Update FSF's address.
[bpt/emacs.git] / lisp / gnus.el
CommitLineData
41487370 1;;; gnus.el --- a newsreader for GNU Emacs
b578f267 2
732be465 3;; Copyright (C) 1987,88,89,90,93,94,95 Free Software Foundation, Inc.
44cdca98 4
41487370
LMI
5;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
44cdca98 7;; Keywords: news
e5167999 8
745bc783
JB
9;; This file is part of GNU Emacs.
10
08b684de
RS
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
e5167999 13;; the Free Software Foundation; either version 2, or (at your option)
08b684de
RS
14;; any later version.
15
745bc783 16;; GNU Emacs is distributed in the hope that it will be useful,
08b684de
RS
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
745bc783 20
08b684de 21;; You should have received a copy of the GNU General Public License
b578f267
EN
22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
745bc783 25
e5167999
ER
26;;; Commentary:
27
41487370
LMI
28;; Although Gnus looks suspiciously like GNUS, it isn't quite the same
29;; beast. Most internal structures have been changed. If you have
30;; written packages that depend on any of the hash tables,
31;; `gnus-newsrc-alist', `gnus-killed-assoc', marked lists, the .newsrc
32;; buffer, or internal knowledge of the `nntp-header-' macros, or
33;; dependence on the buffers having a certain format, your code will
34;; fail.
44cdca98
RS
35
36;;; Code:
745bc783 37
41487370
LMI
38(eval '(run-hooks 'gnus-load-hook))
39
745bc783 40(require 'mail-utils)
70fcd1c2 41(require 'timezone)
41487370
LMI
42(require 'nnheader)
43
44;; Site dependent variables. These variables should be defined in
45;; paths.el.
745bc783 46
44cdca98 47(defvar gnus-default-nntp-server nil
41487370
LMI
48 "Specify a default NNTP server.
49This variable should be defined in paths.el, and should never be set
50by the user.
51If you want to change servers, you should use `gnus-select-method'.
52See the documentation to that variable.")
53
54(defconst gnus-backup-default-subscribed-newsgroups
55 '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus")
56 "Default default new newsgroups the first time Gnus is run.
57Should be set in paths.el, and shouldn't be touched by the user.")
58
59(defvar gnus-local-domain nil
60 "Local domain name without a host name.
61The DOMAINNAME environment variable is used instead if it is defined.
62If the `system-name' function returns the full Internet name, there is
63no need to set this variable.")
64
65(defvar gnus-local-organization nil
66 "String with a description of what organization (if any) the user belongs to.
67The ORGANIZATION environment variable is used instead if it is defined.
68If this variable contains a function, this function will be called
69with the current newsgroup name as the argument. The function should
70return a string.
71
72In any case, if the string (either in the variable, in the environment
73variable, or returned by the function) is a file name, the contents of
74this file will be used as the organization.")
75
76(defvar gnus-use-generic-from nil
77 "If nil, the full host name will be the system name prepended to the domain name.
78If this is a string, the full host name will be this string.
79If this is non-nil, non-string, the domain name will be used as the
80full host name.")
81
82(defvar gnus-use-generic-path nil
83 "If nil, use the NNTP server name in the Path header.
84If stringp, use this; if non-nil, use no host name (user name only).")
44cdca98 85
745bc783 86
41487370
LMI
87;; Customization variables
88
89;; Don't touch this variable.
343fbb30 90(defvar gnus-nntp-service "nntp"
b027f415 91 "*NNTP service name (\"nntp\" or 119).
41487370
LMI
92This is an obsolete variable, which is scarcely used. If you use an
93nntp server for your newsgroup and want to change the port number
94used to 899, you would say something along these lines:
b027f415 95
41487370
LMI
96 (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))")
97
98(defvar gnus-select-method
99 (nconc
100 (list 'nntp (or (getenv "NNTPSERVER")
101 (if (and gnus-default-nntp-server
102 (not (string= gnus-default-nntp-server "")))
103 gnus-default-nntp-server)
104 (system-name)))
105 (if (or (null gnus-nntp-service)
106 (equal gnus-nntp-service "nntp"))
107 nil
108 (list gnus-nntp-service)))
109 "*Default method for selecting a newsgroup.
110This variable should be a list, where the first element is how the
111news is to be fetched, the second is the address.
112
113For instance, if you want to get your news via NNTP from
114\"flab.flab.edu\", you could say:
115
116(setq gnus-select-method '(nntp \"flab.flab.edu\"))
117
118If you want to use your local spool, say:
119
120(setq gnus-select-method (list 'nnspool (system-name)))
121
122If you use this variable, you must set `gnus-nntp-server' to nil.
123
124There is a lot more to know about select methods and virtual servers -
125see the manual for details.")
126
127;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
128(defvar gnus-post-method nil
129 "*Preferred method for posting USENET news.
130If this variable is nil, Gnus will use the current method to decide
131which method to use when posting. If it is non-nil, it will override
132the current method. This method will not be used in mail groups and
133the like, only in \"real\" newsgroups.
134
135The value must be a valid method as discussed in the documentation of
136`gnus-select-method'.")
137
138(defvar gnus-refer-article-method nil
139 "*Preferred method for fetching an article by Message-ID.
140If you are reading news from the local spool (with nnspool), fetching
141articles by Message-ID is painfully slow. By setting this method to an
142nntp method, you might get acceptable results.
143
144The value of this variable must be a valid select method as discussed
145in the documentation of `gnus-select-method'")
146
147(defvar gnus-secondary-select-methods nil
148 "*A list of secondary methods that will be used for reading news.
149This is a list where each element is a complete select method (see
150`gnus-select-method').
151
152If, for instance, you want to read your mail with the nnml backend,
153you could set this variable:
154
155(setq gnus-secondary-select-methods '((nnml \"\")))")
343fbb30 156
41487370
LMI
157(defvar gnus-secondary-servers nil
158 "*List of NNTP servers that the user can choose between interactively.
159To make Gnus query you for a server, you have to give `gnus' a
160non-numeric prefix - `C-u M-x gnus', in short.")
161
162(defvar gnus-nntp-server nil
163 "*The name of the host running the NNTP server.
164This variable is semi-obsolete. Use the `gnus-select-method'
165variable instead.")
166
167(defvar gnus-startup-file "~/.newsrc"
168 "*Your `.newsrc' file.
169`.newsrc-SERVER' will be used instead if that exists.")
170
171(defvar gnus-init-file "~/.gnus"
172 "*Your Gnus elisp startup file.
173If a file with the .el or .elc suffixes exist, it will be read
174instead.")
175
176(defvar gnus-group-faq-directory
177 "/ftp@mirrors.aol.com:/pub/rtfm/usenet/"
178 "*Directory where the group FAQs are stored.
179This will most commonly be on a remote machine, and the file will be
180fetched by ange-ftp.
181
182Note that Gnus uses an aol machine as the default directory. If this
183feels fundamentally unclean, just think of it as a way to finally get
184something of value back from them.
185
186If the default site is too slow, try one of these:
187
188 North America: ftp.uu.net /usenet/news.answers
189 mirrors.aol.com /pub/rtfm/usenet
190 ftp.seas.gwu.edu /pub/rtfm
191 rtfm.mit.edu /pub/usenet/news.answers
192 Europe: ftp.uni-paderborn.de /pub/FAQ
193 ftp.Germany.EU.net /pub/newsarchive/news.answers
194 ftp.sunet.se /pub/usenet
195 Asia: nctuccca.edu.tw /USENET/FAQ
196 hwarang.postech.ac.kr /pub/usenet/news.answers
197 ftp.hk.super.net /mirror/faqs")
198
199(defvar gnus-group-archive-directory
200 "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
201 "*The address of the (ding) archives.")
202
203(defvar gnus-group-recent-archive-directory
204 "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
205 "*The address of the most recent (ding) articles.")
206
207(defvar gnus-default-subscribed-newsgroups nil
208 "*This variable lists what newsgroups should be subscribed the first time Gnus is used.
209It should be a list of strings.
210If it is `t', Gnus will not do anything special the first time it is
211started; it'll just use the normal newsgroups subscription methods.")
745bc783
JB
212
213(defvar gnus-use-cross-reference t
41487370 214 "*Non-nil means that cross referenced articles will be marked as read.
b027f415 215If nil, ignore cross references. If t, mark articles as read in
41487370
LMI
216subscribed newsgroups. If neither t nor nil, mark as read in all
217newsgroups.")
745bc783 218
41487370
LMI
219(defvar gnus-use-dribble-file t
220 "*Non-nil means that Gnus will use a dribble file to store user updates.
221If Emacs should crash without saving the .newsrc files, complete
222information can be restored from the dribble file.")
745bc783 223
41487370
LMI
224(defvar gnus-asynchronous nil
225 "*If non-nil, Gnus will supply backends with data needed for async article fetching.")
226
227(defvar gnus-asynchronous-article-function nil
228 "*Function for picking articles to pre-fetch, possibly.")
229
230(defvar gnus-score-file-single-match-alist nil
231 "*Alist mapping regexps to lists of score files.
232Each element of this alist should be of the form
233 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
234
235If the name of a group is matched by REGEXP, the corresponding scorefiles
236will be used for that group.
237The first match found is used, subsequent matching entries are ignored (to
238use multiple matches, see gnus-score-file-multiple-match-alist).
239
240These score files are loaded in addition to any files returned by
241gnus-score-find-score-files-function (which see).")
242
243(defvar gnus-score-file-multiple-match-alist nil
244 "*Alist mapping regexps to lists of score files.
245Each element of this alist should be of the form
246 (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
247
248If the name of a group is matched by REGEXP, the corresponding scorefiles
249will be used for that group.
250If multiple REGEXPs match a group, the score files corresponding to each
251match will be used (for only one match to be used, see
252gnus-score-file-single-match-alist).
253
254These score files are loaded in addition to any files returned by
255gnus-score-find-score-files-function (which see).")
256
257
258(defvar gnus-score-file-suffix "SCORE"
259 "*Suffix of the score files.")
260
261(defvar gnus-adaptive-file-suffix "ADAPT"
262 "*Suffix of the adaptive score files.")
263
264(defvar gnus-score-find-score-files-function 'gnus-score-find-bnews
265 "*Function used to find score files.
266The function will be called with the group name as the argument, and
267should return a list of score files to apply to that group. The score
268files do not actually have to exist.
745bc783 269
41487370 270Predefined values are:
745bc783 271
41487370
LMI
272gnus-score-find-single: Only apply the group's own score file.
273gnus-score-find-hierarchical: Also apply score files from parent groups.
274gnus-score-find-bnews: Apply score files whose names matches.
745bc783 275
41487370 276See the documentation to these functions for more information.
745bc783 277
41487370
LMI
278This variable can also be a list of functions to be called. Each
279function should either return a list of score files, or a list of
280score alists.")
745bc783 281
41487370
LMI
282(defvar gnus-score-interactive-default-score 1000
283 "*Scoring commands will raise/lower the score with this number as the default.")
745bc783 284
41487370
LMI
285(defvar gnus-large-newsgroup 200
286 "*The number of articles which indicates a large newsgroup.
287If the number of articles in a newsgroup is greater than this value,
288confirmation is required for selecting the newsgroup.")
289
290;; Suggested by Andrew Eskilsson <pi92ae@lelle.pt.hk-r.se>.
291(defvar gnus-no-groups-message "No news is horrible news"
292 "*Message displayed by Gnus when no groups are available.")
293
294(defvar gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix)))
295 "*Non-nil means that the default name of a file to save articles in is the group name.
296If it's nil, the directory form of the group name is used instead.
297
298If this variable is a list, and the list contains the element
299`not-score', long file names will not be used for score files; if it
300contains the element `not-save', long file names will not be used for
301saving; and if it contains the element `not-kill', long file names
302will not be used for kill files.")
303
304(defvar gnus-article-save-directory (or (getenv "SAVEDIR") "~/News/")
305 "*Name of the directory articles will be saved in (default \"~/News\").
745bc783
JB
306Initialized from the SAVEDIR environment variable.")
307
41487370
LMI
308(defvar gnus-kill-files-directory (or (getenv "SAVEDIR") "~/News/")
309 "*Name of the directory where kill files will be stored (default \"~/News\").
1507a647
RS
310Initialized from the SAVEDIR environment variable.")
311
41487370 312(defvar gnus-default-article-saver 'gnus-summary-save-in-rmail
b027f415 313 "*A function to save articles in your favorite format.
745bc783
JB
314The function must be interactively callable (in other words, it must
315be an Emacs command).
316
41487370
LMI
317Gnus provides the following functions:
318
319* gnus-summary-save-in-rmail (Rmail format)
320* gnus-summary-save-in-mail (Unix mail format)
321* gnus-summary-save-in-folder (MH folder)
322* gnus-summary-save-in-file (article format).
323* gnus-summary-save-in-vm (use VM's folder format).")
745bc783
JB
324
325(defvar gnus-rmail-save-name (function gnus-plain-save-name)
b027f415 326 "*A function generating a file name to save articles in Rmail format.
745bc783
JB
327The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.")
328
329(defvar gnus-mail-save-name (function gnus-plain-save-name)
b027f415 330 "*A function generating a file name to save articles in Unix mail format.
745bc783
JB
331The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.")
332
333(defvar gnus-folder-save-name (function gnus-folder-save-name)
b027f415 334 "*A function generating a file name to save articles in MH folder.
745bc783
JB
335The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER.")
336
337(defvar gnus-file-save-name (function gnus-numeric-save-name)
b027f415 338 "*A function generating a file name to save articles in article format.
41487370
LMI
339The function is called with NEWSGROUP, HEADERS, and optional
340LAST-FILE.")
745bc783 341
41487370
LMI
342(defvar gnus-split-methods nil
343 "*Variable used to suggest where articles are to be saved.
344The syntax of this variable is the same as `nnmail-split-methods'.
345
346For instance, if you would like to save articles related to Gnus in
347the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
348you could set this variable to something like:
349
350 '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
351 (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))")
352
353(defvar gnus-save-score nil
354 "*If non-nil, save group scoring info.")
355
356(defvar gnus-use-adaptive-scoring nil
357 "*If non-nil, use some adaptive scoring scheme.")
358
359(defvar gnus-use-cache nil
360 "*If non-nil, Gnus will cache (some) articles locally.")
361
362(defvar gnus-use-scoring t
363 "*If non-nil, enable scoring.")
364
365(defvar gnus-fetch-old-headers nil
366 "*Non-nil means that Gnus will try to build threads by grabbing old headers.
367If an unread article in the group refers to an older, already read (or
368just marked as read) article, the old article will not normally be
369displayed in the Summary buffer. If this variable is non-nil, Gnus
370will attempt to grab the headers to the old articles, and thereby
371build complete threads. If it has the value `some', only enough
372headers to connect otherwise loose threads will be displayed.
373
374The server has to support XOVER for any of this to work.")
375
376;see gnus-cus.el
377;(defvar gnus-visual t
378; "*If non-nil, will do various highlighting.
379;If nil, no mouse highlights (or any other highlights) will be
380;performed. This might speed up Gnus some when generating large group
381;and summary buffers.")
745bc783
JB
382
383(defvar gnus-novice-user t
41487370
LMI
384 "*Non-nil means that you are a usenet novice.
385If non-nil, verbose messages may be displayed and confirmations may be
386required.")
387
388(defvar gnus-expert-user nil
389 "*Non-nil means that you will never be asked for confirmation about anything.
390And that means *anything*.")
391
392(defvar gnus-verbose 7
393 "*Integer that says how verbose Gnus should be.
394The higher the number, the more messages Gnus will flash to say what
395it's doing. At zero, Gnus will be totally mute; at five, Gnus will
396display most important messages; and at ten, Gnus will keep on
397jabbering all the time.")
398
399(defvar gnus-keep-same-level nil
400 "*Non-nil means that the next newsgroup after the current will be on the same level.
401When you type, for instance, `n' after reading the last article in the
402current newsgroup, you will go to the next newsgroup. If this variable
403is nil, the next newsgroup will be the next from the group
404buffer.
405If this variable is non-nil, Gnus will either put you in the
406next newsgroup with the same level, or, if no such newsgroup is
407available, the next newsgroup with the lowest possible level higher
408than the current level.
409If this variable is `best', Gnus will make the next newsgroup the one
410with the best level.")
411
412(defvar gnus-summary-make-false-root 'adopt
413 "*nil means that Gnus won't gather loose threads.
414If the root of a thread has expired or been read in a previous
415session, the information necessary to build a complete thread has been
416lost. Instead of having many small sub-threads from this original thread
417scattered all over the summary buffer, Gnus can gather them.
418
419If non-nil, Gnus will try to gather all loose sub-threads from an
420original thread into one large thread.
421
422If this variable is non-nil, it should be one of `none', `adopt',
423`dummy' or `empty'.
424
425If this variable is `none', Gnus will not make a false root, but just
426present the sub-threads after another.
427If this variable is `dummy', Gnus will create a dummy root that will
428have all the sub-threads as children.
429If this variable is `adopt', Gnus will make one of the \"children\"
430the parent and mark all the step-children as such.
431If this variable is `empty', the \"children\" are printed with empty
432subject fields. (Or rather, they will be printed with a string
433given by the `gnus-summary-same-subject' variable.)")
434
435(defvar gnus-summary-gather-subject-limit nil
436 "*Maximum length of subject comparisons when gathering loose threads.
437Use nil to compare full subjects. Setting this variable to a low
438number will help gather threads that have been corrupted by
439newsreaders chopping off subject lines, but it might also mean that
440unrelated articles that have subject that happen to begin with the
441same few characters will be incorrectly gathered.
442
443If this variable is `fuzzy', Gnus will use a fuzzy algorithm when
444comparing subjects.")
445
446;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
447(defvar gnus-summary-same-subject ""
448 "*String indicating that the current article has the same subject as the previous.
449This variable will only be used if the value of
450`gnus-summary-make-false-root' is `empty'.")
451
452(defvar gnus-summary-goto-unread t
453 "*If non-nil, marking commands will go to the next unread article.")
454
455(defvar gnus-group-goto-unread t
456 "*If non-nil, movement commands will go to the next unread and subscribed group.")
457
458(defvar gnus-check-new-newsgroups t
459 "*Non-nil means that Gnus will add new newsgroups at startup.
460If this variable is `ask-server', Gnus will ask the server for new
461groups since the last time it checked. This means that the killed list
462is no longer necessary, so you could set `gnus-save-killed-list' to
463nil.
464
465A variant is to have this variable be a list of select methods. Gnus
466will then use the `ask-server' method on all these select methods to
467query for new groups from all those servers.
468
469Eg.
470 (setq gnus-check-new-newsgroups
471 '((nntp \"some.server\") (nntp \"other.server\")))
472
473If this variable is nil, then you have to tell Gnus explicitly to
474check for new newsgroups with \\<gnus-group-mode-map>\\[gnus-find-new-newsgroups].")
475
476(defvar gnus-check-bogus-newsgroups nil
477 "*Non-nil means that Gnus will check and remove bogus newsgroup at startup.
478If this variable is nil, then you have to tell Gnus explicitly to
479check for bogus newsgroups with \\<gnus-group-mode-map>\\[gnus-group-check-bogus-groups].")
480
481(defvar gnus-read-active-file t
482 "*Non-nil means that Gnus will read the entire active file at startup.
483If this variable is nil, Gnus will only know about the groups in your
484`.newsrc' file.
485
486If this variable is `some', Gnus will try to only read the relevant
487parts of the active file from the server. Not all servers support
488this, and it might be quite slow with other servers, but this should
489generally be faster than both the t and nil value.
490
491If you set this variable to nil or `some', you probably still want to
492be told about new newsgroups that arrive. To do that, set
493`gnus-check-new-newsgroups' to `ask-server'. This may not work
494properly with all servers.")
495
496(defvar gnus-level-subscribed 5
497 "*Groups with levels less than or equal to this variable are subscribed.")
498
499(defvar gnus-level-unsubscribed 7
500 "*Groups with levels less than or equal to this variable are unsubscribed.
501Groups with levels less than `gnus-level-subscribed', which should be
502less than this variable, are subscribed.")
503
504(defvar gnus-level-zombie 8
505 "*Groups with this level are zombie groups.")
506
507(defvar gnus-level-killed 9
508 "*Groups with this level are killed.")
509
510(defvar gnus-level-default-subscribed 3
511 "*New subscribed groups will be subscribed at this level.")
512
513(defvar gnus-level-default-unsubscribed 6
514 "*New unsubscribed groups will be unsubscribed at this level.")
515
516(defvar gnus-activate-foreign-newsgroups 4
517 "*If nil, Gnus will not check foreign newsgroups at startup.
518If it is non-nil, it should be a number between one and nine. Foreign
519newsgroups that have a level lower or equal to this number will be
520activated on startup. For instance, if you want to active all
521subscribed newsgroups, but not the rest, you'd set this variable to
522`gnus-level-subscribed'.
523
524If you subscribe to lots of newsgroups from different servers, startup
525might take a while. By setting this variable to nil, you'll save time,
526but you won't be told how many unread articles there are in the
527groups.")
528
529(defvar gnus-save-newsrc-file t
530 "*Non-nil means that Gnus will save the `.newsrc' file.
531Gnus always saves its own startup file, which is called
532\".newsrc.eld\". The file called \".newsrc\" is in a format that can
533be readily understood by other newsreaders. If you don't plan on
534using other newsreaders, set this variable to nil to save some time on
535exit.")
536
537(defvar gnus-save-killed-list t
538 "*If non-nil, save the list of killed groups to the startup file.
539This will save both time (when starting and quitting) and space (both
540memory and disk), but it will also mean that Gnus has no record of
541which groups are new and which are old, so the automatic new
542newsgroups subscription methods become meaningless. You should always
543set `gnus-check-new-newsgroups' to `ask-server' or nil if you set this
544variable to nil.")
b027f415
RS
545
546(defvar gnus-interactive-catchup t
41487370 547 "*If non-nil, require your confirmation when catching up a group.")
745bc783
JB
548
549(defvar gnus-interactive-post t
41487370 550 "*If non-nil, group name will be asked for when posting.")
745bc783 551
b027f415 552(defvar gnus-interactive-exit t
41487370
LMI
553 "*If non-nil, require your confirmation when exiting Gnus.")
554
555(defvar gnus-kill-killed t
556 "*If non-nil, Gnus will apply kill files to already killed articles.
557If it is nil, Gnus will never apply kill files to articles that have
558already been through the scoring process, which might very well save lots
559of time.")
560
561(defvar gnus-extract-address-components 'gnus-extract-address-components
562 "*Function for extracting address components from a From header.
563Two pre-defined function exist: `gnus-extract-address-components',
564which is the default, quite fast, and too simplistic solution, and
565`mail-extract-address-components', which works much better, but is
566slower.")
b027f415 567
41487370
LMI
568(defvar gnus-summary-default-score 0
569 "*Default article score level.
570If this variable is nil, scoring will be disabled.")
745bc783 571
41487370
LMI
572(defvar gnus-summary-zcore-fuzz 0
573 "*Fuzziness factor for the zcore in the summary buffer.
574Articles with scores closer than this to `gnus-summary-default-score'
575will not be marked.")
576
577(defvar gnus-simplify-subject-fuzzy-regexp nil
578 "*Regular expression that will be removed from subject strings if
579fuzzy subject simplification is selected.")
580
581(defvar gnus-group-default-list-level gnus-level-subscribed
582 "*Default listing level.
583Ignored if `gnus-group-use-permanent-levels' is non-nil.")
584
585(defvar gnus-group-use-permanent-levels nil
586 "*If non-nil, once you set a level, Gnus will use this level.")
b027f415
RS
587
588(defvar gnus-show-mime nil
41487370
LMI
589 "*If non-nil, do mime processing of articles.
590The articles will simply be fed to the function given by
591`gnus-show-mime-method'.")
745bc783 592
41487370
LMI
593(defvar gnus-strict-mime t
594 "*If nil, decode MIME header even if there is not Mime-Version field.")
595
596(defvar gnus-show-mime-method (function metamail-buffer)
597 "*Function to process a MIME message.
598The function is called from the article buffer.")
745bc783 599
41487370
LMI
600(defvar gnus-show-threads t
601 "*If non-nil, display threads in summary mode.")
745bc783
JB
602
603(defvar gnus-thread-hide-subtree nil
41487370
LMI
604 "*If non-nil, hide all threads initially.
605If threads are hidden, you have to run the command
606`gnus-summary-show-thread' by hand or use `gnus-select-article-hook'
607to expose hidden threads.")
745bc783
JB
608
609(defvar gnus-thread-hide-killed t
41487370 610 "*If non-nil, hide killed threads automatically.")
745bc783
JB
611
612(defvar gnus-thread-ignore-subject nil
41487370
LMI
613 "*If non-nil, ignore subjects and do all threading based on the Reference header.
614If nil, which is the default, articles that have different subjects
615from their parents will start separate threads.")
745bc783
JB
616
617(defvar gnus-thread-indent-level 4
41487370
LMI
618 "*Number that says how much each sub-thread should be indented.")
619
620(defvar gnus-ignored-newsgroups
621 (purecopy (mapconcat 'identity
622 '("^to\\." ; not "real" groups
623 "^[0-9. \t]+ " ; all digits in name
624 "[][\"#'()]" ; bogus characters
625 )
626 "\\|"))
8483b957 627 "*A regexp to match uninteresting newsgroups in the active file.
b027f415
RS
628Any lines in the active file matching this regular expression are
629removed from the newsgroup list before anything else is done to it,
41487370 630thus making them effectively non-existent.")
745bc783
JB
631
632(defvar gnus-ignored-headers
41487370
LMI
633 "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:\\|^Received:\\|^Mail-from:"
634 "*All headers that match this regexp will be hidden.
635If `gnus-visible-headers' is non-nil, this variable will be ignored.")
636
637(defvar gnus-visible-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:"
638 "*All headers that do not match this regexp will be hidden.
639If this variable is non-nil, `gnus-ignored-headers' will be ignored.")
640
641(defvar gnus-sorted-header-list
642 '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:"
643 "^Cc:" "^Date:" "^Organization:")
644 "*This variable is a list of regular expressions.
645If it is non-nil, headers that match the regular expressions will
646be placed first in the article buffer in the sequence specified by
647this list.")
745bc783
JB
648
649(defvar gnus-show-all-headers nil
41487370 650 "*If non-nil, don't hide any headers.")
745bc783 651
b027f415 652(defvar gnus-save-all-headers t
41487370 653 "*If non-nil, don't remove any headers before saving.")
745bc783 654
41487370
LMI
655(defvar gnus-inhibit-startup-message nil
656 "*If non-nil, the startup message will not be displayed.")
657
658(defvar gnus-signature-separator "^-- *$"
659 "Regexp matching signature separator.")
745bc783
JB
660
661(defvar gnus-auto-extend-newsgroup t
41487370 662 "*If non-nil, extend newsgroup forward and backward when requested.")
745bc783
JB
663
664(defvar gnus-auto-select-first t
41487370 665 "*If non-nil, select the first unread article when entering a group.
745bc783 666If you want to prevent automatic selection of the first unread article
41487370
LMI
667in some newsgroups, set the variable to nil in
668`gnus-select-group-hook'.")
745bc783
JB
669
670(defvar gnus-auto-select-next t
41487370
LMI
671 "*If non-nil, offer to go to the next group from the end of the previous.
672If the value is t and the next newsgroup is empty, Gnus will exit
673summary mode and go back to group mode. If the value is neither nil
674nor t, Gnus will select the following unread newsgroup. In
675particular, if the value is the symbol `quietly', the next unread
676newsgroup will be selected without any confirmations.")
745bc783
JB
677
678(defvar gnus-auto-select-same nil
41487370 679 "*If non-nil, select the next article with the same subject.")
745bc783 680
41487370
LMI
681(defvar gnus-summary-check-current nil
682 "*If non-nil, consider the current article when moving.
683The \"unread\" movement commands will stay on the same line if the
684current article is unread.")
b027f415 685
41487370
LMI
686(defvar gnus-auto-center-summary t
687 "*If non-nil, always center the current summary buffer.")
745bc783
JB
688
689(defvar gnus-break-pages t
41487370
LMI
690 "*If non-nil, do page breaking on articles.
691The page delimiter is specified by the `gnus-page-delimiter'
692variable.")
745bc783
JB
693
694(defvar gnus-page-delimiter "^\^L"
41487370
LMI
695 "*Regexp describing what to use as article page delimiters.
696The default value is \"^\^L\", which is a form linefeed at the
697beginning of a line.")
745bc783
JB
698
699(defvar gnus-use-full-window t
41487370
LMI
700 "*If non-nil, use the entire Emacs screen.")
701
702(defvar gnus-window-configuration nil
703 "Obsolete variable. See `gnus-buffer-configuration'.")
704
705(defvar gnus-buffer-configuration
706 '((group ([group 1.0 point]
707 (if gnus-carpal [group-carpal 4])))
708 (summary ([summary 1.0 point]
709 (if gnus-carpal [summary-carpal 4])))
710 (article ([summary 0.25 point]
711 (if gnus-carpal [summary-carpal 4])
712 [article 1.0]))
713 (server ([server 1.0 point]
714 (if gnus-carpal [server-carpal 2])))
715 (browse ([browse 1.0 point]
716 (if gnus-carpal [browse-carpal 2])))
717 (group-mail ([mail 1.0 point]))
718 (summary-mail ([mail 1.0 point]))
719 (summary-reply ([article 0.5]
720 [mail 1.0 point]))
721 (info ([nil 1.0 point]))
722 (summary-faq ([summary 0.25]
723 [faq 1.0 point]))
724 (edit-group ([group 0.5]
725 [edit-group 1.0 point]))
726 (edit-server ([server 0.5]
727 [edit-server 1.0 point]))
728 (edit-score ([summary 0.25]
729 [edit-score 1.0 point]))
730 (post ([post 1.0 point]))
731 (reply ([article 0.5]
732 [mail 1.0 point]))
733 (mail-forward ([mail 1.0 point]))
734 (post-forward ([post 1.0 point]))
735 (reply-yank ([mail 1.0 point]))
736 (followup ([article 0.5]
737 [post 1.0 point]))
738 (followup-yank ([post 1.0 point])))
739 "Window configuration for all possible Gnus buffers.
740This variable is a list of lists. Each of these lists has a NAME and
b94ae5f7 741a RULE. The NAMEs are common-sense names like `group', which names a
41487370
LMI
742rule used when displaying the group buffer; `summary', which names a
743rule for what happens when you enter a group and do not display an
744article buffer; and so on. See the value of this variable for a
745complete list of NAMEs.
746
747Each RULE is a list of vectors. The first element in this vector is
748the name of the buffer to be displayed; the second element is the
749percentage of the screen this buffer is to occupy (a number in the
7500.0-0.99 range); the optional third element is `point', which should
751be present to denote which buffer point is to go to after making this
752buffer configuration.")
753
754(defvar gnus-window-to-buffer
755 '((group . gnus-group-buffer)
756 (summary . gnus-summary-buffer)
757 (article . gnus-article-buffer)
758 (server . gnus-server-buffer)
759 (browse . "*Gnus Browse Server*")
760 (edit-group . gnus-group-edit-buffer)
761 (edit-server . gnus-server-edit-buffer)
762 (group-carpal . gnus-carpal-group-buffer)
763 (summary-carpal . gnus-carpal-summary-buffer)
764 (server-carpal . gnus-carpal-server-buffer)
765 (browse-carpal . gnus-carpal-browse-buffer)
766 (edit-score . gnus-score-edit-buffer)
767 (mail . gnus-mail-buffer)
768 (post . gnus-post-news-buffer)
769 (faq . gnus-faq-buffer))
770 "Mapping from short symbols to buffer names or buffer variables.")
771
772(defvar gnus-carpal nil
773 "*If non-nil, display clickable icons.")
774
775(defvar gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies
776 "*Function called with a group name when new group is detected.
777A few pre-made functions are supplied: `gnus-subscribe-randomly'
778inserts new groups at the beginning of the list of groups;
779`gnus-subscribe-alphabetically' inserts new groups in strict
780alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
781in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
782for your decision.")
783
784;; Suggested by a bug report by Hallvard B Furuseth.
785;; <h.b.furuseth@usit.uio.no>.
786(defvar gnus-subscribe-options-newsgroup-method
b027f415 787 (function gnus-subscribe-alphabetically)
41487370
LMI
788 "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines.
789If, for instance, you want to subscribe to all newsgroups in the
790\"no\" and \"alt\" hierarchies, you'd put the following in your
791.newsrc file:
792
793options -n no.all alt.all
794
795Gnus will the subscribe all new newsgroups in these hierarchies with
796the subscription method in this variable.")
797
798(defvar gnus-subscribe-hierarchical-interactive nil
799 "*If non-nil, Gnus will offer to subscribe hierarchically.
800When a new hierarchy appears, Gnus will ask the user:
801
802'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys):
803
804If the user pressed `d', Gnus will descend the hierarchy, `y' will
805subscribe to all newsgroups in the hierarchy and `s' will skip this
806hierarchy in its entirety.")
807
808(defvar gnus-group-sort-function 'gnus-group-sort-by-alphabet
809 "*Function used for sorting the group buffer.
810This function will be called with group info entries as the arguments
811for the groups to be sorted. Pre-made functions include
812`gnus-group-sort-by-alphabet', `gnus-group-sort-by-unread' and
813`gnus-group-sort-by-level'")
814
815;; Mark variables suggested by Thomas Michanek
816;; <Thomas.Michanek@telelogic.se>.
817(defvar gnus-unread-mark ?
818 "*Mark used for unread articles.")
819(defvar gnus-ticked-mark ?!
820 "*Mark used for ticked articles.")
821(defvar gnus-dormant-mark ??
822 "*Mark used for dormant articles.")
823(defvar gnus-del-mark ?r
824 "*Mark used for del'd articles.")
825(defvar gnus-read-mark ?R
826 "*Mark used for read articles.")
827(defvar gnus-expirable-mark ?E
828 "*Mark used for expirable articles.")
829(defvar gnus-killed-mark ?K
830 "*Mark used for killed articles.")
831(defvar gnus-kill-file-mark ?X
832 "*Mark used for articles killed by kill files.")
833(defvar gnus-low-score-mark ?Y
834 "*Mark used for articles with a low score.")
835(defvar gnus-catchup-mark ?C
836 "*Mark used for articles that are caught up.")
837(defvar gnus-replied-mark ?A
838 "*Mark used for articles that have been replied to.")
839(defvar gnus-process-mark ?#
840 "*Process mark.")
841(defvar gnus-ancient-mark ?O
842 "*Mark used for ancient articles.")
843(defvar gnus-canceled-mark ?G
844 "*Mark used for canceled articles.")
845(defvar gnus-score-over-mark ?+
846 "*Score mark used for articles with high scores.")
847(defvar gnus-score-below-mark ?-
848 "*Score mark used for articles with low scores.")
849(defvar gnus-empty-thread-mark ?
850 "*There is no thread under the article.")
851(defvar gnus-not-empty-thread-mark ?=
852 "*There is a thread under the article.")
853(defvar gnus-dummy-mark ?Z
854 "*This is a dummy article.")
855
856(defvar gnus-view-pseudo-asynchronously nil
857 "*If non-nil, Gnus will view pseudo-articles asynchronously.")
858
859(defvar gnus-view-pseudos nil
860 "*If `automatic', pseudo-articles will be viewed automatically.
861If `not-confirm', pseudos will be viewed automatically, and the user
862will not be asked to confirm the command.")
863
864(defvar gnus-view-pseudos-separately t
865 "*If non-nil, one pseudo-article will be created for each file to be viewed.
866If nil, all files that use the same viewing command will be given as a
867list of parameters to that command.")
868
869(defvar gnus-group-line-format "%M%S%p%5y: %(%g%)\n"
870 "*Format of group lines.
871It works along the same lines as a normal formatting string,
872with some simple extensions.
873
874%M Only marked articles (character, \"*\" or \" \")
875%S Whether the group is subscribed (character, \"U\", \"K\", \"Z\" or \" \")
876%L Level of subscribedness (integer)
877%N Number of unread articles (integer)
878%I Number of dormant articles (integer)
879%i Number of ticked and dormant (integer)
880%T Number of ticked articles (integer)
881%R Number of read articles (integer)
882%t Total number of articles (integer)
883%y Number of unread, unticked articles (integer)
884%G Group name (string)
885%g Qualified group name (string)
886%D Group description (string)
887%s Select method (string)
888%o Moderated group (char, \"m\")
889%p Process mark (char)
890%O Moderated group (string, \"(m)\" or \"\")
891%n Select from where (string)
892%z A string that look like `<%s:%n>' if a foreign select method is used
893%u User defined specifier. The next character in the format string should
894 be a letter. Gnus will call the function gnus-user-format-function-X,
895 where X is the letter following %u. The function will be passed the
896 current header as argument. The function should return a string, which
897 will be inserted into the buffer just like information from any other
898 group specifier.
899
900Text between %( and %) will be highlighted with `gnus-mouse-face' when
901the mouse point move inside the area. There can only be one such area.
902
903Note that this format specification is not always respected. For
904reasons of efficiency, when listing killed groups, this specification
905is ignored altogether. If the spec is changed considerably, your
906output may end up looking strange when listing both alive and killed
907groups.
908
909If you use %o or %O, reading the active file will be slower and quite
910a bit of extra memory will be used. %D will also worsen performance.
911Also note that if you change the format specification to include any
912of these specs, you must probably re-start Gnus to see them go into
913effect.")
914
915(defvar gnus-summary-line-format "%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n"
916 "*The format specification of the lines in the summary buffer.
917
918It works along the same lines as a normal formatting string,
919with some simple extensions.
920
921%N Article number, left padded with spaces (string)
922%S Subject (string)
923%s Subject if it is at the root of a thread, and \"\" otherwise (string)
924%n Name of the poster (string)
925%a Extracted name of the poster (string)
926%A Extracted address of the poster (string)
927%F Contents of the From: header (string)
928%x Contents of the Xref: header (string)
929%D Date of the article (string)
930%d Date of the article (string) in DD-MMM format
931%M Message-id of the article (string)
932%r References of the article (string)
933%c Number of characters in the article (integer)
934%L Number of lines in the article (integer)
935%I Indentation based on thread level (a string of spaces)
936%T A string with two possible values: 80 spaces if the article
937 is on thread level two or larger and 0 spaces on level one
938%R \"A\" if this article has been replied to, \" \" otherwise (character)
939%U Status of this article (character, \"R\", \"K\", \"-\" or \" \")
940%[ Opening bracket (character, \"[\" or \"<\")
941%] Closing bracket (character, \"]\" or \">\")
942%> Spaces of length thread-level (string)
943%< Spaces of length (- 20 thread-level) (string)
944%i Article score (number)
945%z Article zcore (character)
946%t Number of articles under the current thread (number).
947%e Whether the thread is empty or not (character).
948%u User defined specifier. The next character in the format string should
949 be a letter. Gnus will call the function gnus-user-format-function-X,
950 where X is the letter following %u. The function will be passed the
951 current header as argument. The function should return a string, which
952 will be inserted into the summary just like information from any other
953 summary specifier.
954
955Text between %( and %) will be highlighted with `gnus-mouse-face'
956when the mouse point is placed inside the area. There can only be one
957such area.
958
959The %U (status), %R (replied) and %z (zcore) specs have to be handled
960with care. For reasons of efficiency, Gnus will compute what column
961these characters will end up in, and \"hard-code\" that. This means that
962it is illegal to have these specs after a variable-length spec. Well,
963you might not be arrested, but your summary buffer will look strange,
964which is bad enough.
965
966The smart choice is to have these specs as for to the left as
967possible.
968
969This restriction may disappear in later versions of Gnus.")
970
971(defvar gnus-summary-dummy-line-format "* : : %S\n"
972 "*The format specification for the dummy roots in the summary buffer.
973It works along the same lines as a normal formatting string,
974with some simple extensions.
975
976%S The subject")
977
6346a6e6 978(defvar gnus-summary-mode-line-format "Gnus: %b [%A] %Z"
41487370
LMI
979 "*The format specification for the summary mode line.")
980
6346a6e6 981(defvar gnus-article-mode-line-format "Gnus: %b %S"
41487370
LMI
982 "*The format specification for the article mode line.")
983
6346a6e6 984(defvar gnus-group-mode-line-format "Gnus: %b {%M:%S} "
41487370
LMI
985 "*The format specification for the group mode line.")
986
987(defvar gnus-valid-select-methods
988 '(("nntp" post address prompt-address)
989 ("nnspool" post)
990 ("nnvirtual" none virtual prompt-address)
991 ("nnmbox" mail respool)
992 ("nnml" mail respool)
993 ("nnmh" mail respool)
994 ("nndir" none prompt-address address)
995 ("nneething" none prompt-address)
996 ("nndigest" none)
997 ("nndoc" none prompt-address)
998 ("nnbabyl" mail respool)
999 ("nnkiboze" post virtual)
1000 ;;("nnsoup" post)
1001 ("nnfolder" mail respool))
1002 "An alist of valid select methods.
1003The first element of each list lists should be a string with the name
1004of the select method. The other elements may be be the category of
1005this method (ie. `post', `mail', `none' or whatever) or other
1006properties that this method has (like being respoolable).
1007If you implement a new select method, all you should have to change is
1008this variable. I think.")
1009
1010(defvar gnus-updated-mode-lines '(group article summary)
1011 "*List of buffers that should update their mode lines.
1012The list may contain the symbols `group', `article' and `summary'. If
1013the corresponding symbol is present, Gnus will keep that mode line
1014updated with information that may be pertinent.
1015If this variable is nil, screen refresh may be quicker.")
1016
1017;; Added by Keinonen Kari <kk85613@cs.tut.fi>.
6346a6e6 1018(defvar gnus-mode-non-string-length nil
41487370
LMI
1019 "*Max length of mode-line non-string contents.
1020If this is nil, Gnus will take space as is needed, leaving the rest
1021of the modeline intact.")
1022
1023;see gnus-cus.el
1024;(defvar gnus-mouse-face 'highlight
1025; "*Face used for mouse highlighting in Gnus.
1026;No mouse highlights will be done if `gnus-visual' is nil.")
1027
1028(defvar gnus-summary-mark-below nil
1029 "*Mark all articles with a score below this variable as read.
1030This variable is local to each summary buffer and usually set by the
1031score file.")
1032
1033(defvar gnus-thread-sort-functions '(gnus-thread-sort-by-number)
1034 "*List of functions used for sorting threads in the summary buffer.
1035By default, threads are sorted by article number.
1036
1037Each function takes two threads and return non-nil if the first thread
1038should be sorted before the other. If you use more than one function,
1039the primary sort function should be the last.
1040
1041Ready-mady functions include `gnus-thread-sort-by-number',
1042`gnus-thread-sort-by-author', `gnus-thread-sort-by-subject',
1043`gnus-thread-sort-by-date', `gnus-thread-sort-by-score' and
1044`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function').")
1045
1046(defvar gnus-thread-score-function '+
1047 "*Function used for calculating the total score of a thread.
1048
1049The function is called with the scores of the article and each
1050subthread and should then return the score of the thread.
1051
1052Some functions you can use are `+', `max', or `min'.")
1053
1054(defvar gnus-options-subscribe nil
1055 "*All new groups matching this regexp will be subscribed unconditionally.
1056Note that this variable deals only with new newsgroups. This variable
1057does not affect old newsgroups.")
1058
1059(defvar gnus-options-not-subscribe nil
1060 "*All new groups matching this regexp will be ignored.
1061Note that this variable deals only with new newsgroups. This variable
1062does not affect old (already subscribed) newsgroups.")
1063
1064(defvar gnus-auto-expirable-newsgroups nil
1065 "*Groups in which to automatically mark read articles as expirable.
1066If non-nil, this should be a regexp that should match all groups in
1067which to perform auto-expiry. This only makes sense for mail groups.")
1068
1069(defvar gnus-hidden-properties '(invisible t intangible t)
1070 "Property list to use for hiding text.")
1071
1072(defvar gnus-modtime-botch nil
1073 "*Non-nil means .newsrc should be deleted prior to save. Its use is
1074due to the bogus appearance that .newsrc was modified on disc.")
1075
1076;; Hooks.
745bc783 1077
b027f415 1078(defvar gnus-group-mode-hook nil
41487370 1079 "*A hook for Gnus group mode.")
745bc783 1080
b027f415 1081(defvar gnus-summary-mode-hook nil
41487370
LMI
1082 "*A hook for Gnus summary mode.
1083This hook is run before any variables are set in the summary buffer.")
745bc783 1084
b027f415 1085(defvar gnus-article-mode-hook nil
41487370
LMI
1086 "*A hook for Gnus article mode.")
1087
1088(defun gnus-summary-prepare-exit-hook nil
1089 "*A hook called when preparing to exit from the summary buffer.
1090It calls `gnus-summary-expire-articles' by default.")
1091(add-hook 'gnus-summary-prepare-exit-hook 'gnus-summary-expire-articles)
745bc783 1092
41487370
LMI
1093(defun gnus-summary-exit-hook nil
1094 "*A hook called on exit from the summary buffer.")
745bc783 1095
b027f415 1096(defvar gnus-open-server-hook nil
41487370
LMI
1097 "*A hook called just before opening connection to the news server.")
1098
1099(defvar gnus-load-hook nil
1100 "*A hook run while Gnus is loaded.")
745bc783 1101
b027f415 1102(defvar gnus-startup-hook nil
41487370
LMI
1103 "*A hook called at startup.
1104This hook is called after Gnus is connected to the NNTP server.")
1105
1106(defvar gnus-get-new-news-hook nil
1107 "*A hook run just before Gnus checks for new news.")
1108
1109(defvar gnus-group-prepare-function 'gnus-group-prepare-flat
1110 "*A function that is called to generate the group buffer.
1111The function is called with three arguments: The first is a number;
1112all group with a level less or equal to that number should be listed,
1113if the second is non-nil, empty groups should also be displayed. If
1114the third is non-nil, it is a number. No groups with a level lower
1115than this number should be displayed.
1116
1117The only current function implemented is `gnus-group-prepare-flat'.")
745bc783 1118
b027f415 1119(defvar gnus-group-prepare-hook nil
41487370
LMI
1120 "*A hook called after the group buffer has been generated.
1121If you want to modify the group buffer, you can use this hook.")
745bc783 1122
b027f415 1123(defvar gnus-summary-prepare-hook nil
41487370
LMI
1124 "*A hook called after the summary buffer has been generated.
1125If you want to modify the summary buffer, you can use this hook.")
745bc783 1126
b027f415 1127(defvar gnus-article-prepare-hook nil
41487370 1128 "*A hook called after an article has been prepared in the article buffer.
745bc783
JB
1129If you want to run a special decoding program like nkf, use this hook.")
1130
41487370
LMI
1131;(defvar gnus-article-display-hook nil
1132; "*A hook called after the article is displayed in the article buffer.
1133;The hook is designed to change the contents of the article
1134;buffer. Typical functions that this hook may contain are
1135;`gnus-article-hide-headers' (hide selected headers),
1136;`gnus-article-maybe-highlight' (perform fancy article highlighting),
1137;`gnus-article-hide-signature' (hide signature) and
1138;`gnus-article-treat-overstrike' (turn \"^H_\" into bold characters).")
1139;(add-hook 'gnus-article-display-hook 'gnus-article-hide-headers-if-wanted)
1140;(add-hook 'gnus-article-display-hook 'gnus-article-treat-overstrike)
1141;(add-hook 'gnus-article-display-hook 'gnus-article-maybe-highlight)
1142
1143(defvar gnus-article-x-face-command
1144 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
1145 "String or function to be executed to display an X-Face header.
1146If it is a string, the command will be executed in a sub-shell
1147asynchronously. The compressed face will be piped to this command.")
1148
1149(defvar gnus-article-x-face-too-ugly nil
1150 "Regexp matching posters whose face shouldn't be shown automatically.")
1151
b027f415
RS
1152(defvar gnus-select-group-hook nil
1153 "*A hook called when a newsgroup is selected.
b027f415
RS
1154
1155If you'd like to simplify subjects like the
1156`gnus-summary-next-same-subject' command does, you can use the
1157following hook:
1158
41487370
LMI
1159 (setq gnus-select-group-hook
1160 (list
8483b957 1161 (lambda ()
41487370
LMI
1162 (mapcar (lambda (header)
1163 (mail-header-set-subject
8483b957
RS
1164 header
1165 (gnus-simplify-subject
41487370
LMI
1166 (mail-header-subject header) 're-only)))
1167 gnus-newsgroup-headers))))")
745bc783 1168
b027f415 1169(defvar gnus-select-article-hook
8483b957 1170 '(gnus-summary-show-thread)
b027f415
RS
1171 "*A hook called when an article is selected.
1172The default hook shows conversation thread subtrees of the selected
41487370 1173article automatically using `gnus-summary-show-thread'.")
745bc783 1174
8483b957 1175(defvar gnus-apply-kill-hook '(gnus-apply-kill-file)
41487370
LMI
1176 "*A hook called to apply kill files to a group.
1177This hook is intended to apply a kill file to the selected newsgroup.
8483b957 1178The function `gnus-apply-kill-file' is called by default.
745bc783 1179
41487370
LMI
1180Since a general kill file is too heavy to use only for a few
1181newsgroups, I recommend you to use a lighter hook function. For
1182example, if you'd like to apply a kill file to articles which contains
745bc783
JB
1183a string `rmgroup' in subject in newsgroup `control', you can use the
1184following hook:
1185
41487370 1186 (setq gnus-apply-kill-hook
8483b957 1187 (list
8483b957
RS
1188 (lambda ()
1189 (cond ((string-match \"control\" gnus-newsgroup-name)
1190 (gnus-kill \"Subject\" \"rmgroup\")
41487370 1191 (gnus-expunge \"X\"))))))")
b027f415 1192
41487370
LMI
1193(defvar gnus-visual-mark-article-hook
1194 (list 'gnus-highlight-selected-summary)
1195 "*Hook run after selecting an article in the summary buffer.
1196It is meant to be used for highlighting the article in some way. It
1197is not run if `gnus-visual' is nil.")
b027f415 1198
7e988fb6
LMI
1199(defun gnus-parse-headers-hook nil
1200 "*A hook called before parsing the headers.")
1201
b027f415 1202(defvar gnus-exit-group-hook nil
41487370 1203 "*A hook called when exiting (not quitting) summary mode.")
745bc783 1204
b027f415 1205(defvar gnus-suspend-gnus-hook nil
41487370 1206 "*A hook called when suspending (not exiting) Gnus.")
745bc783 1207
b027f415 1208(defvar gnus-exit-gnus-hook nil
41487370 1209 "*A hook called when exiting Gnus.")
745bc783 1210
b027f415 1211(defvar gnus-save-newsrc-hook nil
41487370 1212 "*A hook called when saving the newsrc file.")
de032aaa 1213
41487370
LMI
1214(defvar gnus-summary-update-hook
1215 (list 'gnus-summary-highlight-line)
1216 "*A hook called when a summary line is changed.
1217The hook will not be called if `gnus-visual' is nil.
de032aaa 1218
41487370
LMI
1219The default function `gnus-summary-highlight-line' will
1220highlight the line according to the `gnus-summary-highlight'
1221variable.")
de032aaa 1222
41487370
LMI
1223(defvar gnus-mark-article-hook (list 'gnus-summary-mark-unread-as-read)
1224 "*A hook called when an article is selected for the first time.
1225The hook is intended to mark an article as read (or unread)
1226automatically when it is selected.")
de032aaa 1227
41487370
LMI
1228;; Remove any hilit infestation.
1229(add-hook 'gnus-startup-hook
1230 (lambda ()
1231 (remove-hook 'gnus-summary-prepare-hook
1232 'hilit-rehighlight-buffer-quietly)
1233 (remove-hook 'gnus-summary-prepare-hook 'hilit-install-line-hooks)
1234 (setq gnus-mark-article-hook '(gnus-summary-mark-unread-as-read))
1235 (remove-hook 'gnus-article-prepare-hook
1236 'hilit-rehighlight-buffer-quietly)))
de032aaa 1237
de032aaa 1238
745bc783 1239\f
41487370 1240;; Internal variables
745bc783 1241
41487370
LMI
1242;; Avoid highlighting in kill files.
1243(defvar gnus-summary-inhibit-highlight nil)
1244(defvar gnus-newsgroup-selected-overlay nil)
745bc783 1245
41487370
LMI
1246(defvar gnus-article-mode-map nil)
1247(defvar gnus-dribble-buffer nil)
1248(defvar gnus-headers-retrieved-by nil)
1249(defvar gnus-article-reply nil)
1250(defvar gnus-override-method nil)
1251(defvar gnus-article-check-size nil)
1252
1253(defvar gnus-current-score-file nil)
1254(defvar gnus-internal-global-score-files nil)
1255(defvar gnus-score-file-list nil)
1256(defvar gnus-scores-exclude-files nil)
1257
1258(defvar gnus-current-move-group nil)
1259
1260(defvar gnus-newsgroup-dependencies nil)
1261(defvar gnus-newsgroup-threads nil)
1262(defvar gnus-newsgroup-async nil)
1263(defconst gnus-group-edit-buffer "*Gnus edit newsgroup*")
1264
1265(defvar gnus-newsgroup-adaptive nil)
1266
1267(defvar gnus-summary-display-table nil)
1268
1269(defconst gnus-group-line-format-alist
1270 (list (list ?M 'marked ?c)
1271 (list ?S 'subscribed ?c)
1272 (list ?L 'level ?d)
1273 (list ?N 'number ?s)
1274 (list ?I 'number-of-dormant ?d)
1275 (list ?T 'number-of-ticked ?d)
1276 (list ?R 'number-of-read ?s)
1277 (list ?t 'number-total ?d)
1278 (list ?y 'number-of-unread-unticked ?s)
1279 (list ?i 'number-of-ticked-and-dormant ?d)
1280 (list ?g 'group ?s)
1281 (list ?G 'qualified-group ?s)
1282 (list ?D 'newsgroup-description ?s)
1283 (list ?o 'moderated ?c)
1284 (list ?O 'moderated-string ?s)
1285 (list ?p 'process-marked ?c)
1286 (list ?s 'news-server ?s)
1287 (list ?n 'news-method ?s)
1288 (list ?z 'news-method-string ?s)
1289 (list ?u 'user-defined ?s)))
1290
1291(defconst gnus-summary-line-format-alist
1292 (list (list ?N 'number ?d)
1293 (list ?S 'subject ?s)
1294 (list ?s 'subject-or-nil ?s)
1295 (list ?n 'name ?s)
1296 (list ?A '(car (cdr (funcall gnus-extract-address-components from)))
1297 ?s)
1298 (list ?a '(or (car (funcall gnus-extract-address-components from))
1299 from) ?s)
1300 (list ?F 'from ?s)
1301 (list ?x (macroexpand '(mail-header-xref header)) ?s)
1302 (list ?D (macroexpand '(mail-header-date header)) ?s)
1303 (list ?d '(gnus-dd-mmm (mail-header-date header)) ?s)
1304 (list ?M (macroexpand '(mail-header-id header)) ?s)
1305 (list ?r (macroexpand '(mail-header-references header)) ?s)
1306 (list ?c '(or (mail-header-chars header) 0) ?d)
1307 (list ?L 'lines ?d)
1308 (list ?I 'indentation ?s)
1309 (list ?T '(if (= level 0) "" (make-string (frame-width) ? )) ?s)
1310 (list ?R 'replied ?c)
1311 (list ?\[ 'opening-bracket ?c)
1312 (list ?\] 'closing-bracket ?c)
1313 (list ?\> '(make-string level ? ) ?s)
1314 (list ?\< '(make-string (max 0 (- 20 level)) ? ) ?s)
1315 (list ?i 'score ?d)
1316 (list ?z 'score-char ?c)
1317 (list ?U 'unread ?c)
1318 (list ?t '(gnus-summary-number-of-articles-in-thread
1319 (and (boundp 'thread) (car thread)))
1320 ?d)
1321 (list ?e '(gnus-summary-number-of-articles-in-thread
1322 (and (boundp 'thread) (car thread)) t)
1323 ?c)
1324 (list ?u 'user-defined ?s))
1325 "An alist of format specifications that can appear in summary lines,
1326and what variables they correspond with, along with the type of the
1327variable (string, integer, character, etc).")
1328
1329(defconst gnus-summary-dummy-line-format-alist
1330 (list (list ?S 'subject ?s)
1331 (list ?N 'number ?d)
1332 (list ?u 'user-defined ?s)))
1333
1334(defconst gnus-summary-mode-line-format-alist
1335 (list (list ?G 'group-name ?s)
1336 (list ?g '(gnus-short-group-name group-name) ?s)
1337 (list ?A 'article-number ?d)
1338 (list ?Z 'unread-and-unselected ?s)
1339 (list ?V 'gnus-version ?s)
1340 (list ?U 'unread ?d)
1341 (list ?S 'subject ?s)
1342 (list ?e 'unselected ?d)
1343 (list ?u 'user-defined ?s)
6346a6e6 1344 (list ?b 'buffer-name ?s)
41487370
LMI
1345 (list ?s '(gnus-current-score-file-nondirectory) ?s)))
1346
1347(defconst gnus-group-mode-line-format-alist
1348 (list (list ?S 'news-server ?s)
1349 (list ?M 'news-method ?s)
6346a6e6 1350 (list ?b '(buffer-name) ?s)
41487370
LMI
1351 (list ?u 'user-defined ?s)))
1352
1353(defvar gnus-have-read-active-file nil)
1354
1355(defconst gnus-maintainer
1356 "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls + Boys)"
1357 "The mail address of the Gnus maintainers.")
1358
1359(defconst gnus-version "Gnus v5.1"
1360 "Version number for this version of Gnus.")
44cdca98 1361
b027f415 1362(defvar gnus-info-nodes
41487370
LMI
1363 '((gnus-group-mode "(gnus)The Group Buffer")
1364 (gnus-summary-mode "(gnus)The Summary Buffer")
1365 (gnus-article-mode "(gnus)The Article Buffer"))
745bc783
JB
1366 "Assoc list of major modes and related Info nodes.")
1367
41487370 1368(defvar gnus-group-buffer "*Group*")
b027f415
RS
1369(defvar gnus-summary-buffer "*Summary*")
1370(defvar gnus-article-buffer "*Article*")
41487370
LMI
1371(defvar gnus-server-buffer "*Server*")
1372
1373(defvar gnus-work-buffer " *gnus work*")
1374
1375(defvar gnus-buffer-list nil
1376 "Gnus buffers that should be killed on exit.")
745bc783 1377
41487370
LMI
1378(defvar gnus-server-alist nil
1379 "List of available servers.")
745bc783
JB
1380
1381(defvar gnus-variable-list
41487370
LMI
1382 '(gnus-newsrc-options gnus-newsrc-options-n
1383 gnus-newsrc-last-checked-date
1384 gnus-newsrc-alist gnus-server-alist
1385 gnus-killed-list gnus-zombie-list)
1386 "Gnus variables saved in the quick startup file.")
745bc783
JB
1387
1388(defvar gnus-overload-functions
41487370 1389 '((news-inews gnus-inews-news "rnewspost"))
745bc783
JB
1390 "Functions overloaded by gnus.
1391It is a list of `(original overload &optional file)'.")
1392
1393(defvar gnus-newsrc-options nil
41487370 1394 "Options line in the .newsrc file.")
745bc783 1395
41487370
LMI
1396(defvar gnus-newsrc-options-n nil
1397 "List of regexps representing groups to be subscribed/ignored unconditionally.")
745bc783 1398
41487370
LMI
1399(defvar gnus-newsrc-last-checked-date nil
1400 "Date Gnus last asked server for new newsgroups.")
745bc783 1401
41487370 1402(defvar gnus-newsrc-alist nil
b027f415 1403 "Assoc list of read articles.
41487370 1404gnus-newsrc-hashtb should be kept so that both hold the same information.")
b027f415
RS
1405
1406(defvar gnus-newsrc-hashtb nil
41487370 1407 "Hashtable of gnus-newsrc-alist.")
745bc783 1408
41487370
LMI
1409(defvar gnus-killed-list nil
1410 "List of killed newsgroups.")
b027f415
RS
1411
1412(defvar gnus-killed-hashtb nil
41487370 1413 "Hash table equivalent of gnus-killed-list.")
745bc783 1414
41487370
LMI
1415(defvar gnus-zombie-list nil
1416 "List of almost dead newsgroups.")
b027f415 1417
41487370
LMI
1418(defvar gnus-description-hashtb nil
1419 "Descriptions of newsgroups.")
745bc783 1420
41487370
LMI
1421(defvar gnus-list-of-killed-groups nil
1422 "List of newsgroups that have recently been killed by the user.")
745bc783
JB
1423
1424(defvar gnus-active-hashtb nil
1425 "Hashtable of active articles.")
1426
41487370
LMI
1427(defvar gnus-moderated-list nil
1428 "List of moderated newsgroups.")
1429
1430(defvar gnus-group-marked nil)
745bc783
JB
1431
1432(defvar gnus-current-startup-file nil
1433 "Startup file for the current host.")
1434
1435(defvar gnus-last-search-regexp nil
1436 "Default regexp for article search command.")
1437
1438(defvar gnus-last-shell-command nil
1439 "Default shell command on article.")
1440
41487370
LMI
1441(defvar gnus-current-select-method nil
1442 "The current method for selecting a newsgroup.")
1443
1444(defvar gnus-group-list-mode nil)
1445
1446(defvar gnus-article-internal-prepare-hook nil)
745bc783
JB
1447
1448(defvar gnus-newsgroup-name nil)
1449(defvar gnus-newsgroup-begin nil)
1450(defvar gnus-newsgroup-end nil)
1451(defvar gnus-newsgroup-last-rmail nil)
1452(defvar gnus-newsgroup-last-mail nil)
1453(defvar gnus-newsgroup-last-folder nil)
1454(defvar gnus-newsgroup-last-file nil)
41487370
LMI
1455(defvar gnus-newsgroup-auto-expire nil)
1456(defvar gnus-newsgroup-active nil)
745bc783
JB
1457
1458(defvar gnus-newsgroup-unreads nil
1459 "List of unread articles in the current newsgroup.")
1460
1461(defvar gnus-newsgroup-unselected nil
1462 "List of unselected unread articles in the current newsgroup.")
1463
41487370
LMI
1464(defvar gnus-newsgroup-reads nil
1465 "Alist of read articles and article marks in the current newsgroup.")
1466
745bc783 1467(defvar gnus-newsgroup-marked nil
41487370
LMI
1468 "List of ticked articles in the current newsgroup (a subset of unread art).")
1469
1470(defvar gnus-newsgroup-killed nil
1471 "List of ranges of articles that have been through the scoring process.")
1472
1473(defvar gnus-newsgroup-kill-headers nil)
1474
1475(defvar gnus-newsgroup-replied nil
1476 "List of articles that have been replied to in the current newsgroup.")
1477
1478(defvar gnus-newsgroup-expirable nil
1479 "List of articles in the current newsgroup that can be expired.")
1480
1481(defvar gnus-newsgroup-processable nil
1482 "List of articles in the current newsgroup that can be processed.")
1483
1484(defvar gnus-newsgroup-bookmarks nil
1485 "List of articles in the current newsgroup that have bookmarks.")
1486
1487(defvar gnus-newsgroup-dormant nil
1488 "List of dormant articles in the current newsgroup.")
1489
1490(defvar gnus-newsgroup-scored nil
1491 "List of scored articles in the current newsgroup.")
745bc783
JB
1492
1493(defvar gnus-newsgroup-headers nil
41487370 1494 "List of article headers in the current newsgroup.")
b027f415 1495(defvar gnus-newsgroup-headers-hashtb-by-number nil)
745bc783 1496
41487370
LMI
1497(defvar gnus-newsgroup-ancient nil
1498 "List of `gnus-fetch-old-headers' articles in the current newsgroup.")
1499
745bc783 1500(defvar gnus-current-article nil)
41487370 1501(defvar gnus-article-current nil)
745bc783 1502(defvar gnus-current-headers nil)
41487370 1503(defvar gnus-have-all-headers nil)
745bc783 1504(defvar gnus-last-article nil)
41487370 1505(defvar gnus-newsgroup-history nil)
745bc783
JB
1506(defvar gnus-current-kill-article nil)
1507
1508;; Save window configuration.
41487370
LMI
1509(defvar gnus-prev-winconf nil)
1510
1511;; Format specs
1512(defvar gnus-summary-line-format-spec nil)
1513(defvar gnus-summary-dummy-line-format-spec nil)
1514(defvar gnus-group-line-format-spec nil)
1515(defvar gnus-summary-mode-line-format-spec nil)
1516(defvar gnus-article-mode-line-format-spec nil)
1517(defvar gnus-group-mode-line-format-spec nil)
1518(defvar gnus-summary-mark-positions nil)
1519(defvar gnus-group-mark-positions nil)
1520
1521(defvar gnus-summary-expunge-below nil)
1522(defvar gnus-reffed-article-number nil)
1523
1524; Let the byte-compiler know that we know about this variable.
1525(defvar rmail-default-rmail-file)
1526
b94ae5f7 1527(defvar gnus-cache-removable-articles nil)
41487370
LMI
1528
1529(defconst gnus-summary-local-variables
1530 '(gnus-newsgroup-name
1531 gnus-newsgroup-begin gnus-newsgroup-end
1532 gnus-newsgroup-last-rmail gnus-newsgroup-last-mail
1533 gnus-newsgroup-last-folder gnus-newsgroup-last-file
1534 gnus-newsgroup-auto-expire gnus-newsgroup-unreads
1535 gnus-newsgroup-unselected gnus-newsgroup-marked
1536 gnus-newsgroup-reads
1537 gnus-newsgroup-replied gnus-newsgroup-expirable
1538 gnus-newsgroup-processable gnus-newsgroup-killed
1539 gnus-newsgroup-bookmarks gnus-newsgroup-dormant
1540 gnus-newsgroup-headers gnus-newsgroup-headers-hashtb-by-number
1541 gnus-current-article gnus-current-headers gnus-have-all-headers
1542 gnus-last-article gnus-article-internal-prepare-hook
1543 gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay
1544 gnus-newsgroup-scored gnus-newsgroup-kill-headers
1545 gnus-newsgroup-threads gnus-newsgroup-async
1546 gnus-score-alist gnus-current-score-file gnus-summary-expunge-below
1547 gnus-summary-mark-below gnus-newsgroup-active gnus-scores-exclude-files
1548 gnus-newsgroup-history gnus-newsgroup-ancient
1549 (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring)
b94ae5f7 1550 gnus-cache-removable-articles)
41487370
LMI
1551 "Variables that are buffer-local to the summary buffers.")
1552
1553(defconst gnus-bug-message
1554 "Sending a bug report to the Gnus Towers.
1555========================================
1556
1557The buffer below is a mail buffer. When you press `C-c C-c', it will
1558be sent to the Gnus Bug Exterminators.
1559
1560At the bottom of the buffer you'll see lots of variable settings.
1561Please do not delete those. They will tell the Bug People what your
1562environment is, so that it will be easier to locate the bugs.
1563
1564If you have found a bug that makes Emacs go \"beep\", set
1565debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
1566and include the backtrace in your bug report.
1567
1568Please describe the bug in annoying, painstaking detail.
1569
1570Thank you for your help in stamping out bugs.
1571")
1572
1573;;; End of variables.
1574
1575;; Define some autoload functions Gnus might use.
1576(eval-and-compile
1577
1578 ;; Various
1579 (autoload 'metamail-buffer "metamail")
1580 (autoload 'Info-goto-node "info")
1581 (autoload 'hexl-hex-string-to-integer "hexl")
1582 (autoload 'pp "pp")
1583 (autoload 'pp-to-string "pp")
1584 (autoload 'pp-eval-expression "pp")
1585 (autoload 'mail-extract-address-components "mail-extr")
1586
1587 (autoload 'nnmail-split-fancy "nnmail")
1588 (autoload 'nnvirtual-catchup-group "nnvirtual")
1589
1590 ;; timezone
1591 (autoload 'timezone-make-date-arpa-standard "timezone")
1592 (autoload 'timezone-fix-time "timezone")
1593 (autoload 'timezone-make-sortable-date "timezone")
1594 (autoload 'timezone-make-time-string "timezone")
1595
1596 ;; rmail & friends
1597 (autoload 'mail-position-on-field "sendmail")
1598 (autoload 'mail-setup "sendmail")
1599 (autoload 'rmail-output "rmailout")
1600 (autoload 'news-mail-other-window "rnewspost")
1601 (autoload 'news-reply-yank-original "rnewspost")
1602 (autoload 'news-caesar-buffer-body "rnewspost")
1603 (autoload 'rmail-insert-rmail-file-header "rmail")
1604 (autoload 'rmail-count-new-messages "rmail")
1605 (autoload 'rmail-show-message "rmail")
1606
1607 ;; gnus-soup
1608 ;;(autoload 'gnus-group-brew-soup "gnus-soup" nil t)
1609 ;;(autoload 'gnus-brew-soup "gnus-soup" nil t)
1610 ;;(autoload 'gnus-soup-add-article "gnus-soup" nil t)
1611 ;;(autoload 'gnus-soup-send-replies "gnus-soup" nil t)
1612 ;;(autoload 'gnus-soup-save-areas "gnus-soup" nil t)
1613 ;;(autoload 'gnus-soup-pack-packet "gnus-soup" nil t)
1614 ;;(autoload 'nnsoup-pack-replies "nnsoup" nil t)
1615
1616 ;; gnus-mh
1617 (autoload 'gnus-mail-reply-using-mhe "gnus-mh")
1618 (autoload 'gnus-mail-forward-using-mhe "gnus-mh")
1619 (autoload 'gnus-mail-other-window-using-mhe "gnus-mh")
1620 (autoload 'gnus-summary-save-in-folder "gnus-mh" nil t)
1621 (autoload 'gnus-summary-save-article-folder "gnus-mh")
1622 (autoload 'gnus-Folder-save-name "gnus-mh")
1623 (autoload 'gnus-folder-save-name "gnus-mh")
1624
1625 ;; gnus-vis misc
1626 (autoload 'gnus-group-make-menu-bar "gnus-vis")
1627 (autoload 'gnus-summary-make-menu-bar "gnus-vis")
1628 (autoload 'gnus-server-make-menu-bar "gnus-vis")
1629 (autoload 'gnus-article-make-menu-bar "gnus-vis")
1630 (autoload 'gnus-browse-make-menu-bar "gnus-vis")
1631 (autoload 'gnus-highlight-selected-summary "gnus-vis")
1632 (autoload 'gnus-summary-highlight-line "gnus-vis")
1633 (autoload 'gnus-carpal-setup-buffer "gnus-vis")
1634
1635 ;; gnus-vis article
1636 (autoload 'gnus-article-push-button "gnus-vis" nil t)
1637 (autoload 'gnus-article-press-button "gnus-vis" nil t)
1638 (autoload 'gnus-article-highlight "gnus-vis" nil t)
1639 (autoload 'gnus-article-highlight-some "gnus-vis" nil t)
1640 (autoload 'gnus-article-hide "gnus-vis" nil t)
1641 (autoload 'gnus-article-hide-signature "gnus-vis" nil t)
1642 (autoload 'gnus-article-highlight-headers "gnus-vis" nil t)
1643 (autoload 'gnus-article-highlight-signature "gnus-vis" nil t)
1644 (autoload 'gnus-article-add-buttons "gnus-vis" nil t)
1645 (autoload 'gnus-article-next-button "gnus-vis" nil t)
1646 (autoload 'gnus-article-add-button "gnus-vis")
1647
1648 ;; gnus-cite
1649 (autoload 'gnus-article-highlight-citation "gnus-cite" nil t)
1650 (autoload 'gnus-article-hide-citation-maybe "gnus-cite" nil t)
1651 (autoload 'gnus-article-hide-citation "gnus-cite" nil t)
1652
1653 ;; gnus-kill
1654 (autoload 'gnus-kill "gnus-kill")
1655 (autoload 'gnus-apply-kill-file-internal "gnus-kill")
1656 (autoload 'gnus-kill-file-edit-file "gnus-kill")
1657 (autoload 'gnus-kill-file-raise-followups-to-author "gnus-kill")
1658 (autoload 'gnus-execute "gnus-kill")
1659 (autoload 'gnus-expunge "gnus-kill")
1660
1661 ;; gnus-cache
1662 (autoload 'gnus-cache-possibly-enter-article "gnus-cache")
1663 (autoload 'gnus-cache-save-buffers "gnus-cache")
1664 (autoload 'gnus-cache-possibly-remove-articles "gnus-cache")
1665 (autoload 'gnus-cache-request-article "gnus-cache")
1666 (autoload 'gnus-cache-retrieve-headers "gnus-cache")
1667 (autoload 'gnus-cache-possibly-alter-active "gnus-cache")
1668 (autoload 'gnus-jog-cache "gnus-cache" nil t)
1669 (autoload 'gnus-cache-enter-remove-article "gnus-cache")
1670
1671 ;; gnus-score
1672 (autoload 'gnus-summary-increase-score "gnus-score" nil t)
1673 (autoload 'gnus-summary-lower-score "gnus-score" nil t)
1674 (autoload 'gnus-summary-score-map "gnus-score" nil nil 'keymap)
1675 (autoload 'gnus-score-save "gnus-score")
1676 (autoload 'gnus-score-headers "gnus-score")
1677 (autoload 'gnus-current-score-file-nondirectory "gnus-score")
1678 (autoload 'gnus-score-adaptive "gnus-score")
1679 (autoload 'gnus-score-remove-lines-adaptive "gnus-score")
1680 (autoload 'gnus-score-find-trace "gnus-score")
1681
1682 ;; gnus-edit
1683 (autoload 'gnus-score-customize "gnus-edit" nil t)
1684
1685 ;; gnus-uu
1686 (autoload 'gnus-uu-extract-map "gnus-uu" nil nil 'keymap)
1687 (autoload 'gnus-uu-mark-map "gnus-uu" nil nil 'keymap)
1688 (autoload 'gnus-uu-digest-mail-forward "gnus-uu" nil t)
1689 (autoload 'gnus-uu-digest-post-forward "gnus-uu" nil t)
1690 (autoload 'gnus-uu-mark-series "gnus-uu" nil t)
1691 (autoload 'gnus-uu-mark-region "gnus-uu" nil t)
1692 (autoload 'gnus-uu-mark-by-regexp "gnus-uu" nil t)
1693 (autoload 'gnus-uu-mark-all "gnus-uu" nil t)
1694 (autoload 'gnus-uu-mark-sparse "gnus-uu" nil t)
1695 (autoload 'gnus-uu-mark-thread "gnus-uu" nil t)
1696 (autoload 'gnus-uu-decode-uu "gnus-uu" nil t)
1697 (autoload 'gnus-uu-decode-uu-and-save "gnus-uu" nil t)
1698 (autoload 'gnus-uu-decode-unshar "gnus-uu" nil t)
1699 (autoload 'gnus-uu-decode-unshar-and-save "gnus-uu" nil t)
1700 (autoload 'gnus-uu-decode-save "gnus-uu" nil t)
1701 (autoload 'gnus-uu-decode-binhex "gnus-uu" nil t)
1702 (autoload 'gnus-uu-decode-uu-view "gnus-uu" nil t)
1703 (autoload 'gnus-uu-decode-uu-and-save-view "gnus-uu" nil t)
1704 (autoload 'gnus-uu-decode-unshar-view "gnus-uu" nil t)
1705 (autoload 'gnus-uu-decode-unshar-and-save-view "gnus-uu" nil t)
1706 (autoload 'gnus-uu-decode-save-view "gnus-uu" nil t)
1707 (autoload 'gnus-uu-decode-binhex-view "gnus-uu" nil t)
1708
1709 ;; gnus-msg
1710 (autoload 'gnus-summary-send-map "gnus-msg" nil nil 'keymap)
1711 (autoload 'gnus-group-post-news "gnus-msg" nil t)
1712 (autoload 'gnus-group-mail "gnus-msg" nil t)
1713 (autoload 'gnus-summary-post-news "gnus-msg" nil t)
1714 (autoload 'gnus-summary-followup "gnus-msg" nil t)
1715 (autoload 'gnus-summary-followup-with-original "gnus-msg" nil t)
1716 (autoload 'gnus-summary-followup-and-reply "gnus-msg" nil t)
1717 (autoload 'gnus-summary-followup-and-reply-with-original "gnus-msg" nil t)
1718 (autoload 'gnus-summary-cancel-article "gnus-msg" nil t)
1719 (autoload 'gnus-summary-supersede-article "gnus-msg" nil t)
1720 (autoload 'gnus-post-news "gnus-msg" nil t)
1721 (autoload 'gnus-inews-news "gnus-msg" nil t)
1722 (autoload 'gnus-cancel-news "gnus-msg" nil t)
1723 (autoload 'gnus-summary-reply "gnus-msg" nil t)
1724 (autoload 'gnus-summary-reply-with-original "gnus-msg" nil t)
1725 (autoload 'gnus-summary-mail-forward "gnus-msg" nil t)
1726 (autoload 'gnus-summary-mail-other-window "gnus-msg" nil t)
1727 (autoload 'gnus-mail-reply-using-mail "gnus-msg")
1728 (autoload 'gnus-mail-yank-original "gnus-msg")
1729 (autoload 'gnus-mail-send-and-exit "gnus-msg")
1730 (autoload 'gnus-mail-forward-using-mail "gnus-msg")
1731 (autoload 'gnus-mail-other-window-using-mail "gnus-msg")
1732 (autoload 'gnus-article-mail "gnus-msg")
1733 (autoload 'gnus-bug "gnus-msg" nil t)
1734
1735 ;; gnus-vm
1736 (autoload 'gnus-summary-save-in-vm "gnus-vm" nil t)
1737 (autoload 'gnus-summary-save-article-vm "gnus-vm" nil t)
1738 (autoload 'gnus-mail-forward-using-vm "gnus-vm")
1739 (autoload 'gnus-mail-reply-using-vm "gnus-vm")
1740 (autoload 'gnus-mail-other-window-using-vm "gnus-vm" nil t)
1741 (autoload 'gnus-yank-article "gnus-vm" nil t)
745bc783 1742
41487370 1743 )
745bc783
JB
1744
1745\f
41487370
LMI
1746
1747;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
1748;; If you want the cursor to go somewhere else, set these two
1749;; functions in some startup hook to whatever you want.
1750(defalias 'gnus-summary-position-cursor 'gnus-goto-colon)
1751(defalias 'gnus-group-position-cursor 'gnus-goto-colon)
1752
1753;;; Various macros and substs.
745bc783
JB
1754
1755(defmacro gnus-eval-in-buffer-window (buffer &rest forms)
1756 "Pop to BUFFER, evaluate FORMS, and then returns to original window."
41487370 1757 (` (let ((GnusStartBufferWindow (selected-window)))
745bc783
JB
1758 (unwind-protect
1759 (progn
1760 (pop-to-buffer (, buffer))
1761 (,@ forms))
41487370 1762 (select-window GnusStartBufferWindow)))))
745bc783
JB
1763
1764(defmacro gnus-gethash (string hashtable)
1765 "Get hash value of STRING in HASHTABLE."
1766 ;;(` (symbol-value (abbrev-symbol (, string) (, hashtable))))
b027f415
RS
1767 ;;(` (abbrev-expansion (, string) (, hashtable)))
1768 (` (symbol-value (intern-soft (, string) (, hashtable)))))
745bc783
JB
1769
1770(defmacro gnus-sethash (string value hashtable)
41487370 1771 "Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
745bc783 1772 ;; We cannot use define-abbrev since it only accepts string as value.
41487370 1773 ;; (set (intern string hashtable) value))
745bc783
JB
1774 (` (set (intern (, string) (, hashtable)) (, value))))
1775
41487370
LMI
1776(defsubst gnus-buffer-substring (beg end)
1777 (buffer-substring (match-beginning beg) (match-end end)))
1778
1779;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
1780;; function `substring' might cut on a middle of multi-octet
1781;; character.
1782(defun gnus-truncate-string (str width)
1783 (substring str 0 width))
1784
1785;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
1786;; to limit the length of a string. This function is necessary since
1787;; `(substr "abc" 0 30)' pukes with "Args out of range".
1788(defsubst gnus-limit-string (str width)
1789 (if (> (length str) width)
1790 (substring str 0 width)
1791 str))
1792
1793(defsubst gnus-simplify-subject-re (subject)
1794 "Remove \"Re:\" from subject lines."
1795 (let ((case-fold-search t))
1796 (if (string-match "^re: *" subject)
1797 (substring subject (match-end 0))
1798 subject)))
1799
1800(defsubst gnus-goto-char (point)
1801 (and point (goto-char point)))
1802
1803(defmacro gnus-buffer-exists-p (buffer)
1804 (` (and (, buffer)
1805 (funcall (if (stringp (, buffer)) 'get-buffer 'buffer-name)
1806 (, buffer)))))
1807
1808(defmacro gnus-kill-buffer (buffer)
1809 (` (if (gnus-buffer-exists-p (, buffer))
1810 (kill-buffer (, buffer)))))
1811
1812(defsubst gnus-point-at-bol ()
1813 "Return point at the beginning of line."
1814 (let ((p (point)))
1815 (beginning-of-line)
1816 (prog1
1817 (point)
1818 (goto-char p))))
1819
1820(defsubst gnus-point-at-eol ()
1821 "Return point at the beginning of line."
1822 (let ((p (point)))
1823 (end-of-line)
1824 (prog1
1825 (point)
1826 (goto-char p))))
1827
1828;; Delete the current line (and the next N lines.);
1829(defmacro gnus-delete-line (&optional n)
1830 (` (delete-region (progn (beginning-of-line) (point))
1831 (progn (forward-line (, (or n 1))) (point)))))
1832
1833;; Suggested by Brian Edmonds <edmonds@cs.ubc.ca>.
1834(defvar gnus-init-inhibit nil)
1835(defun gnus-read-init-file (&optional inhibit-next)
1836 (if gnus-init-inhibit
1837 (setq gnus-init-inhibit nil)
1838 (setq gnus-init-inhibit inhibit-next)
1839 (and gnus-init-file
1840 (or (and (file-exists-p gnus-init-file)
1841 ;; Don't try to load a directory.
1842 (not (file-directory-p gnus-init-file)))
1843 (file-exists-p (concat gnus-init-file ".el"))
1844 (file-exists-p (concat gnus-init-file ".elc")))
1845 (load gnus-init-file nil t))))
1846
1847;;; Load the user startup file.
1848;; (eval '(gnus-read-init-file 'inhibit))
1849
b94ae5f7 1850;;; Load the compatibility functions.
41487370
LMI
1851
1852(require 'gnus-cus)
1853(require 'gnus-ems)
745bc783 1854
41487370
LMI
1855\f
1856;;;
1857;;; Gnus Utility Functions
1858;;;
745bc783 1859
41487370
LMI
1860(defun gnus-extract-address-components (from)
1861 (let (name address)
1862 ;; First find the address - the thing with the @ in it. This may
1863 ;; not be accurate in mail addresses, but does the trick most of
1864 ;; the time in news messages.
1865 (if (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
1866 (setq address (substring from (match-beginning 0) (match-end 0))))
1867 ;; Then we check whether the "name <address>" format is used.
1868 (and address
1869 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>
1870 ;; Linear white space is not required.
1871 (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
1872 (and (setq name (substring from 0 (match-beginning 0)))
1873 ;; Strip any quotes from the name.
1874 (string-match "\".*\"" name)
1875 (setq name (substring name 1 (1- (match-end 0))))))
1876 ;; If not, then "address (name)" is used.
1877 (or name
1878 (and (string-match "(.+)" from)
1879 (setq name (substring from (1+ (match-beginning 0))
1880 (1- (match-end 0)))))
1881 (and (string-match "()" from)
1882 (setq name address))
1883 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.
1884 ;; XOVER might not support folded From headers.
1885 (and (string-match "(.*" from)
1886 (setq name (substring from (1+ (match-beginning 0))
1887 (match-end 0)))))
1888 ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
1889 (list (or name from) (or address from))))
745bc783 1890
41487370
LMI
1891(defun gnus-fetch-field (field)
1892 "Return the value of the header FIELD of current article."
1893 (save-excursion
1894 (save-restriction
1895 (let ((case-fold-search t))
1896 (gnus-narrow-to-headers)
1897 (mail-fetch-field field)))))
745bc783 1898
41487370
LMI
1899(defun gnus-goto-colon ()
1900 (beginning-of-line)
1901 (search-forward ":" (gnus-point-at-eol) t))
745bc783 1902
41487370
LMI
1903(defun gnus-narrow-to-headers ()
1904 (widen)
1905 (save-excursion
1906 (narrow-to-region
1907 (goto-char (point-min))
1908 (if (search-forward "\n\n" nil t)
1909 (1- (point))
1910 (point-max)))))
1911
1912(defvar gnus-old-specs nil)
1913
1914(defun gnus-update-format-specifications ()
1915 (gnus-make-thread-indent-array)
1916
1917 (let ((formats '(summary summary-dummy group
1918 summary-mode group-mode article-mode))
1919 old-format new-format)
1920 (while formats
1921 (setq new-format (symbol-value
1922 (intern (format "gnus-%s-line-format" (car formats)))))
1923 (or (and (setq old-format (cdr (assq (car formats) gnus-old-specs)))
1924 (equal old-format new-format))
1925 (set (intern (format "gnus-%s-line-format-spec" (car formats)))
1926 (gnus-parse-format
1927 new-format
1928 (symbol-value
1929 (intern (format "gnus-%s-line-format-alist"
1930 (if (eq (car formats) 'article-mode)
1931 'summary-mode (car formats))))))))
1932 (setq gnus-old-specs (cons (cons (car formats) new-format)
1933 (delq (car formats) gnus-old-specs)))
1934 (setq formats (cdr formats))))
1935
1936 (gnus-update-group-mark-positions)
1937 (gnus-update-summary-mark-positions)
1938
1939 (if (and (string-match "%D" gnus-group-line-format)
1940 (not gnus-description-hashtb)
1941 gnus-read-active-file)
1942 (gnus-read-all-descriptions-files)))
1943
1944(defun gnus-update-summary-mark-positions ()
1945 (save-excursion
1946 (let ((gnus-replied-mark 129)
1947 (gnus-score-below-mark 130)
1948 (gnus-score-over-mark 130)
1949 (thread nil)
1950 pos)
1951 (gnus-set-work-buffer)
1952 (gnus-summary-insert-line
1953 nil [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1)
1954 (goto-char (point-min))
1955 (setq pos (list (cons 'unread (and (search-forward "\200" nil t)
1956 (- (point) 2)))))
1957 (goto-char (point-min))
1958 (setq pos (cons (cons 'replied (and (search-forward "\201" nil t)
1959 (- (point) 2))) pos))
1960 (goto-char (point-min))
1961 (setq pos (cons (cons 'score (and (search-forward "\202" nil t)
1962 (- (point) 2))) pos))
1963 (setq gnus-summary-mark-positions pos))))
745bc783 1964
41487370
LMI
1965(defun gnus-update-group-mark-positions ()
1966 (save-excursion
1967 (let ((gnus-process-mark 128)
1968 (gnus-group-marked '("dummy.group")))
1969 (gnus-sethash "dummy.group" '(0 . 0) gnus-active-hashtb)
1970 (gnus-set-work-buffer)
1971 (gnus-group-insert-group-line nil "dummy.group" 0 nil 0 nil)
1972 (goto-char (point-min))
1973 (setq gnus-group-mark-positions
1974 (list (cons 'process (and (search-forward "\200" nil t)
1975 (- (point) 2))))))))
1976
1977(defun gnus-mouse-face-function (form)
1978 (` (let ((string (, form)))
1979 (put-text-property 0 (length string) 'mouse-face gnus-mouse-face string)
1980 string)))
1981
1982(defun gnus-max-width-function (el max-width)
1983 (or (numberp max-width) (signal 'wrong-type-argument '(numberp max-width)))
1984 (` (let* ((val (eval (, el)))
1985 (valstr (if (numberp val)
1986 (int-to-string val) val)))
1987 (if (> (length valstr) (, max-width))
1988 (substring valstr 0 (, max-width))
1989 valstr))))
1990
1991(defun gnus-parse-format (format spec-alist)
1992 ;; This function parses the FORMAT string with the help of the
1993 ;; SPEC-ALIST and returns a list that can be eval'ed to return the
1994 ;; string. If the FORMAT string contains the specifiers %( and %)
1995 ;; the text between them will have the mouse-face text property.
1996 (if (string-match "\\`\\(.*\\)%(\\(.*\\)%)\\(.*\n?\\)\\'" format)
1997 (if (and gnus-visual gnus-mouse-face)
1998 (let ((pre (substring format (match-beginning 1) (match-end 1)))
1999 (button (substring format (match-beginning 2) (match-end 2)))
2000 (post (substring format (match-beginning 3) (match-end 3))))
2001 (list 'concat
2002 (gnus-parse-simple-format pre spec-alist)
2003 (gnus-mouse-face-function
2004 (gnus-parse-simple-format button spec-alist))
2005 (gnus-parse-simple-format post spec-alist)))
2006 (gnus-parse-simple-format
2007 (concat (substring format (match-beginning 1) (match-end 1))
2008 (substring format (match-beginning 2) (match-end 2))
2009 (substring format (match-beginning 3) (match-end 3)))
2010 spec-alist))
2011 (gnus-parse-simple-format format spec-alist)))
2012
2013(defun gnus-parse-simple-format (format spec-alist)
2014 ;; This function parses the FORMAT string with the help of the
2015 ;; SPEC-ALIST and returns a list that can be eval'ed to return the
2016 ;; string. The list will consist of the symbol `format', a format
2017 ;; specification string, and a list of forms depending on the
2018 ;; SPEC-ALIST.
2019 (let ((max-width 0)
2020 spec flist fstring newspec elem beg)
2021 (save-excursion
2022 (gnus-set-work-buffer)
2023 (insert format)
2024 (goto-char (point-min))
2025 (while (re-search-forward "%[-0-9]*\\(,[0-9]+\\)?\\([^0-9]\\)\\(.\\)?" nil t)
2026 (setq spec (string-to-char (buffer-substring (match-beginning 2)
2027 (match-end 2))))
2028 ;; First check if there are any specs that look anything like
2029 ;; "%12,12A", ie. with a "max width specification". These have
2030 ;; to be treated specially.
2031 (if (setq beg (match-beginning 1))
2032 (setq max-width
2033 (string-to-int
2034 (buffer-substring (1+ (match-beginning 1)) (match-end 1))))
2035 (setq max-width 0)
2036 (setq beg (match-beginning 2)))
2037 ;; Find the specification from `spec-alist'.
2038 (if (not (setq elem (cdr (assq spec spec-alist))))
2039 (setq elem '("*" ?s)))
2040 ;; Treat user defined format specifiers specially
2041 (and (eq (car elem) 'user-defined)
2042 (setq elem
2043 (list
2044 (list (intern (concat "gnus-user-format-function-"
2045 (buffer-substring
2046 (match-beginning 3)
2047 (match-end 3))))
2048 'header)
2049 ?s))
2050 (delete-region (match-beginning 3) (match-end 3)))
2051 (if (not (zerop max-width))
2052 (let ((el (car elem)))
2053 (cond ((= (car (cdr elem)) ?c)
2054 (setq el (list 'char-to-string el)))
2055 ((= (car (cdr elem)) ?d)
2056 (numberp el) (setq el (list 'int-to-string el))))
2057 (setq flist (cons (gnus-max-width-function el max-width)
2058 flist))
2059 (setq newspec ?s))
2060 (setq flist (cons (car elem) flist))
2061 (setq newspec (car (cdr elem))))
2062 ;; Remove the old specification (and possibly a ",12" string).
2063 (delete-region beg (match-end 2))
2064 ;; Insert the new specification.
2065 (goto-char beg)
2066 (insert newspec))
2067 (setq fstring (buffer-substring 1 (point-max))))
2068 (cons 'format (cons fstring (nreverse flist)))))
2069
2070(defun gnus-set-work-buffer ()
2071 (if (get-buffer gnus-work-buffer)
2072 (progn
2073 (set-buffer gnus-work-buffer)
2074 (erase-buffer))
2075 (set-buffer (get-buffer-create gnus-work-buffer))
2076 (kill-all-local-variables)
2077 (buffer-disable-undo (current-buffer))
2078 (gnus-add-current-to-buffer-list)))
745bc783 2079
41487370 2080;; Article file names when saving.
745bc783 2081
41487370
LMI
2082(defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
2083 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2084If variable `gnus-use-long-file-name' is nil, it is ~/News/News.group/num.
2085Otherwise, it is like ~/News/news/group/num."
2086 (let ((default
2087 (expand-file-name
2088 (concat (if (gnus-use-long-file-name 'not-save)
2089 (gnus-capitalize-newsgroup newsgroup)
2090 (gnus-newsgroup-directory-form newsgroup))
2091 "/" (int-to-string (mail-header-number headers)))
2092 (or gnus-article-save-directory "~/News"))))
2093 (if (and last-file
2094 (string-equal (file-name-directory default)
2095 (file-name-directory last-file))
2096 (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2097 default
2098 (or last-file default))))
745bc783 2099
41487370
LMI
2100(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
2101 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2102If variable `gnus-use-long-file-name' is non-nil, it is
2103~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
2104 (let ((default
2105 (expand-file-name
2106 (concat (if (gnus-use-long-file-name 'not-save)
2107 newsgroup
2108 (gnus-newsgroup-directory-form newsgroup))
2109 "/" (int-to-string (mail-header-number headers)))
2110 (or gnus-article-save-directory "~/News"))))
2111 (if (and last-file
2112 (string-equal (file-name-directory default)
2113 (file-name-directory last-file))
2114 (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2115 default
2116 (or last-file default))))
745bc783 2117
41487370
LMI
2118(defun gnus-Plain-save-name (newsgroup headers &optional last-file)
2119 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2120If variable `gnus-use-long-file-name' is non-nil, it is
2121~/News/News.group. Otherwise, it is like ~/News/news/group/news."
2122 (or last-file
2123 (expand-file-name
2124 (if (gnus-use-long-file-name 'not-save)
2125 (gnus-capitalize-newsgroup newsgroup)
2126 (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
2127 (or gnus-article-save-directory "~/News"))))
745bc783 2128
41487370
LMI
2129(defun gnus-plain-save-name (newsgroup headers &optional last-file)
2130 "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2131If variable `gnus-use-long-file-name' is non-nil, it is
2132~/News/news.group. Otherwise, it is like ~/News/news/group/news."
2133 (or last-file
2134 (expand-file-name
2135 (if (gnus-use-long-file-name 'not-save)
2136 newsgroup
2137 (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
2138 (or gnus-article-save-directory "~/News"))))
745bc783 2139
41487370 2140;; For subscribing new newsgroup
745bc783 2141
41487370
LMI
2142(defun gnus-subscribe-hierarchical-interactive (groups)
2143 (let ((groups (sort groups 'string<))
2144 prefixes prefix start ans group starts)
2145 (while groups
2146 (setq prefixes (list "^"))
2147 (while (and groups prefixes)
2148 (while (not (string-match (car prefixes) (car groups)))
2149 (setq prefixes (cdr prefixes)))
2150 (setq prefix (car prefixes))
2151 (setq start (1- (length prefix)))
2152 (if (and (string-match "[^\\.]\\." (car groups) start)
2153 (cdr groups)
2154 (setq prefix
2155 (concat "^" (substring (car groups) 0 (match-end 0))))
2156 (string-match prefix (car (cdr groups))))
2157 (progn
2158 (setq prefixes (cons prefix prefixes))
2159 (message "Descend hierarchy %s? ([y]nsq): "
2160 (substring prefix 1 (1- (length prefix))))
2161 (setq ans (read-char))
2162 (cond ((= ans ?n)
2163 (while (and groups
2164 (string-match prefix
2165 (setq group (car groups))))
2166 (setq gnus-killed-list
2167 (cons group gnus-killed-list))
2168 (gnus-sethash group group gnus-killed-hashtb)
2169 (setq groups (cdr groups)))
2170 (setq starts (cdr starts)))
2171 ((= ans ?s)
2172 (while (and groups
2173 (string-match prefix
2174 (setq group (car groups))))
2175 (gnus-sethash group group gnus-killed-hashtb)
2176 (gnus-subscribe-alphabetically (car groups))
2177 (setq groups (cdr groups)))
2178 (setq starts (cdr starts)))
2179 ((= ans ?q)
2180 (while groups
2181 (setq group (car groups))
2182 (setq gnus-killed-list (cons group gnus-killed-list))
2183 (gnus-sethash group group gnus-killed-hashtb)
2184 (setq groups (cdr groups))))
2185 (t nil)))
2186 (message "Subscribe %s? ([n]yq)" (car groups))
2187 (setq ans (read-char))
2188 (setq group (car groups))
2189 (cond ((= ans ?y)
2190 (gnus-subscribe-alphabetically (car groups))
2191 (gnus-sethash group group gnus-killed-hashtb))
2192 ((= ans ?q)
2193 (while groups
2194 (setq group (car groups))
2195 (setq gnus-killed-list (cons group gnus-killed-list))
2196 (gnus-sethash group group gnus-killed-hashtb)
2197 (setq groups (cdr groups))))
2198 (t
2199 (setq gnus-killed-list (cons group gnus-killed-list))
2200 (gnus-sethash group group gnus-killed-hashtb)))
2201 (setq groups (cdr groups)))))))
745bc783 2202
41487370
LMI
2203(defun gnus-subscribe-randomly (newsgroup)
2204 "Subscribe new NEWSGROUP by making it the first newsgroup."
2205 (gnus-subscribe-newsgroup newsgroup))
745bc783 2206
41487370
LMI
2207(defun gnus-subscribe-alphabetically (newgroup)
2208 "Subscribe new NEWSGROUP and insert it in alphabetical order."
2209 ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams)
2210 (let ((groups (cdr gnus-newsrc-alist))
2211 before)
2212 (while (and (not before) groups)
2213 (if (string< newgroup (car (car groups)))
2214 (setq before (car (car groups)))
2215 (setq groups (cdr groups))))
2216 (gnus-subscribe-newsgroup newgroup before)))
745bc783 2217
41487370
LMI
2218(defun gnus-subscribe-hierarchically (newgroup)
2219 "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order."
2220 ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams)
2221 (save-excursion
2222 (set-buffer (find-file-noselect gnus-current-startup-file))
2223 (let ((groupkey newgroup)
2224 before)
2225 (while (and (not before) groupkey)
2226 (goto-char (point-min))
2227 (let ((groupkey-re
2228 (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]")))
2229 (while (and (re-search-forward groupkey-re nil t)
2230 (progn
2231 (setq before (buffer-substring
2232 (match-beginning 1) (match-end 1)))
2233 (string< before newgroup)))))
2234 ;; Remove tail of newsgroup name (eg. a.b.c -> a.b)
2235 (setq groupkey
2236 (if (string-match "^\\(.*\\)\\.[^.]+$" groupkey)
2237 (substring groupkey (match-beginning 1) (match-end 1)))))
2238 (gnus-subscribe-newsgroup newgroup before))))
2239
2240(defun gnus-subscribe-interactively (newsgroup)
2241 "Subscribe new NEWSGROUP interactively.
2242It is inserted in hierarchical newsgroup order if subscribed. If not,
2243it is killed."
2244 (if (gnus-y-or-n-p (format "Subscribe new newsgroup: %s " newsgroup))
2245 (gnus-subscribe-hierarchically newsgroup)
2246 (setq gnus-killed-list (cons newsgroup gnus-killed-list))))
2247
2248(defun gnus-subscribe-zombies (newsgroup)
2249 "Make new NEWSGROUP a zombie group."
2250 (setq gnus-zombie-list (cons newsgroup gnus-zombie-list)))
2251
2252(defun gnus-subscribe-newsgroup (newsgroup &optional next)
2253 "Subscribe new NEWSGROUP.
2254If NEXT is non-nil, it is inserted before NEXT. Otherwise it is made
2255the first newsgroup."
2256 ;; We subscribe the group by changing its level to `subscribed'.
2257 (gnus-group-change-level
2258 newsgroup gnus-level-default-subscribed
2259 gnus-level-killed (gnus-gethash (or next "dummy.group") gnus-newsrc-hashtb))
2260 (gnus-message 5 "Subscribe newsgroup: %s" newsgroup))
2261
2262;; For directories
2263
2264(defun gnus-newsgroup-directory-form (newsgroup)
2265 "Make hierarchical directory name from NEWSGROUP name."
b94ae5f7 2266 (let ((newsgroup (gnus-newsgroup-savable-name newsgroup))
41487370
LMI
2267 (len (length newsgroup))
2268 idx)
2269 ;; If this is a foreign group, we don't want to translate the
2270 ;; entire name.
2271 (if (setq idx (string-match ":" newsgroup))
2272 (aset newsgroup idx ?/)
2273 (setq idx 0))
2274 ;; Replace all occurrences of `.' with `/'.
2275 (while (< idx len)
2276 (if (= (aref newsgroup idx) ?.)
2277 (aset newsgroup idx ?/))
2278 (setq idx (1+ idx)))
2279 newsgroup))
2280
b94ae5f7 2281(defun gnus-newsgroup-savable-name (group)
41487370
LMI
2282 ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
2283 ;; with dots.
2284 (gnus-replace-chars-in-string group ?/ ?.))
2285
2286(defun gnus-make-directory (dir)
2287 "Make DIRECTORY recursively."
2288 ;; Why don't we use `(make-directory dir 'parents)'? That's just one
2289 ;; of the many mysteries of the universe.
2290 (let* ((dir (expand-file-name dir default-directory))
2291 dirs err)
2292 (if (string-match "/$" dir)
2293 (setq dir (substring dir 0 (match-beginning 0))))
2294 ;; First go down the path until we find a directory that exists.
2295 (while (not (file-exists-p dir))
2296 (setq dirs (cons dir dirs))
2297 (string-match "/[^/]+$" dir)
2298 (setq dir (substring dir 0 (match-beginning 0))))
2299 ;; Then create all the subdirs.
2300 (while (and dirs (not err))
2301 (condition-case ()
2302 (make-directory (car dirs))
2303 (error (setq err t)))
2304 (setq dirs (cdr dirs)))
2305 ;; We return whether we were successful or not.
2306 (not dirs)))
2307
2308(defun gnus-capitalize-newsgroup (newsgroup)
2309 "Capitalize NEWSGROUP name."
2310 (and (not (zerop (length newsgroup)))
2311 (concat (char-to-string (upcase (aref newsgroup 0)))
2312 (substring newsgroup 1))))
2313
2314;; Var
2315
2316(defun gnus-simplify-subject (subject &optional re-only)
2317 "Remove `Re:' and words in parentheses.
2318If optional argument RE-ONLY is non-nil, strip `Re:' only."
2319 (let ((case-fold-search t)) ;Ignore case.
2320 ;; Remove `Re:' and `Re^N:'.
2321 (if (string-match "^re:[ \t]*" subject)
2322 (setq subject (substring subject (match-end 0))))
2323 ;; Remove words in parentheses from end.
2324 (or re-only
2325 (while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject)
2326 (setq subject (substring subject 0 (match-beginning 0)))))
2327 ;; Return subject string.
2328 subject))
2329
2330;; Remove any leading "re:"s, any trailing paren phrases, and simplify
2331;; all whitespace.
2332(defun gnus-simplify-subject-fuzzy (subject)
2333 (let ((case-fold-search t))
2334 (save-excursion
2335 (gnus-set-work-buffer)
2336 (insert subject)
2337 (inline (gnus-simplify-buffer-fuzzy))
2338 (buffer-string))))
2339
2340(defun gnus-simplify-buffer-fuzzy ()
2341 (goto-char (point-min))
2342 ;; Fix by Stainless Steel Rat <ratinox@ccs.neu.edu>.
2343 (while (re-search-forward "^[ \t]*\\(re\\|fwd\\)[[{(^0-9]*[])}]?[:;][ \t]*"
2344 nil t)
2345 (replace-match "" t t))
2346 (goto-char (point-min))
2347 (while (re-search-forward "[ \t\n]*([^()]*)[ \t\n]*$" nil t)
2348 (replace-match "" t t))
2349 (goto-char (point-min))
2350 (while (re-search-forward "[ \t]+" nil t)
2351 (replace-match " " t t))
2352 (goto-char (point-min))
2353 (while (re-search-forward "[ \t]+$" nil t)
2354 (replace-match "" t t))
2355 (goto-char (point-min))
2356 (while (re-search-forward "^[ \t]+" nil t)
2357 (replace-match "" t t))
2358 (if gnus-simplify-subject-fuzzy-regexp
2359 (while (re-search-forward gnus-simplify-subject-fuzzy-regexp nil t)
2360 (replace-match "" t t))))
2361
2362;; Add the current buffer to the list of buffers to be killed on exit.
2363(defun gnus-add-current-to-buffer-list ()
2364 (or (memq (current-buffer) gnus-buffer-list)
2365 (setq gnus-buffer-list (cons (current-buffer) gnus-buffer-list))))
2366
2367(defun gnus-string> (s1 s2)
2368 (not (or (string< s1 s2)
2369 (string= s1 s2))))
2370
2371;; Functions accessing headers.
2372;; Functions are more convenient than macros in some cases.
2373
2374(defun gnus-header-number (header)
2375 (mail-header-number header))
2376
2377(defun gnus-header-subject (header)
2378 (mail-header-subject header))
2379
2380(defun gnus-header-from (header)
2381 (mail-header-from header))
2382
2383(defun gnus-header-xref (header)
2384 (mail-header-xref header))
2385
2386(defun gnus-header-lines (header)
2387 (mail-header-lines header))
2388
2389(defun gnus-header-date (header)
2390 (mail-header-date header))
2391
2392(defun gnus-header-id (header)
2393 (mail-header-id header))
2394
2395(defun gnus-header-message-id (header)
2396 (mail-header-id header))
2397
2398(defun gnus-header-chars (header)
2399 (mail-header-chars header))
2400
2401(defun gnus-header-references (header)
2402 (mail-header-references header))
2403
2404;;; General various misc type functions.
2405
2406(defun gnus-clear-system ()
2407 "Clear all variables and buffers."
2408 ;; Clear Gnus variables.
2409 (let ((variables gnus-variable-list))
2410 (while variables
2411 (set (car variables) nil)
2412 (setq variables (cdr variables))))
2413 ;; Clear other internal variables.
2414 (setq gnus-list-of-killed-groups nil
2415 gnus-have-read-active-file nil
2416 gnus-newsrc-alist nil
2417 gnus-newsrc-hashtb nil
2418 gnus-killed-list nil
2419 gnus-zombie-list nil
2420 gnus-killed-hashtb nil
2421 gnus-active-hashtb nil
2422 gnus-moderated-list nil
2423 gnus-description-hashtb nil
2424 gnus-newsgroup-headers nil
2425 gnus-newsgroup-headers-hashtb-by-number nil
2426 gnus-newsgroup-name nil
2427 gnus-server-alist nil
2428 gnus-current-select-method nil)
2429 ;; Reset any score variables.
2430 (and (boundp 'gnus-score-cache)
2431 (set 'gnus-score-cache nil))
2432 (and (boundp 'gnus-internal-global-score-files)
2433 (set 'gnus-internal-global-score-files nil))
2434 ;; Kill the startup file.
2435 (and gnus-current-startup-file
2436 (get-file-buffer gnus-current-startup-file)
2437 (kill-buffer (get-file-buffer gnus-current-startup-file)))
2438 ;; Save any cache buffers.
2439 (and gnus-use-cache (gnus-cache-save-buffers))
2440 ;; Clear the dribble buffer.
2441 (gnus-dribble-clear)
2442 ;; Kill global KILL file buffer.
2443 (if (get-file-buffer (gnus-newsgroup-kill-file nil))
2444 (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil))))
2445 (gnus-kill-buffer nntp-server-buffer)
2446 ;; Kill Gnus buffers.
2447 (while gnus-buffer-list
2448 (gnus-kill-buffer (car gnus-buffer-list))
2449 (setq gnus-buffer-list (cdr gnus-buffer-list))))
2450
2451(defun gnus-windows-old-to-new (setting)
2452 ;; First we take care of the really, really old Gnus 3 actions.
2453 (if (symbolp setting)
2454 (setq setting
2455 (cond ((memq setting '(SelectArticle))
2456 'article)
2457 ((memq setting '(SelectSubject ExpandSubject))
2458 'summary)
2459 ((memq setting '(SelectNewsgroup ExitNewsgroup))
2460 'group)
2461 (t setting))))
2462 (if (or (listp setting)
2463 (not (and gnus-window-configuration
2464 (memq setting '(group summary article)))))
2465 setting
2466 (let* ((setting (if (eq setting 'group)
2467 (if (assq 'newsgroup gnus-window-configuration)
2468 'newsgroup
2469 'newsgroups) setting))
2470 (elem (car (cdr (assq setting gnus-window-configuration))))
2471 (total (apply '+ elem))
2472 (types '(group summary article))
2473 (pbuf (if (eq setting 'newsgroups) 'group 'summary))
2474 (i 0)
2475 perc
2476 out)
2477 (while (< i 3)
2478 (or (not (numberp (nth i elem)))
2479 (zerop (nth i elem))
2480 (progn
2481 (setq perc (/ (* 1.0 (nth 0 elem)) total))
2482 (setq out (cons (if (eq pbuf (nth i types))
2483 (vector (nth i types) perc 'point)
2484 (vector (nth i types) perc))
2485 out))))
2486 (setq i (1+ i)))
2487 (list (nreverse out)))))
2488
2489(defun gnus-add-configuration (conf)
2490 (setq gnus-buffer-configuration
2491 (cons conf (delq (assq (car conf) gnus-buffer-configuration)
2492 gnus-buffer-configuration))))
2493
2494(defun gnus-configure-windows (setting &optional force)
2495 (setq setting (gnus-windows-old-to-new setting))
2496 (let ((r (if (symbolp setting)
2497 (cdr (assq setting gnus-buffer-configuration))
2498 setting))
2499 (in-buf (current-buffer))
2500 rule val w height hor ohor heights sub jump-buffer
2501 rel total to-buf all-visible)
2502 (or r (error "No such setting: %s" setting))
2503
2504 (if (and (not force) (setq all-visible (gnus-all-windows-visible-p r)))
2505 ;; All the windows mentioned are already visible, so we just
2506 ;; put point in the assigned buffer, and do not touch the
2507 ;; winconf.
2508 (select-window (get-buffer-window all-visible t))
2509
2510
2511 ;; Either remove all windows or just remove all Gnus windows.
2512 (if gnus-use-full-window
2513 (delete-other-windows)
2514 (gnus-remove-some-windows)
2515 (switch-to-buffer nntp-server-buffer))
2516
2517 (while r
2518 (setq hor (car r)
2519 ohor nil)
2520
2521 ;; We have to do the (possible) horizontal splitting before the
2522 ;; vertical.
2523 (if (and (listp (car hor))
2524 (eq (car (car hor)) 'horizontal))
2525 (progn
2526 (split-window
2527 nil
2528 (if (integerp (nth 1 (car hor)))
2529 (nth 1 (car hor))
2530 (- (frame-width) (floor (* (frame-width) (nth 1 (car hor))))))
2531 t)
2532 (setq hor (cdr hor))))
2533
2534 ;; Go through the rules and eval the elements that are to be
b94ae5f7 2535 ;; evalled.
41487370
LMI
2536 (while hor
2537 (if (setq val (if (vectorp (car hor)) (car hor) (eval (car hor))))
2538 (progn
2539 ;; Expand short buffer name.
2540 (setq w (aref val 0))
2541 (and (setq w (cdr (assq w gnus-window-to-buffer)))
2542 (progn
2543 (setq val (apply 'vector (mapcar 'identity val)))
2544 (aset val 0 w)))
2545 (setq ohor (cons val ohor))))
2546 (setq hor (cdr hor)))
2547 (setq rule (cons (nreverse ohor) rule))
2548 (setq r (cdr r)))
2549 (setq rule (nreverse rule))
2550
2551 ;; We tally the window sizes.
2552 (setq total (window-height))
2553 (while rule
2554 (setq hor (car rule))
2555 (if (and (listp (car hor)) (eq (car (car hor)) 'horizontal))
2556 (setq hor (cdr hor)))
2557 (setq sub 0)
2558 (while hor
2559 (setq rel (aref (car hor) 1)
2560 heights (cons
2561 (cond ((and (floatp rel) (= 1.0 rel))
2562 'x)
2563 ((integerp rel)
2564 rel)
2565 (t
2566 (max (floor (* total rel)) 4)))
2567 heights)
2568 sub (+ sub (if (numberp (car heights)) (car heights) 0))
2569 hor (cdr hor)))
2570 (setq heights (nreverse heights)
2571 hor (car rule))
2572
b94ae5f7 2573 ;; We then go through these heights and create windows for them.
41487370
LMI
2574 (while heights
2575 (setq height (car heights)
2576 heights (cdr heights))
2577 (and (eq height 'x)
2578 (setq height (- total sub)))
2579 (and heights
2580 (split-window nil height))
2581 (setq to-buf (aref (car hor) 0))
2582 (switch-to-buffer
2583 (cond ((not to-buf)
2584 in-buf)
2585 ((symbolp to-buf)
2586 (symbol-value (aref (car hor) 0)))
2587 (t
2588 (aref (car hor) 0))))
2589 (and (> (length (car hor)) 2)
2590 (eq (aref (car hor) 2) 'point)
2591 (setq jump-buffer (current-buffer)))
2592 (other-window 1)
2593 (setq hor (cdr hor)))
2594
2595 (setq rule (cdr rule)))
2596
2597 ;; Finally, we pop to the buffer that's supposed to have point.
2598 (or jump-buffer (error "Missing `point' in spec for %s" setting))
2599
2600 (select-window (get-buffer-window jump-buffer t))
2601 (set-buffer jump-buffer))))
2602
2603(defun gnus-all-windows-visible-p (rule)
2604 (let (invisible hor jump-buffer val buffer)
2605 ;; Go through the rules and eval the elements that are to be
b94ae5f7 2606 ;; evalled.
41487370
LMI
2607 (while (and rule (not invisible))
2608 (setq hor (car rule)
2609 rule (cdr rule))
2610 (while (and hor (not invisible))
2611 (if (setq val (if (vectorp (car hor))
2612 (car hor)
2613 (if (not (eq (car (car hor)) 'horizontal))
2614 (eval (car hor)))))
2615 (progn
2616 ;; Expand short buffer name.
2617 (setq buffer (or (cdr (assq (aref val 0) gnus-window-to-buffer))
2618 (aref val 0)))
2619 (setq buffer (if (symbolp buffer) (symbol-value buffer)
2620 buffer))
2621 (and (> (length val) 2) (eq 'point (aref val 2))
2622 (setq jump-buffer buffer))
2623 (setq invisible (not (and buffer (get-buffer-window buffer))))))
2624 (setq hor (cdr hor))))
2625 (and (not invisible) jump-buffer)))
2626
2627(defun gnus-window-top-edge (&optional window)
2628 (nth 1 (window-edges window)))
2629
2630(defun gnus-remove-some-windows ()
2631 (let ((buffers gnus-window-to-buffer)
2632 buf bufs lowest-buf lowest)
2633 (save-excursion
2634 ;; Remove windows on all known Gnus buffers.
2635 (while buffers
2636 (setq buf (cdr (car buffers)))
2637 (if (symbolp buf)
2638 (setq buf (and (boundp buf) (symbol-value buf))))
2639 (and buf
2640 (get-buffer-window buf)
2641 (progn
2642 (setq bufs (cons buf bufs))
2643 (pop-to-buffer buf)
2644 (if (or (not lowest)
2645 (< (gnus-window-top-edge) lowest))
2646 (progn
2647 (setq lowest (gnus-window-top-edge))
2648 (setq lowest-buf buf)))))
2649 (setq buffers (cdr buffers)))
2650 ;; Remove windows on *all* summary buffers.
2651 (let (wins)
2652 (walk-windows
2653 (lambda (win)
2654 (let ((buf (window-buffer win)))
2655 (if (string-match "^\\*Summary" (buffer-name buf))
2656 (progn
2657 (setq bufs (cons buf bufs))
2658 (pop-to-buffer buf)
2659 (if (or (not lowest)
2660 (< (gnus-window-top-edge) lowest))
2661 (progn
2662 (setq lowest-buf buf)
2663 (setq lowest (gnus-window-top-edge))))))))))
2664 (and lowest-buf
2665 (progn
2666 (pop-to-buffer lowest-buf)
2667 (switch-to-buffer nntp-server-buffer)))
2668 (while bufs
2669 (and (not (eq (car bufs) lowest-buf))
2670 (delete-windows-on (car bufs)))
2671 (setq bufs (cdr bufs))))))
2672
2673(defun gnus-version ()
2674 "Version numbers of this version of Gnus."
2675 (interactive)
2676 (let ((methods gnus-valid-select-methods)
2677 (mess gnus-version)
2678 meth)
2679 ;; Go through all the legal select methods and add their version
2680 ;; numbers to the total version string. Only the backends that are
2681 ;; currently in use will have their message numbers taken into
2682 ;; consideration.
2683 (while methods
2684 (setq meth (intern (concat (car (car methods)) "-version")))
2685 (and (boundp meth)
2686 (stringp (symbol-value meth))
2687 (setq mess (concat mess "; " (symbol-value meth))))
2688 (setq methods (cdr methods)))
2689 (gnus-message 2 mess)))
2690
2691(defun gnus-info-find-node ()
2692 "Find Info documentation of Gnus."
2693 (interactive)
2694 ;; Enlarge info window if needed.
2695 (let ((mode major-mode))
2696 (gnus-configure-windows 'info)
2697 (Info-goto-node (car (cdr (assq mode gnus-info-nodes))))))
2698
2699(defun gnus-overload-functions (&optional overloads)
2700 "Overload functions specified by optional argument OVERLOADS.
2701If nothing is specified, use the variable gnus-overload-functions."
2702 (let ((defs nil)
2703 (overloads (or overloads gnus-overload-functions)))
2704 (while overloads
2705 (setq defs (car overloads))
2706 (setq overloads (cdr overloads))
2707 ;; Load file before overloading function if necessary. Make
2708 ;; sure we cannot use `require' always.
2709 (and (not (fboundp (car defs)))
2710 (car (cdr (cdr defs)))
2711 (load (car (cdr (cdr defs))) nil 'nomessage))
2712 (fset (car defs) (car (cdr defs))))))
2713
2714(defun gnus-replace-chars-in-string (string &rest pairs)
2715 "Replace characters in STRING from FROM to TO."
2716 (let ((string (substring string 0)) ;Copy string.
2717 (len (length string))
2718 (idx 0)
2719 sym to)
2720 (or (zerop (% (length pairs) 2))
2721 (error "Odd number of translation pairs"))
2722 (setplist 'sym pairs)
2723 ;; Replace all occurrences of FROM with TO.
2724 (while (< idx len)
2725 (if (setq to (get 'sym (aref string idx)))
2726 (aset string idx to))
2727 (setq idx (1+ idx)))
2728 string))
2729
2730(defun gnus-days-between (date1 date2)
2731 ;; Return the number of days between date1 and date2.
2732 (- (gnus-day-number date1) (gnus-day-number date2)))
2733
2734(defun gnus-day-number (date)
2735 (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
2736 (timezone-parse-date date))))
2737 (timezone-absolute-from-gregorian
2738 (nth 1 dat) (nth 2 dat) (car dat))))
2739
2740;; Returns a floating point number that says how many seconds have
2741;; lapsed between Jan 1 12:00:00 1970 and DATE.
2742(defun gnus-seconds-since-epoch (date)
2743 (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
2744 (timezone-parse-date date)))
2745 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
2746 (timezone-parse-time
2747 (aref (timezone-parse-date date) 3))))
2748 (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
2749 (timezone-parse-date "Jan 1 12:00:00 1970")))
2750 (tday (- (timezone-absolute-from-gregorian
2751 (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
2752 (timezone-absolute-from-gregorian
2753 (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
2754 (+ (nth 2 ttime)
2755 (* (nth 1 ttime) 60)
2756 (* 1.0 (nth 0 ttime) 60 60)
2757 (* 1.0 tday 60 60 24))))
2758
2759(defun gnus-file-newer-than (file date)
2760 (let ((fdate (nth 5 (file-attributes file))))
2761 (or (> (car fdate) (car date))
2762 (and (= (car fdate) (car date))
2763 (> (nth 1 fdate) (nth 1 date))))))
2764
2765(defun gnus-group-read-only-p (&optional group)
2766 "Check whether GROUP supports editing or not.
2767If GROUP is nil, `gnus-newsgroup-name' will be checked instead. Note
2768that that variable is buffer-local to the summary buffers."
2769 (let ((group (or group gnus-newsgroup-name)))
2770 (not (gnus-check-backend-function 'request-replace-article group))))
2771
2772;; Two silly functions to ensure that all `y-or-n-p' questions clear
2773;; the echo area.
2774(defun gnus-y-or-n-p (prompt)
2775 (prog1
2776 (y-or-n-p prompt)
2777 (message "")))
2778
2779(defun gnus-yes-or-no-p (prompt)
2780 (prog1
2781 (yes-or-no-p prompt)
2782 (message "")))
2783
2784;; Check whether to use long file names.
2785(defun gnus-use-long-file-name (symbol)
2786 ;; The variable has to be set...
2787 (and gnus-use-long-file-name
2788 ;; If it isn't a list, then we return t.
2789 (or (not (listp gnus-use-long-file-name))
2790 ;; If it is a list, and the list contains `symbol', we
2791 ;; return nil.
2792 (not (memq symbol gnus-use-long-file-name)))))
2793
2794;; I suspect there's a better way, but I haven't taken the time to do
2795;; it yet. -erik selberg@cs.washington.edu
2796(defun gnus-dd-mmm (messy-date)
2797 "Return a string like DD-MMM from a big messy string"
2798 (let ((datevec (timezone-parse-date messy-date)))
2799 (format "%2s-%s"
2800 (or (aref datevec 2) "??")
2801 (capitalize
2802 (or (car
2803 (nth (1- (string-to-number (aref datevec 1)))
2804 timezone-months-assoc))
2805 "???")))))
2806
2807;; Make a hash table (default and minimum size is 255).
2808;; Optional argument HASHSIZE specifies the table size.
2809(defun gnus-make-hashtable (&optional hashsize)
2810 (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 255) 255) 0))
2811
2812;; Make a number that is suitable for hashing; bigger than MIN and one
2813;; less than 2^x.
2814(defun gnus-create-hash-size (min)
2815 (let ((i 1))
2816 (while (< i min)
2817 (setq i (* 2 i)))
2818 (1- i)))
2819
2820;; Show message if message has a lower level than `gnus-verbose'.
2821;; Guide-line for numbers:
2822;; 1 - error messages, 3 - non-serious error messages, 5 - messages
2823;; for things that take a long time, 7 - not very important messages
2824;; on stuff, 9 - messages inside loops.
2825(defun gnus-message (level &rest args)
2826 (if (<= level gnus-verbose)
2827 (apply 'message args)
b94ae5f7 2828 ;; We have to do this format thingy here even if the result isn't
41487370
LMI
2829 ;; shown - the return value has to be the same as the return value
2830 ;; from `message'.
2831 (apply 'format args)))
2832
2833;; Generate a unique new group name.
2834(defun gnus-generate-new-group-name (leaf)
2835 (let ((name leaf)
2836 (num 0))
2837 (while (gnus-gethash name gnus-newsrc-hashtb)
2838 (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">")))
2839 name))
2840
2841(defun gnus-ephemeral-group-p (group)
2842 "Say whether GROUP is ephemeral or not."
2843 (assoc 'quit-config (gnus-find-method-for-group group)))
2844
2845(defun gnus-group-quit-config (group)
2846 "Return the quit-config of GROUP."
3425f79a 2847 (nth 1 (assoc 'quit-config (gnus-find-method-for-group group))))
41487370 2848
a828a776
LMI
2849(defun gnus-simplify-mode-line ()
2850 "Make mode lines a bit simpler."
2851 (setq mode-line-modified "-- ")
2852 (if (listp mode-line-format)
2853 (progn
2854 (make-local-variable 'mode-line-format)
2855 (setq mode-line-format (copy-sequence mode-line-format))
2856 (and (equal (nth 3 mode-line-format) " ")
2857 (setcar (nthcdr 3 mode-line-format) "")))))
2858
41487370
LMI
2859;;; List and range functions
2860
2861(defun gnus-last-element (list)
2862 "Return last element of LIST."
2863 (while (cdr list)
2864 (setq list (cdr list)))
2865 (car list))
2866
2867(defun gnus-copy-sequence (list)
2868 "Do a complete, total copy of a list."
2869 (if (and (consp list) (not (consp (cdr list))))
2870 (cons (car list) (cdr list))
2871 (mapcar (lambda (elem) (if (consp elem)
2872 (if (consp (cdr elem))
2873 (gnus-copy-sequence elem)
2874 (cons (car elem) (cdr elem)))
2875 elem))
2876 list)))
2877
2878(defun gnus-set-difference (list1 list2)
2879 "Return a list of elements of LIST1 that do not appear in LIST2."
2880 (let ((list1 (copy-sequence list1)))
2881 (while list2
2882 (setq list1 (delq (car list2) list1))
2883 (setq list2 (cdr list2)))
2884 list1))
2885
2886(defun gnus-sorted-complement (list1 list2)
2887 "Return a list of elements of LIST1 that do not appear in LIST2.
2888Both lists have to be sorted over <."
2889 (let (out)
2890 (if (or (null list1) (null list2))
2891 (or list1 list2)
2892 (while (and list1 list2)
2893 (cond ((= (car list1) (car list2))
2894 (setq list1 (cdr list1)
2895 list2 (cdr list2)))
2896 ((< (car list1) (car list2))
2897 (setq out (cons (car list1) out))
2898 (setq list1 (cdr list1)))
2899 (t
2900 (setq out (cons (car list2) out))
2901 (setq list2 (cdr list2)))))
2902 (nconc (nreverse out) (or list1 list2)))))
2903
2904(defun gnus-intersection (list1 list2)
2905 (let ((result nil))
2906 (while list2
2907 (if (memq (car list2) list1)
2908 (setq result (cons (car list2) result)))
2909 (setq list2 (cdr list2)))
2910 result))
2911
2912(defun gnus-sorted-intersection (list1 list2)
2913 ;; LIST1 and LIST2 have to be sorted over <.
2914 (let (out)
2915 (while (and list1 list2)
2916 (cond ((= (car list1) (car list2))
2917 (setq out (cons (car list1) out)
2918 list1 (cdr list1)
2919 list2 (cdr list2)))
2920 ((< (car list1) (car list2))
2921 (setq list1 (cdr list1)))
2922 (t
2923 (setq list2 (cdr list2)))))
2924 (nreverse out)))
2925
2926(defun gnus-set-sorted-intersection (list1 list2)
2927 ;; LIST1 and LIST2 have to be sorted over <.
2928 ;; This function modifies LIST1.
2929 (let* ((top (cons nil list1))
2930 (prev top))
2931 (while (and list1 list2)
2932 (cond ((= (car list1) (car list2))
2933 (setq prev list1
2934 list1 (cdr list1)
2935 list2 (cdr list2)))
2936 ((< (car list1) (car list2))
2937 (setcdr prev (cdr list1))
2938 (setq list1 (cdr list1)))
2939 (t
2940 (setq list2 (cdr list2)))))
2941 (setcdr prev nil)
2942 (cdr top)))
2943
2944(defun gnus-compress-sequence (numbers &optional always-list)
2945 "Convert list of numbers to a list of ranges or a single range.
2946If ALWAYS-LIST is non-nil, this function will always release a list of
2947ranges."
2948 (let* ((first (car numbers))
2949 (last (car numbers))
2950 result)
2951 (if (null numbers)
2952 nil
2953 (if (not (listp (cdr numbers)))
2954 numbers
2955 (while numbers
2956 (cond ((= last (car numbers)) nil) ;Omit duplicated number
2957 ((= (1+ last) (car numbers)) ;Still in sequence
2958 (setq last (car numbers)))
2959 (t ;End of one sequence
2960 (setq result
2961 (cons (if (= first last) first
2962 (cons first last)) result))
2963 (setq first (car numbers))
2964 (setq last (car numbers))))
2965 (setq numbers (cdr numbers)))
2966 (if (and (not always-list) (null result))
2967 (if (= first last) (list first) (cons first last))
2968 (nreverse (cons (if (= first last) first (cons first last))
2969 result)))))))
2970
2971(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range)
2972(defun gnus-uncompress-range (ranges)
2973 "Expand a list of ranges into a list of numbers.
2974RANGES is either a single range on the form `(num . num)' or a list of
2975these ranges."
2976 (let (first last result)
2977 (cond
2978 ((null ranges)
2979 nil)
2980 ((not (listp (cdr ranges)))
2981 (setq first (car ranges))
2982 (setq last (cdr ranges))
2983 (while (<= first last)
2984 (setq result (cons first result))
2985 (setq first (1+ first)))
2986 (nreverse result))
2987 (t
2988 (while ranges
2989 (if (atom (car ranges))
2990 (if (numberp (car ranges))
2991 (setq result (cons (car ranges) result)))
2992 (setq first (car (car ranges)))
2993 (setq last (cdr (car ranges)))
2994 (while (<= first last)
2995 (setq result (cons first result))
2996 (setq first (1+ first))))
2997 (setq ranges (cdr ranges)))
2998 (nreverse result)))))
2999
3000(defun gnus-add-to-range (ranges list)
3001 "Return a list of ranges that has all articles from both RANGES and LIST.
3002Note: LIST has to be sorted over `<'."
3003 (if (not ranges)
3004 (gnus-compress-sequence list t)
3005 (setq list (copy-sequence list))
3006 (or (listp (cdr ranges))
3007 (setq ranges (list ranges)))
3008 (let ((out ranges)
3009 ilist lowest highest temp)
3010 (while (and ranges list)
3011 (setq ilist list)
3012 (setq lowest (or (and (atom (car ranges)) (car ranges))
3013 (car (car ranges))))
3014 (while (and list (cdr list) (< (car (cdr list)) lowest))
3015 (setq list (cdr list)))
3016 (if (< (car ilist) lowest)
3017 (progn
3018 (setq temp list)
3019 (setq list (cdr list))
3020 (setcdr temp nil)
3021 (setq out (nconc (gnus-compress-sequence ilist t) out))))
3022 (setq highest (or (and (atom (car ranges)) (car ranges))
3023 (cdr (car ranges))))
3024 (while (and list (<= (car list) highest))
3025 (setq list (cdr list)))
3026 (setq ranges (cdr ranges)))
3027 (if list
3028 (setq out (nconc (gnus-compress-sequence list t) out)))
3029 (setq out (sort out (lambda (r1 r2)
3030 (< (or (and (atom r1) r1) (car r1))
3031 (or (and (atom r2) r2) (car r2))))))
3032 (setq ranges out)
3033 (while ranges
3034 (if (atom (car ranges))
3035 (if (cdr ranges)
3036 (if (atom (car (cdr ranges)))
3037 (if (= (1+ (car ranges)) (car (cdr ranges)))
3038 (progn
3039 (setcar ranges (cons (car ranges)
3040 (car (cdr ranges))))
3041 (setcdr ranges (cdr (cdr ranges)))))
3042 (if (= (1+ (car ranges)) (car (car (cdr ranges))))
3043 (progn
3044 (setcar (car (cdr ranges)) (car ranges))
3045 (setcar ranges (car (cdr ranges)))
3046 (setcdr ranges (cdr (cdr ranges)))))))
3047 (if (cdr ranges)
3048 (if (atom (car (cdr ranges)))
3049 (if (= (1+ (cdr (car ranges))) (car (cdr ranges)))
3050 (progn
3051 (setcdr (car ranges) (car (cdr ranges)))
3052 (setcdr ranges (cdr (cdr ranges)))))
3053 (if (= (1+ (cdr (car ranges))) (car (car (cdr ranges))))
3054 (progn
3055 (setcdr (car ranges) (cdr (car (cdr ranges))))
3056 (setcdr ranges (cdr (cdr ranges))))))))
3057 (setq ranges (cdr ranges)))
3058 out)))
3059
3060(defun gnus-remove-from-range (ranges list)
3061 "Return a list of ranges that has all articles from LIST removed from RANGES.
3062Note: LIST has to be sorted over `<'."
3063 ;; !!! This function shouldn't look like this, but I've got a headache.
3064 (gnus-compress-sequence
3065 (gnus-sorted-complement
3066 (gnus-uncompress-range ranges) list)))
3067
3068(defun gnus-member-of-range (number ranges)
3069 (if (not (listp (cdr ranges)))
3070 (and (>= number (car ranges))
3071 (<= number (cdr ranges)))
3072 (let ((not-stop t))
3073 (while (and ranges
3074 (if (numberp (car ranges))
3075 (>= number (car ranges))
3076 (>= number (car (car ranges))))
3077 not-stop)
3078 (if (if (numberp (car ranges))
3079 (= number (car ranges))
3080 (and (>= number (car (car ranges)))
3081 (<= number (cdr (car ranges)))))
3082 (setq not-stop nil))
3083 (setq ranges (cdr ranges)))
3084 (not not-stop))))
3085
3086\f
3087;;;
3088;;; Gnus group mode
3089;;;
3090
3091(defvar gnus-group-mode-map nil)
3092(defvar gnus-group-group-map nil)
3093(defvar gnus-group-mark-map nil)
3094(defvar gnus-group-list-map nil)
7e988fb6 3095(defvar gnus-group-help-map nil)
41487370
LMI
3096(defvar gnus-group-sub-map nil)
3097(put 'gnus-group-mode 'mode-class 'special)
3098
3099(if gnus-group-mode-map
3100 nil
3101 (setq gnus-group-mode-map (make-keymap))
3102 (suppress-keymap gnus-group-mode-map)
3103 (define-key gnus-group-mode-map " " 'gnus-group-read-group)
3104 (define-key gnus-group-mode-map "=" 'gnus-group-select-group)
3105 (define-key gnus-group-mode-map "\r" 'gnus-group-select-group)
3106 (define-key gnus-group-mode-map "j" 'gnus-group-jump-to-group)
b027f415
RS
3107 (define-key gnus-group-mode-map "n" 'gnus-group-next-unread-group)
3108 (define-key gnus-group-mode-map "p" 'gnus-group-prev-unread-group)
3109 (define-key gnus-group-mode-map "\177" 'gnus-group-prev-unread-group)
3110 (define-key gnus-group-mode-map "N" 'gnus-group-next-group)
3111 (define-key gnus-group-mode-map "P" 'gnus-group-prev-group)
41487370
LMI
3112 (define-key gnus-group-mode-map
3113 "\M-n" 'gnus-group-next-unread-group-same-level)
3114 (define-key gnus-group-mode-map
3115 "\M-p" 'gnus-group-prev-unread-group-same-level)
3116 (define-key gnus-group-mode-map "," 'gnus-group-best-unread-group)
3117 (define-key gnus-group-mode-map "." 'gnus-group-first-unread-group)
b027f415
RS
3118 (define-key gnus-group-mode-map "u" 'gnus-group-unsubscribe-current-group)
3119 (define-key gnus-group-mode-map "U" 'gnus-group-unsubscribe-group)
41487370
LMI
3120 (define-key gnus-group-mode-map "c" 'gnus-group-catchup-current)
3121 (define-key gnus-group-mode-map "C" 'gnus-group-catchup-current-all)
b027f415
RS
3122 (define-key gnus-group-mode-map "l" 'gnus-group-list-groups)
3123 (define-key gnus-group-mode-map "L" 'gnus-group-list-all-groups)
41487370 3124 (define-key gnus-group-mode-map "m" 'gnus-group-mail)
b027f415 3125 (define-key gnus-group-mode-map "g" 'gnus-group-get-new-news)
41487370 3126 (define-key gnus-group-mode-map "\M-g" 'gnus-group-get-new-news-this-group)
b027f415 3127 (define-key gnus-group-mode-map "R" 'gnus-group-restart)
41487370
LMI
3128 (define-key gnus-group-mode-map "r" 'gnus-group-read-init-file)
3129 (define-key gnus-group-mode-map "B" 'gnus-group-browse-foreign-server)
b027f415 3130 (define-key gnus-group-mode-map "b" 'gnus-group-check-bogus-groups)
41487370
LMI
3131 (define-key gnus-group-mode-map "F" 'gnus-find-new-newsgroups)
3132 (define-key gnus-group-mode-map "\C-c\C-d" 'gnus-group-describe-group)
3133 (define-key gnus-group-mode-map "\M-d" 'gnus-group-describe-all-groups)
3134 (define-key gnus-group-mode-map "\C-c\C-a" 'gnus-group-apropos)
3135 (define-key gnus-group-mode-map "\C-c\M-\C-a" 'gnus-group-description-apropos)
b027f415
RS
3136 (define-key gnus-group-mode-map "a" 'gnus-group-post-news)
3137 (define-key gnus-group-mode-map "\ek" 'gnus-group-edit-local-kill)
3138 (define-key gnus-group-mode-map "\eK" 'gnus-group-edit-global-kill)
3139 (define-key gnus-group-mode-map "\C-k" 'gnus-group-kill-group)
3140 (define-key gnus-group-mode-map "\C-y" 'gnus-group-yank-group)
3141 (define-key gnus-group-mode-map "\C-w" 'gnus-group-kill-region)
3142 (define-key gnus-group-mode-map "\C-x\C-t" 'gnus-group-transpose-groups)
41487370
LMI
3143 (define-key gnus-group-mode-map "\C-c\C-l" 'gnus-group-list-killed)
3144 (define-key gnus-group-mode-map "\C-c\C-x" 'gnus-group-expire-articles)
3145 (define-key gnus-group-mode-map "\C-c\M-\C-x" 'gnus-group-expire-all-groups)
b027f415 3146 (define-key gnus-group-mode-map "V" 'gnus-version)
41487370 3147 (define-key gnus-group-mode-map "s" 'gnus-group-save-newsrc)
b027f415 3148 (define-key gnus-group-mode-map "z" 'gnus-group-suspend)
41487370 3149 (define-key gnus-group-mode-map "Z" 'gnus-group-clear-dribble)
b027f415
RS
3150 (define-key gnus-group-mode-map "q" 'gnus-group-exit)
3151 (define-key gnus-group-mode-map "Q" 'gnus-group-quit)
3152 (define-key gnus-group-mode-map "?" 'gnus-group-describe-briefly)
ef97d5a2 3153 (define-key gnus-group-mode-map "\C-c\C-i" 'gnus-info-find-node)
41487370
LMI
3154 (define-key gnus-group-mode-map "\M-e" 'gnus-group-edit-group-method)
3155 (define-key gnus-group-mode-map "^" 'gnus-group-enter-server-mode)
3156 (define-key gnus-group-mode-map gnus-mouse-2 'gnus-mouse-pick-group)
3157 (define-key gnus-group-mode-map "<" 'beginning-of-buffer)
3158 (define-key gnus-group-mode-map ">" 'end-of-buffer)
3159 (define-key gnus-group-mode-map "\C-c\C-b" 'gnus-bug)
3160 (define-key gnus-group-mode-map "\C-c\C-s" 'gnus-group-sort-groups)
3161
3162 (define-key gnus-group-mode-map "#" 'gnus-group-mark-group)
3163 (define-key gnus-group-mode-map "\M-#" 'gnus-group-unmark-group)
3164 (define-prefix-command 'gnus-group-mark-map)
3165 (define-key gnus-group-mode-map "M" 'gnus-group-mark-map)
3166 (define-key gnus-group-mark-map "m" 'gnus-group-mark-group)
3167 (define-key gnus-group-mark-map "u" 'gnus-group-unmark-group)
3168 (define-key gnus-group-mark-map "w" 'gnus-group-mark-region)
3169
3170 (define-prefix-command 'gnus-group-group-map)
3171 (define-key gnus-group-mode-map "G" 'gnus-group-group-map)
3172 (define-key gnus-group-group-map "d" 'gnus-group-make-directory-group)
3173 (define-key gnus-group-group-map "h" 'gnus-group-make-help-group)
3174 (define-key gnus-group-group-map "a" 'gnus-group-make-archive-group)
3175 (define-key gnus-group-group-map "k" 'gnus-group-make-kiboze-group)
3176 (define-key gnus-group-group-map "m" 'gnus-group-make-group)
3177 (define-key gnus-group-group-map "E" 'gnus-group-edit-group)
3178 (define-key gnus-group-group-map "e" 'gnus-group-edit-group-method)
3179 (define-key gnus-group-group-map "p" 'gnus-group-edit-group-parameters)
3180 (define-key gnus-group-group-map "v" 'gnus-group-add-to-virtual)
3181 (define-key gnus-group-group-map "V" 'gnus-group-make-empty-virtual)
3182 (define-key gnus-group-group-map "D" 'gnus-group-enter-directory)
3183 (define-key gnus-group-group-map "f" 'gnus-group-make-doc-group)
3184 ;;(define-key gnus-group-group-map "sb" 'gnus-group-brew-soup)
3185 ;;(define-key gnus-group-group-map "sw" 'gnus-soup-save-areas)
3186 ;;(define-key gnus-group-group-map "ss" 'gnus-soup-send-replies)
3187 ;;(define-key gnus-group-group-map "sp" 'gnus-soup-pack-packet)
3188 ;;(define-key gnus-group-group-map "sr" 'nnsoup-pack-replies)
3189
3190 (define-prefix-command 'gnus-group-list-map)
3191 (define-key gnus-group-mode-map "A" 'gnus-group-list-map)
3192 (define-key gnus-group-list-map "k" 'gnus-group-list-killed)
3193 (define-key gnus-group-list-map "z" 'gnus-group-list-zombies)
3194 (define-key gnus-group-list-map "s" 'gnus-group-list-groups)
3195 (define-key gnus-group-list-map "u" 'gnus-group-list-all-groups)
3196 (define-key gnus-group-list-map "a" 'gnus-group-apropos)
3197 (define-key gnus-group-list-map "d" 'gnus-group-description-apropos)
3198 (define-key gnus-group-list-map "m" 'gnus-group-list-matching)
3199 (define-key gnus-group-list-map "M" 'gnus-group-list-all-matching)
3200
7e988fb6
LMI
3201 (define-prefix-command 'gnus-group-help-map)
3202 (define-key gnus-group-mode-map "H" 'gnus-group-help-map)
3203 (define-key gnus-group-help-map "f" 'gnus-group-fetch-faq)
3204
41487370
LMI
3205 (define-prefix-command 'gnus-group-sub-map)
3206 (define-key gnus-group-mode-map "S" 'gnus-group-sub-map)
3207 (define-key gnus-group-sub-map "l" 'gnus-group-set-current-level)
3208 (define-key gnus-group-sub-map "t" 'gnus-group-unsubscribe-current-group)
3209 (define-key gnus-group-sub-map "s" 'gnus-group-unsubscribe-group)
3210 (define-key gnus-group-sub-map "k" 'gnus-group-kill-group)
3211 (define-key gnus-group-sub-map "y" 'gnus-group-yank-group)
3212 (define-key gnus-group-sub-map "w" 'gnus-group-kill-region)
3213 (define-key gnus-group-sub-map "z" 'gnus-group-kill-all-zombies))
b027f415
RS
3214
3215(defun gnus-group-mode ()
41487370
LMI
3216 "Major mode for reading news.
3217
3218All normal editing commands are switched off.
3219\\<gnus-group-mode-map>
3220The group buffer lists (some of) the groups available. For instance,
3221`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]'
3222lists all zombie groups.
3223
3224Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe
3225to a group not displayed, type `\\[gnus-group-unsubscribe-group]'.
3226
3227For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]').
3228
3229The following commands are available:
3230
3231\\{gnus-group-mode-map}"
745bc783 3232 (interactive)
41487370 3233 (if gnus-visual (gnus-group-make-menu-bar))
745bc783 3234 (kill-all-local-variables)
a828a776 3235 (gnus-simplify-mode-line)
b027f415 3236 (setq major-mode 'gnus-group-mode)
41487370
LMI
3237 (setq mode-name "Group")
3238 (gnus-group-set-mode-line)
745bc783 3239 (setq mode-line-process nil)
b027f415 3240 (use-local-map gnus-group-mode-map)
41487370
LMI
3241 (buffer-disable-undo (current-buffer))
3242 (setq truncate-lines t)
3243 (setq buffer-read-only t)
b027f415 3244 (run-hooks 'gnus-group-mode-hook))
745bc783 3245
7f410bb7
RS
3246(defun gnus-mouse-pick-group (e)
3247 (interactive "e")
3248 (mouse-set-point e)
3249 (gnus-group-read-group nil))
3250
41487370
LMI
3251;; Look at LEVEL and find out what the level is really supposed to be.
3252;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens
3253;; will depend on whether `gnus-group-use-permanent-levels' is used.
3254(defun gnus-group-default-level (&optional level number-or-nil)
3255 (cond
3256 (gnus-group-use-permanent-levels
3257 (setq gnus-group-default-list-level
3258 (or level gnus-group-default-list-level))
3259 (or gnus-group-default-list-level gnus-level-subscribed))
3260 (number-or-nil
3261 level)
3262 (t
3263 (or level gnus-group-default-list-level gnus-level-subscribed))))
3264
3265
3266(defvar gnus-tmp-prev-perm nil)
3267
3268;;;###autoload
3269(defun gnus-no-server (&optional arg)
3270 "Read network news.
3271If ARG is a positive number, Gnus will use that as the
3272startup level. If ARG is nil, Gnus will be started at level 2.
3273If ARG is non-nil and not a positive number, Gnus will
3274prompt the user for the name of an NNTP server to use.
3275As opposed to `gnus', this command will not connect to the local server."
3276 (interactive "P")
3277 (let ((perm
3278 (cons gnus-group-use-permanent-levels gnus-group-default-list-level)))
3279 (setq gnus-tmp-prev-perm nil)
3280 (setq gnus-group-use-permanent-levels t)
3281 (gnus (or arg (1- gnus-level-default-subscribed)) t)
3282 (setq gnus-tmp-prev-perm perm)))
3283
745bc783 3284;;;###autoload
41487370 3285(defun gnus (&optional arg dont-connect)
745bc783 3286 "Read network news.
41487370
LMI
3287If ARG is non-nil and a positive number, Gnus will use that as the
3288startup level. If ARG is non-nil and not a positive number, Gnus will
3289prompt the user for the name of an NNTP server to use."
745bc783 3290 (interactive "P")
41487370 3291 (if (get-buffer gnus-group-buffer)
745bc783 3292 (progn
41487370
LMI
3293 (switch-to-buffer gnus-group-buffer)
3294 (gnus-group-get-new-news))
3295
3296 (gnus-clear-system)
3297
3298 (nnheader-init-server-buffer)
3299 ;; We do this if `gnus-no-server' has been run.
3300 (if gnus-tmp-prev-perm
3301 (setq gnus-group-use-permanent-levels (car gnus-tmp-prev-perm)
3302 gnus-group-default-list-level (cdr gnus-tmp-prev-perm)
3303 gnus-tmp-prev-perm nil))
3304 (gnus-read-init-file)
3305
3306 (gnus-group-setup-buffer)
3307 (let ((buffer-read-only nil))
3308 (erase-buffer)
3309 (if (not gnus-inhibit-startup-message)
3310 (progn
3311 (gnus-group-startup-message)
3312 (sit-for 0))))
3313
3314 (let ((level (and arg (numberp arg) (> arg 0) arg))
3315 did-connect)
3316 (unwind-protect
3317 (progn
3318 (or dont-connect
3319 (setq did-connect
3320 (gnus-start-news-server (and arg (not level))))))
3321 (if (and (not dont-connect)
3322 (not did-connect))
3323 (gnus-group-quit)
3324 (run-hooks 'gnus-startup-hook)
3325 ;; NNTP server is successfully open.
3326
3327 ;; Find the current startup file name.
3328 (setq gnus-current-startup-file
3329 (gnus-make-newsrc-file gnus-startup-file))
3330
3331 ;; Read the dribble file.
3332 (and gnus-use-dribble-file (gnus-dribble-read-file))
3333
3334 (gnus-summary-make-display-table)
3335 (gnus-setup-news nil level)
3336 (gnus-group-list-groups level)
3337 (gnus-configure-windows 'group))))))
3338
3339(defun gnus-unload ()
3340 "Unload all Gnus features."
3341 (interactive)
3342 (or (boundp 'load-history)
3343 (error "Sorry, `gnus-unload' is not implemented in this Emacs version."))
3344 (let ((history load-history)
3345 feature)
3346 (while history
3347 (and (string-match "^gnus" (car (car history)))
3348 (setq feature (cdr (assq 'provide (car history))))
3349 (unload-feature feature 'force))
3350 (setq history (cdr history)))))
3351
3352(defun gnus-group-startup-message (&optional x y)
745bc783
JB
3353 "Insert startup message in current buffer."
3354 ;; Insert the message.
41487370 3355 (erase-buffer)
44cdca98
RS
3356 (insert
3357 (format "
41487370
LMI
3358 _ ___ _ _
3359 _ ___ __ ___ __ _ ___
3360 __ _ ___ __ ___
3361 _ ___ _
3362 _ _ __ _
3363 ___ __ _
3364 __ _
3365 _ _ _
3366 _ _ _
3367 _ _ _
3368 __ ___
3369 _ _ _ _
3370 _ _
3371 _ _
3372 _ _
3373 _
3374 __
3375
3376
3377 Gnus * A newsreader for Emacsen
3378 A Praxis release * larsi@ifi.uio.no
3379"
3380 gnus-version))
3381 ;; And then hack it.
3382 ;; 18 is the longest line.
3383 (indent-rigidly (point-min) (point-max)
3384 (/ (max (- (window-width) (or x 46)) 0) 2))
3385 (goto-char (point-min))
3386 (let* ((pheight (count-lines (point-min) (point-max)))
3387 (wheight (window-height))
3388 (rest (- wheight pheight)))
3389 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
3390
3391
745bc783 3392
41487370
LMI
3393 ;; Fontify some.
3394 (goto-char (point-min))
3395 (search-forward "Praxis")
3396 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
3397 (goto-char (point-min)))
745bc783 3398
41487370
LMI
3399(defun gnus-group-startup-message-old (&optional x y)
3400 "Insert startup message in current buffer."
3401 ;; Insert the message.
3402 (erase-buffer)
3403 (insert
3404 (format "
3405 %s
3406 A newsreader
3407 for GNU Emacs
3408
3409 Based on GNUS
3410 written by
3411 Masanobu UMEDA
3412
3413 A Praxis Release
3414 larsi@ifi.uio.no
3415"
3416 gnus-version))
745bc783 3417 ;; And then hack it.
41487370
LMI
3418 ;; 18 is the longest line.
3419 (indent-rigidly (point-min) (point-max)
3420 (/ (max (- (window-width) (or x 28)) 0) 2))
745bc783
JB
3421 (goto-char (point-min))
3422 ;; +4 is fuzzy factor.
41487370 3423 (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2))
745bc783 3424
41487370
LMI
3425 ;; Fontify some.
3426 (goto-char (point-min))
3427 (search-forward "Praxis")
3428 (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
3429 (goto-char (point-min)))
3430
3431(defun gnus-group-setup-buffer ()
3432 (or (get-buffer gnus-group-buffer)
3433 (progn
3434 (switch-to-buffer gnus-group-buffer)
3435 (gnus-add-current-to-buffer-list)
3436 (gnus-group-mode)
3437 (and gnus-carpal (gnus-carpal-setup-buffer 'group)))))
3438
3439(defun gnus-group-list-groups (&optional level unread)
3440 "List newsgroups with level LEVEL or lower that have unread articles.
3441Default is all subscribed groups.
3442If argument UNREAD is non-nil, groups with no unread articles are also
3443listed."
3444 (interactive (list (if current-prefix-arg
3445 (prefix-numeric-value current-prefix-arg)
3446 (or
3447 (gnus-group-default-level nil t)
3448 gnus-group-default-list-level
3449 gnus-level-subscribed))))
3450 (or level
3451 (setq level (car gnus-group-list-mode)
3452 unread (cdr gnus-group-list-mode)))
3453 (setq level (gnus-group-default-level level))
3454 (gnus-group-setup-buffer) ;May call from out of group buffer
b027f415 3455 (let ((case-fold-search nil)
41487370
LMI
3456 (group (gnus-group-group-name)))
3457 (funcall gnus-group-prepare-function level unread nil)
745bc783 3458 (if (zerop (buffer-size))
41487370 3459 (gnus-message 5 gnus-no-groups-message)
745bc783 3460 (goto-char (point-min))
41487370
LMI
3461 (if (not group)
3462 ;; Go to the first group with unread articles.
3463 (gnus-group-search-forward nil nil nil t)
3464 ;; Find the right group to put point on. If the current group
b94ae5f7 3465 ;; has disappeared in the new listing, try to find the next
41487370
LMI
3466 ;; one. If no next one can be found, just leave point at the
3467 ;; first newsgroup in the buffer.
3468 (if (not (gnus-goto-char
3469 (text-property-any (point-min) (point-max)
3470 'gnus-group (intern group))))
3471 (let ((newsrc (nthcdr 3 (gnus-gethash group gnus-newsrc-hashtb))))
3472 (while (and newsrc
3473 (not (gnus-goto-char
3474 (text-property-any
3475 (point-min) (point-max) 'gnus-group
3476 (intern (car (car newsrc)))))))
3477 (setq newsrc (cdr newsrc)))
3478 (or newsrc (progn (goto-char (point-max))
3479 (forward-line -1))))))
745bc783 3480 ;; Adjust cursor point.
41487370
LMI
3481 (gnus-group-position-cursor))))
3482
3483(defun gnus-group-prepare-flat (level &optional all lowest regexp)
3484 "List all newsgroups with unread articles of level LEVEL or lower.
3485If ALL is non-nil, list groups that have no unread articles.
3486If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
3487If REGEXP, only list groups matching REGEXP."
3488 (set-buffer gnus-group-buffer)
745bc783 3489 (let ((buffer-read-only nil)
41487370
LMI
3490 (newsrc (cdr gnus-newsrc-alist))
3491 (lowest (or lowest 1))
3492 info clevel unread group)
745bc783 3493 (erase-buffer)
41487370
LMI
3494 (if (< lowest gnus-level-zombie)
3495 ;; List living groups.
3496 (while newsrc
3497 (setq info (car newsrc)
3498 group (car info)
3499 newsrc (cdr newsrc)
3500 unread (car (gnus-gethash group gnus-newsrc-hashtb)))
3501 (and unread ; This group might be bogus
3502 (or (not regexp)
3503 (string-match regexp group))
3504 (<= (setq clevel (car (cdr info))) level)
3505 (>= clevel lowest)
3506 (or all ; We list all groups?
3507 (eq unread t) ; We list unactivated groups
3508 (> unread 0) ; We list groups with unread articles
b94ae5f7 3509 (cdr (assq 'tick (nth 3 info)))) ; And ticked groups
41487370
LMI
3510 (gnus-group-insert-group-line
3511 nil group (car (cdr info)) (nth 3 info) unread (nth 4 info)))))
3512
3513 ;; List dead groups.
3514 (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
3515 (gnus-group-prepare-flat-list-dead
3516 (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
3517 gnus-level-zombie ?Z
3518 regexp))
3519 (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
3520 (gnus-group-prepare-flat-list-dead
3521 (setq gnus-killed-list (sort gnus-killed-list 'string<))
3522 gnus-level-killed ?K regexp))
3523
3524 (gnus-group-set-mode-line)
3525 (setq gnus-group-list-mode (cons level all))
3526 (run-hooks 'gnus-group-prepare-hook)))
3527
3528(defun gnus-group-prepare-flat-list-dead (groups level mark regexp)
b94ae5f7 3529 ;; List zombies and killed lists somewhat faster, which was
41487370
LMI
3530 ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does
3531 ;; this by ignoring the group format specification altogether.
3532 (let (group beg)
3533 (while groups
3534 (setq group (car groups)
3535 groups (cdr groups))
3536 (if (or (not regexp)
3537 (string-match regexp group))
3538 (progn
3539 (setq beg (point))
3540 (insert (format " %c *: %s\n" mark group))
3541 (add-text-properties
3542 beg (1+ beg)
3543 (list 'gnus-group (intern group)
3544 'gnus-unread t
3545 'gnus-level level)))))))
3546
3547(defun gnus-group-real-name (group)
3548 "Find the real name of a foreign newsgroup."
3549 (if (string-match ":[^:]+$" group)
3550 (substring group (1+ (match-beginning 0)))
3551 group))
3552
3553(defun gnus-group-prefixed-name (group method)
3554 "Return the whole name from GROUP and METHOD."
3555 (and (stringp method) (setq method (gnus-server-to-method method)))
3556 (concat (format "%s" (car method))
3557 (if (and
3558 (assoc (format "%s" (car method)) (gnus-methods-using 'address))
3559 (not (string= (nth 1 method) "")))
3560 (concat "+" (nth 1 method)))
3561 ":" group))
3562
3563(defun gnus-group-real-prefix (group)
3564 "Return the prefix of the current group name."
3565 (if (string-match "^[^:]+:" group)
3566 (substring group 0 (match-end 0))
3567 ""))
3568
3569(defun gnus-group-method-name (group)
3570 "Return the method used for selecting GROUP."
3571 (let ((prefix (gnus-group-real-prefix group)))
3572 (if (equal prefix "")
3573 gnus-select-method
3574 (if (string-match "^[^\\+]+\\+" prefix)
3575 (list (intern (substring prefix 0 (1- (match-end 0))))
3576 (substring prefix (match-end 0) (1- (length prefix))))
3577 (list (intern (substring prefix 0 (1- (length prefix)))) "")))))
3578
3579(defun gnus-group-foreign-p (group)
3580 "Return nil if GROUP is native, non-nil if it is foreign."
3581 (string-match ":" group))
3582
3583(defun gnus-group-set-info (info &optional method-only-group part)
3584 (let* ((entry (gnus-gethash
3585 (or method-only-group (car info)) gnus-newsrc-hashtb))
3586 (part-info info)
3587 (info (if method-only-group (nth 2 entry) info)))
3588 (if (not method-only-group)
3589 ()
3590 (or entry
3591 (error "Trying to change non-existent group %s" method-only-group))
b94ae5f7 3592 ;; We have received parts of the actual group info - either the
41487370
LMI
3593 ;; select method or the group parameters. We first check
3594 ;; whether we have to extend the info, and if so, do that.
3595 (let ((len (length info))
3596 (total (if (eq part 'method) 5 6)))
3597 (and (< len total)
3598 (setcdr (nthcdr (1- len) info)
3599 (make-list (- total len) nil)))
3600 ;; Then we enter the new info.
3601 (setcar (nthcdr (1- total) info) part-info)))
3602 ;; We uncompress some lists of marked articles.
3603 (let (marked)
3604 (if (not (setq marked (nth 3 info)))
3605 ()
3606 (while marked
3607 (or (eq 'score (car (car marked)))
3608 (eq 'bookmark (car (car marked)))
3609 (eq 'killed (car (car marked)))
3610 (setcdr (car marked)
3611 (gnus-uncompress-range (cdr (car marked)))))
3612 (setq marked (cdr marked)))))
3613 (if entry
3614 ()
3615 ;; This is a new group, so we just create it.
3616 (save-excursion
3617 (set-buffer gnus-group-buffer)
3618 (if (nth 4 info)
3619 ;; It's a foreign group...
3620 (gnus-group-make-group
3621 (gnus-group-real-name (car info))
3622 (prin1-to-string (car (nth 4 info)))
3623 (nth 1 (nth 4 info)))
3624 ;; It's a native group.
3625 (gnus-group-make-group (car info)))
3626 (gnus-message 6 "Note: New group created")
3627 (setq entry
3628 (gnus-gethash (gnus-group-prefixed-name
3629 (gnus-group-real-name (car info))
3630 (or (nth 4 info) gnus-select-method))
3631 gnus-newsrc-hashtb))))
3632 ;; Whether it was a new group or not, we now have the entry, so we
3633 ;; can do the update.
3634 (if entry
3635 (progn
3636 (setcar (nthcdr 2 entry) info)
3637 (if (and (not (eq (car entry) t))
3638 (gnus-gethash (car info) gnus-active-hashtb))
3639 (let ((marked (nth 3 info)))
3640 (setcar entry
3641 (max 0 (- (length (gnus-list-of-unread-articles
3642 (car info)))
3643 (length (cdr (assq 'tick marked)))
3644 (length (cdr (assq 'dormant marked)))))))))
3645 (error "No such group: %s" (car info)))))
3646
3647(defun gnus-group-set-method-info (group select-method)
3648 (gnus-group-set-info select-method group 'method))
3649
3650(defun gnus-group-set-params-info (group params)
3651 (gnus-group-set-info params group 'params))
3652
3653(defun gnus-group-update-group-line ()
3654 "This function updates the current line in the newsgroup buffer and
3655moves the point to the colon."
3656 (let* ((buffer-read-only nil)
3657 (group (gnus-group-group-name))
3658 (entry (and group (gnus-gethash group gnus-newsrc-hashtb))))
3659 (if (and entry (not (gnus-ephemeral-group-p group)))
3660 (gnus-dribble-enter
3661 (concat "(gnus-group-set-info '" (prin1-to-string (nth 2 entry))
3662 ")")))
3663 (beginning-of-line)
3664 (delete-region (point) (progn (forward-line 1) (point)))
3665 (gnus-group-insert-group-line-info group)
3666 (forward-line -1)
3667 (gnus-group-position-cursor)))
3668
3669(defun gnus-group-insert-group-line-info (group)
3670 (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
3671 active info)
3672 (if entry
de032aaa 3673 (progn
41487370
LMI
3674 (setq info (nth 2 entry))
3675 (gnus-group-insert-group-line
3676 nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
3677 (setq active (gnus-gethash group gnus-active-hashtb))
3678 (gnus-group-insert-group-line
3679 nil group
3680 (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed)
3681 nil (if active (- (1+ (cdr active)) (car active)) 0) nil))))
3682
3683(defun gnus-group-insert-group-line (gformat group level marked number method)
3684 (let* ((gformat (or gformat gnus-group-line-format-spec))
3685 (active (gnus-gethash group gnus-active-hashtb))
3686 (number-total (if active (1+ (- (cdr active) (car active))) 0))
3687 (number-of-dormant (length (cdr (assq 'dormant marked))))
3688 (number-of-ticked (length (cdr (assq 'tick marked))))
3689 (number-of-ticked-and-dormant
3690 (+ number-of-ticked number-of-dormant))
3691 (number-of-unread-unticked
3692 (if (numberp number) (int-to-string (max 0 number))
3693 "*"))
3694 (number-of-read
3695 (if (numberp number)
3696 (max 0 (- number-total number))
3697 "*"))
3698 (subscribed (cond ((<= level gnus-level-subscribed) ? )
3699 ((<= level gnus-level-unsubscribed) ?U)
3700 ((= level gnus-level-zombie) ?Z)
3701 (t ?K)))
3702 (qualified-group (gnus-group-real-name group))
3703 (newsgroup-description
3704 (if gnus-description-hashtb
3705 (or (gnus-gethash group gnus-description-hashtb) "")
3706 ""))
3707 (moderated (if (member group gnus-moderated-list) ?m ? ))
3708 (moderated-string (if (eq moderated ?m) "(m)" ""))
3709 (method (gnus-server-get-method group method))
3710 (news-server (or (car (cdr method)) ""))
3711 (news-method (or (car method) ""))
3712 (news-method-string
3713 (if method (format "(%s:%s)" (car method) (car (cdr method))) ""))
3714 (marked (if (and
3715 (numberp number)
3716 (zerop number)
3717 (> number-of-ticked 0))
3718 ?* ? ))
3719 (number (if (eq number t) "*" (+ number number-of-dormant
3720 number-of-ticked)))
3721 (process-marked (if (member group gnus-group-marked)
3722 gnus-process-mark ? ))
3723 (buffer-read-only nil)
3724 header ; passed as parameter to user-funcs.
3725 b)
3726 (beginning-of-line)
3727 (setq b (point))
3728 ;; Insert the text.
3729 (insert (eval gformat))
3730
3731 (add-text-properties
3732 b (1+ b) (list 'gnus-group (intern group)
3733 'gnus-unread (if (numberp number)
3734 (string-to-int number-of-unread-unticked)
3735 t)
3736 'gnus-marked marked
3737 'gnus-level level))))
745bc783 3738
b027f415 3739(defun gnus-group-update-group (group &optional visible-only)
745bc783 3740 "Update newsgroup info of GROUP.
41487370
LMI
3741If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't already."
3742 (save-excursion
3743 (set-buffer gnus-group-buffer)
3744 (let ((buffer-read-only nil)
3745 visible)
3746 (let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
3747 (if (and entry
3748 (not (gnus-ephemeral-group-p group)))
3749 (gnus-dribble-enter
3750 (concat "(gnus-group-set-info '" (prin1-to-string (nth 2 entry))
3751 ")"))))
3752 ;; Buffer may be narrowed.
3753 (save-restriction
3754 (widen)
3755 ;; Search a line to modify. If the buffer is large, the search
3756 ;; takes long time. In most cases, current point is on the line
3757 ;; we are looking for. So, first of all, check current line.
3758 (if (or (progn
3759 (beginning-of-line)
3760 (eq (get-text-property (point) 'gnus-group)
3761 (intern group)))
3762 (progn
3763 (gnus-goto-char
3764 (text-property-any
3765 (point-min) (point-max) 'gnus-group (intern group)))))
3766 ;; GROUP is listed in current buffer. So, delete old line.
3767 (progn
3768 (setq visible t)
3769 (beginning-of-line)
3770 (delete-region (point) (progn (forward-line 1) (point))))
3771 ;; No such line in the buffer, find out where it's supposed to
3772 ;; go, and insert it there (or at the end of the buffer).
3773 ;; Fix by Per Abrahamsen <amanda@iesd.auc.dk>.
3774 (or visible-only
3775 (let ((entry
3776 (cdr (cdr (gnus-gethash group gnus-newsrc-hashtb)))))
3777 (while (and entry
3778 (car entry)
3779 (not
3780 (gnus-goto-char
3781 (text-property-any
3782 (point-min) (point-max)
3783 'gnus-group (intern (car (car entry)))))))
3784 (setq entry (cdr entry)))
3785 (or entry (goto-char (point-max)))))))
745bc783 3786 (if (or visible (not visible-only))
41487370
LMI
3787 (gnus-group-insert-group-line-info group))
3788 (gnus-group-set-mode-line))))
3789
3790(defun gnus-group-set-mode-line ()
3791 (if (memq 'group gnus-updated-mode-lines)
3792 (let* ((gformat (or gnus-group-mode-line-format-spec
3793 (setq gnus-group-mode-line-format-spec
3794 (gnus-parse-format
3795 gnus-group-mode-line-format
3796 gnus-group-mode-line-format-alist))))
3797 (news-server (car (cdr gnus-select-method)))
3798 (news-method (car gnus-select-method))
3799 (max-len 60)
8bb6fec9 3800 header ;Dummy binding for user-defined specs.
41487370
LMI
3801 (mode-string (eval gformat)))
3802 (setq mode-string (eval gformat))
3803 (if (> (length mode-string) max-len)
3804 (setq mode-string (substring mode-string 0 (- max-len 4))))
3805 (setq mode-line-buffer-identification mode-string)
3806 (set-buffer-modified-p t))))
745bc783 3807
b027f415 3808(defun gnus-group-group-name ()
41487370
LMI
3809 "Get the name of the newsgroup on the current line."
3810 (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group)))
3811 (and group (symbol-name group))))
3812
3813(defun gnus-group-group-level ()
3814 "Get the level of the newsgroup on the current line."
3815 (get-text-property (gnus-point-at-bol) 'gnus-level))
3816
3817(defun gnus-group-group-unread ()
3818 "Get the number of unread articles of the newsgroup on the current line."
3819 (get-text-property (gnus-point-at-bol) 'gnus-unread))
3820
3821(defun gnus-group-search-forward (&optional backward all level first-too)
3822 "Find the next newsgroup with unread articles.
3823If BACKWARD is non-nil, find the previous newsgroup instead.
3824If ALL is non-nil, just find any newsgroup.
3825If LEVEL is non-nil, find group with level LEVEL, or higher if no such
3826group exists.
3827If FIRST-TOO, the current line is also eligible as a target."
3828 (let ((way (if backward -1 1))
3829 (low gnus-level-killed)
3830 (beg (point))
3831 pos found lev)
3832 (if (and backward (progn (beginning-of-line)) (bobp))
3833 nil
3834 (or first-too (forward-line way))
3835 (while (and
3836 (not (eobp))
3837 (not (setq
3838 found
3839 (and (or all
3840 (and
3841 (let ((unread
3842 (get-text-property (point) 'gnus-unread)))
3843 (or (eq unread t) (and unread (> unread 0))))
3844 (setq lev (get-text-property (point)
3845 'gnus-level))
3846 (<= lev gnus-level-subscribed)))
3847 (or (not level)
3848 (and (setq lev (get-text-property (point)
3849 'gnus-level))
3850 (or (= lev level)
3851 (and (< lev low)
3852 (< level lev)
3853 (progn
3854 (setq low lev)
3855 (setq pos (point))
3856 nil))))))))
3857 (zerop (forward-line way)))))
3858 (if found
3859 (progn (gnus-group-position-cursor) t)
3860 (goto-char (or pos beg))
3861 (and pos t))))
3862
3863;;; Gnus group mode commands
3864
3865;; Group marking.
3866
3867(defun gnus-group-mark-group (n &optional unmark no-advance)
3868 "Mark the current group."
3869 (interactive "p")
3870 (let ((buffer-read-only nil)
3871 group)
3872 (while
3873 (and (> n 0)
3874 (setq group (gnus-group-group-name))
3875 (progn
3876 (beginning-of-line)
3877 (forward-char
3878 (or (cdr (assq 'process gnus-group-mark-positions)) 2))
3879 (delete-char 1)
3880 (if unmark
3881 (progn
3882 (insert " ")
3883 (setq gnus-group-marked (delete group gnus-group-marked)))
3884 (insert "#")
3885 (setq gnus-group-marked
3886 (cons group (delete group gnus-group-marked))))
3887 t)
3888 (or no-advance (zerop (gnus-group-next-group 1))))
3889 (setq n (1- n)))
3890 (gnus-summary-position-cursor)
3891 n))
3892
3893(defun gnus-group-unmark-group (n)
3894 "Remove the mark from the current group."
3895 (interactive "p")
3896 (gnus-group-mark-group n 'unmark))
b027f415 3897
41487370
LMI
3898(defun gnus-group-mark-region (unmark beg end)
3899 "Mark all groups between point and mark.
3900If UNMARK, remove the mark instead."
3901 (interactive "P\nr")
3902 (let ((num (count-lines beg end)))
3903 (save-excursion
3904 (goto-char beg)
3905 (- num (gnus-group-mark-group num unmark)))))
b027f415 3906
41487370
LMI
3907(defun gnus-group-remove-mark (group)
3908 (and (gnus-group-goto-group group)
3909 (save-excursion
3910 (gnus-group-mark-group 1 'unmark t))))
3911
3912;; Return a list of groups to work on. Take into consideration N (the
3913;; prefix) and the list of marked groups.
3914(defun gnus-group-process-prefix (n)
3915 (cond (n
3916 (setq n (prefix-numeric-value n))
3917 ;; There is a prefix, so we return a list of the N next
3918 ;; groups.
3919 (let ((way (if (< n 0) -1 1))
3920 (n (abs n))
3921 group groups)
3922 (save-excursion
3923 (while (and (> n 0)
3924 (setq group (gnus-group-group-name)))
3925 (setq groups (cons group groups))
3926 (setq n (1- n))
3927 (forward-line way)))
3928 (nreverse groups)))
3929 (gnus-group-marked
3930 ;; No prefix, but a list of marked articles.
3931 (reverse gnus-group-marked))
3932 (t
3933 ;; Neither marked articles or a prefix, so we return the
3934 ;; current group.
3935 (let ((group (gnus-group-group-name)))
3936 (and group (list group))))))
3937
3938;; Selecting groups.
3939
3940(defun gnus-group-read-group (&optional all no-article group)
3941 "Read news in this newsgroup.
3942If the prefix argument ALL is non-nil, already read articles become
3943readable. If the optional argument NO-ARTICLE is non-nil, no article
3944will be auto-selected upon group entry."
3945 (interactive "P")
3946 (let ((group (or group (gnus-group-group-name)))
3947 number active marked entry)
3948 (or group (error "No group on current line"))
3949 (setq marked
3950 (nth 3 (nth 2 (setq entry (gnus-gethash group gnus-newsrc-hashtb)))))
3951 ;; This group might be a dead group. In that case we have to get
3952 ;; the number of unread articles from `gnus-active-hashtb'.
3953 (if entry
3954 (setq number (car entry))
3955 (if (setq active (gnus-gethash group gnus-active-hashtb))
3956 (setq number (- (1+ (cdr active)) (car active)))))
3957 (gnus-summary-read-group
3958 group (or all (and (numberp number)
3959 (zerop (+ number (length (cdr (assq 'tick marked)))
3960 (length (cdr (assq 'dormant marked)))))))
3961 no-article)))
3962
3963(defun gnus-group-select-group (&optional all)
3964 "Select this newsgroup.
745bc783
JB
3965No article is selected automatically.
3966If argument ALL is non-nil, already read articles become readable."
3967 (interactive "P")
b027f415 3968 (gnus-group-read-group all t))
745bc783 3969
41487370
LMI
3970(defun gnus-group-select-group-all ()
3971 "Select the current group and display all articles in it."
3972 (interactive)
3973 (gnus-group-select-group 'all))
3974
3975;; Enter a group that is not in the group buffer. Non-nil is returned
3976;; if selection was successful.
3977(defun gnus-group-read-ephemeral-group
3978 (group method &optional activate quit-config)
3979 (let ((group (if (gnus-group-foreign-p group) group
3980 (gnus-group-prefixed-name group method))))
3981 (gnus-sethash
3982 group
3983 (list t nil (list group gnus-level-default-subscribed nil nil
3984 (append method
3985 (list
3986 (list 'quit-config
3987 (if quit-config quit-config
3988 (cons (current-buffer) 'summary)))))))
3989 gnus-newsrc-hashtb)
3990 (set-buffer gnus-group-buffer)
3991 (or (gnus-check-server method)
3992 (error "Unable to contact server: %s" (gnus-status-message method)))
3993 (if activate (or (gnus-request-group group)
3994 (error "Couldn't request group")))
3995 (condition-case ()
3996 (gnus-group-read-group t t group)
3997 (error nil)
3998 (quit nil))
3999 (not (equal major-mode 'gnus-group-mode))))
4000
b027f415 4001(defun gnus-group-jump-to-group (group)
745bc783 4002 "Jump to newsgroup GROUP."
41487370
LMI
4003 (interactive
4004 (list (completing-read
4005 "Group: " gnus-active-hashtb nil
4006 (memq gnus-select-method gnus-have-read-active-file))))
4007
4008 (if (equal group "")
4009 (error "Empty group name"))
4010
4011 (let ((b (text-property-any
4012 (point-min) (point-max) 'gnus-group (intern group))))
4013 (if b
4014 ;; Either go to the line in the group buffer...
4015 (goto-char b)
4016 ;; ... or insert the line.
4017 (or
4018 (gnus-gethash group gnus-active-hashtb)
4019 (gnus-activate-group group)
4020 (error "%s error: %s" group (gnus-status-message group)))
4021
4022 (gnus-group-update-group group)
4023 (goto-char (text-property-any
4024 (point-min) (point-max) 'gnus-group (intern group)))))
4025 ;; Adjust cursor point.
4026 (gnus-group-position-cursor))
4027
4028(defun gnus-group-goto-group (group)
4029 "Goto to newsgroup GROUP."
4030 (let ((b (text-property-any (point-min) (point-max)
4031 'gnus-group (intern group))))
4032 (and b (goto-char b))))
745bc783 4033
b027f415 4034(defun gnus-group-next-group (n)
41487370
LMI
4035 "Go to next N'th newsgroup.
4036If N is negative, search backward instead.
4037Returns the difference between N and the number of skips actually
4038done."
745bc783 4039 (interactive "p")
41487370
LMI
4040 (gnus-group-next-unread-group n t))
4041
4042(defun gnus-group-next-unread-group (n &optional all level)
4043 "Go to next N'th unread newsgroup.
4044If N is negative, search backward instead.
4045If ALL is non-nil, choose any newsgroup, unread or not.
4046If LEVEL is non-nil, choose the next group with level LEVEL, or, if no
4047such group can be found, the next group with a level higher than
4048LEVEL.
4049Returns the difference between N and the number of skips actually
4050made."
745bc783 4051 (interactive "p")
41487370
LMI
4052 (let ((backward (< n 0))
4053 (n (abs n)))
4054 (while (and (> n 0)
4055 (gnus-group-search-forward
4056 backward (or (not gnus-group-goto-unread) all) level))
4057 (setq n (1- n)))
4058 (if (/= 0 n) (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread")
4059 (if level " on this level or higher" "")))
4060 n))
745bc783 4061
b027f415 4062(defun gnus-group-prev-group (n)
41487370
LMI
4063 "Go to previous N'th newsgroup.
4064Returns the difference between N and the number of skips actually
4065done."
745bc783 4066 (interactive "p")
41487370 4067 (gnus-group-next-unread-group (- n) t))
745bc783 4068
b027f415 4069(defun gnus-group-prev-unread-group (n)
41487370
LMI
4070 "Go to previous N'th unread newsgroup.
4071Returns the difference between N and the number of skips actually
4072done."
745bc783 4073 (interactive "p")
41487370 4074 (gnus-group-next-unread-group (- n)))
745bc783 4075
41487370
LMI
4076(defun gnus-group-next-unread-group-same-level (n)
4077 "Go to next N'th unread newsgroup on the same level.
4078If N is negative, search backward instead.
4079Returns the difference between N and the number of skips actually
4080done."
4081 (interactive "p")
4082 (gnus-group-next-unread-group n t (gnus-group-group-level))
4083 (gnus-group-position-cursor))
4084
4085(defun gnus-group-prev-unread-group-same-level (n)
4086 "Go to next N'th unread newsgroup on the same level.
4087Returns the difference between N and the number of skips actually
4088done."
4089 (interactive "p")
4090 (gnus-group-next-unread-group (- n) t (gnus-group-group-level))
4091 (gnus-group-position-cursor))
4092
4093(defun gnus-group-best-unread-group (&optional exclude-group)
4094 "Go to the group with the highest level.
4095If EXCLUDE-GROUP, do not go to that group."
4096 (interactive)
4097 (goto-char (point-min))
4098 (let ((best 100000)
4099 unread best-point)
4100 (while (setq unread (get-text-property (point) 'gnus-unread))
4101 (if (and (numberp unread) (> unread 0))
4102 (progn
4103 (if (and (< (get-text-property (point) 'gnus-level) best)
4104 (or (not exclude-group)
4105 (not (equal exclude-group (gnus-group-group-name)))))
4106 (progn
4107 (setq best (get-text-property (point) 'gnus-level))
4108 (setq best-point (point))))))
4109 (forward-line 1))
4110 (if best-point (goto-char best-point))
4111 (gnus-summary-position-cursor)
4112 (and best-point (gnus-group-group-name))))
4113
4114(defun gnus-group-first-unread-group ()
4115 "Go to the first group with unread articles."
4116 (interactive)
4117 (prog1
4118 (let ((opoint (point))
4119 unread)
4120 (goto-char (point-min))
4121 (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active.
4122 (not (zerop unread)) ; Has unread articles.
4123 (zerop (gnus-group-next-unread-group 1))) ; Next unread group.
4124 (point) ; Success.
4125 (goto-char opoint)
4126 nil)) ; Not success.
4127 (gnus-group-position-cursor)))
4128
4129(defun gnus-group-enter-server-mode ()
4130 "Jump to the server buffer."
745bc783 4131 (interactive)
41487370
LMI
4132 (gnus-server-setup-buffer)
4133 (gnus-configure-windows 'server)
4134 (gnus-server-prepare))
4135
4136(defun gnus-group-make-group (name &optional method address)
4137 "Add a new newsgroup.
4138The user will be prompted for a NAME, for a select METHOD, and an
4139ADDRESS."
4140 (interactive
4141 (cons
4142 (read-string "Group name: ")
4143 (let ((method
4144 (completing-read
4145 "Method: " (append gnus-valid-select-methods gnus-server-alist)
4146 nil t)))
4147 (if (assoc method gnus-valid-select-methods)
4148 (list method
4149 (if (memq 'prompt-address
4150 (assoc method gnus-valid-select-methods))
4151 (read-string "Address: ")
4152 ""))
4153 (list method nil)))))
4154
4155 (let* ((meth (and method (if address (list (intern method) address) method)))
4156 (nname (if method (gnus-group-prefixed-name name meth) name))
4157 info)
4158 (and (gnus-gethash nname gnus-newsrc-hashtb)
4159 (error "Group %s already exists" nname))
4160 (gnus-group-change-level
4161 (setq info (list t nname gnus-level-default-subscribed nil nil meth))
4162 gnus-level-default-subscribed gnus-level-killed
4163 (and (gnus-group-group-name)
4164 (gnus-gethash (gnus-group-group-name)
4165 gnus-newsrc-hashtb))
4166 t)
4167 (gnus-sethash nname (cons 1 0) gnus-active-hashtb)
4168 (or (gnus-ephemeral-group-p name)
4169 (gnus-dribble-enter
4170 (concat "(gnus-group-set-info '" (prin1-to-string (cdr info)) ")")))
4171 (gnus-group-insert-group-line-info nname)
4172
4173 (if (assoc method gnus-valid-select-methods)
4174 (require (intern method)))
4175 (and (gnus-check-backend-function 'request-create-group nname)
4176 (gnus-request-create-group nname))))
4177
4178(defun gnus-group-edit-group (group &optional part)
4179 "Edit the group on the current line."
4180 (interactive (list (gnus-group-group-name)))
4181 (let ((done-func '(lambda ()
4182 "Exit editing mode and update the information."
4183 (interactive)
4184 (gnus-group-edit-group-done 'part 'group)))
4185 (part (or part 'info))
4186 (winconf (current-window-configuration))
4187 info)
4188 (or group (error "No group on current line"))
4189 (or (setq info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
4190 (error "Killed group; can't be edited"))
4191 (set-buffer (get-buffer-create gnus-group-edit-buffer))
4192 (gnus-configure-windows 'edit-group)
4193 (gnus-add-current-to-buffer-list)
4194 (emacs-lisp-mode)
4195 ;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
4196 (use-local-map (copy-keymap emacs-lisp-mode-map))
4197 (local-set-key "\C-c\C-c" done-func)
4198 (make-local-variable 'gnus-prev-winconf)
4199 (setq gnus-prev-winconf winconf)
4200 ;; We modify the func to let it know what part it is editing.
4201 (setcar (cdr (nth 4 done-func)) (list 'quote part))
4202 (setcar (cdr (cdr (nth 4 done-func))) group)
4203 (erase-buffer)
4204 (insert
4205 (cond
4206 ((eq part 'method)
4207 ";; Type `C-c C-c' after editing the select method.\n\n")
4208 ((eq part 'params)
4209 ";; Type `C-c C-c' after editing the group parameters.\n\n")
4210 ((eq part 'info)
4211 ";; Type `C-c C-c' after editing the group info.\n\n")))
4212 (let ((cinfo (gnus-copy-sequence info))
4213 marked)
4214 (if (not (setq marked (nth 3 cinfo)))
4215 ()
4216 (while marked
4217 (or (eq 'score (car (car marked)))
4218 (eq 'bookmark (car (car marked)))
4219 (eq 'killed (car (car marked)))
4220 (not (numberp (car (cdr (car marked)))))
4221 (setcdr (car marked)
4222 (gnus-compress-sequence (sort (cdr (car marked)) '<) t)))
4223 (setq marked (cdr marked))))
4224 (insert
4225 (pp-to-string
4226 (cond ((eq part 'method)
4227 (or (nth 4 info) "native"))
4228 ((eq part 'params)
4229 (nth 5 info))
4230 (t
4231 cinfo)))
4232 "\n"))))
4233
4234(defun gnus-group-edit-group-method (group)
4235 "Edit the select method of GROUP."
4236 (interactive (list (gnus-group-group-name)))
4237 (gnus-group-edit-group group 'method))
4238
4239(defun gnus-group-edit-group-parameters (group)
4240 "Edit the group parameters of GROUP."
4241 (interactive (list (gnus-group-group-name)))
4242 (gnus-group-edit-group group 'params))
4243
4244(defun gnus-group-edit-group-done (part group)
4245 "Get info from buffer, update variables and jump to the group buffer."
4246 (set-buffer (get-buffer-create gnus-group-edit-buffer))
4247 (goto-char (point-min))
4248 (let ((form (read (current-buffer)))
4249 (winconf gnus-prev-winconf))
4250 (if (eq part 'info)
4251 (gnus-group-set-info form)
4252 (gnus-group-set-info form group part))
4253 (kill-buffer (current-buffer))
4254 (and winconf (set-window-configuration winconf))
4255 (set-buffer gnus-group-buffer)
4256 (gnus-group-update-group (gnus-group-group-name))
4257 (gnus-group-position-cursor)))
745bc783 4258
41487370
LMI
4259(defun gnus-group-make-help-group ()
4260 "Create the Gnus documentation group."
745bc783 4261 (interactive)
41487370
LMI
4262 (let ((path (cons (concat installation-directory "etc/") load-path))
4263 (name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
4264 file)
4265 (and (gnus-gethash name gnus-newsrc-hashtb)
4266 (error "Documentation group already exists"))
4267 (while (and path
4268 (not (file-exists-p
4269 (setq file (concat (file-name-as-directory (car path))
4270 "gnus-tut.txt")))))
4271 (setq path (cdr path)))
4272 (if (not path)
4273 (message "Couldn't find doc group")
4274 (gnus-group-make-group
4275 (gnus-group-real-name name)
4276 (list 'nndoc name
4277 (list 'nndoc-address file)
4278 (list 'nndoc-article-type 'mbox)))))
4279 (gnus-group-position-cursor))
4280
4281(defun gnus-group-make-doc-group (file type)
4282 "Create a group that uses a single file as the source."
4283 (interactive
4284 (list (read-file-name "File name: ")
4285 (let ((err "")
4286 found char)
4287 (while (not found)
4288 (message "%sFile type (mbox, babyl, digest) [mbd]: " err)
4289 (setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
4290 ((= char ?b) 'babyl)
4291 ((= char ?d) 'digest)
4292 (t (setq err (format "%c unknown. " char))
4293 nil))))
4294 found)))
4295 (let* ((file (expand-file-name file))
4296 (name (gnus-generate-new-group-name
4297 (gnus-group-prefixed-name
4298 (file-name-nondirectory file) '(nndoc "")))))
4299 (gnus-group-make-group
4300 (gnus-group-real-name name)
4301 (list 'nndoc name
4302 (list 'nndoc-address file)
4303 (list 'nndoc-article-type type)))))
4304
4305(defun gnus-group-make-archive-group (&optional all)
4306 "Create the (ding) Gnus archive group of the most recent articles.
4307Given a prefix, create a full group."
4308 (interactive "P")
4309 (let ((group (gnus-group-prefixed-name
4310 (if all "ding.archives" "ding.recent") '(nndir ""))))
4311 (and (gnus-gethash group gnus-newsrc-hashtb)
4312 (error "Archive group already exists"))
4313 (gnus-group-make-group
4314 (gnus-group-real-name group)
4315 "nndir"
4316 (if all gnus-group-archive-directory
4317 gnus-group-recent-archive-directory)))
4318 (gnus-group-position-cursor))
4319
4320(defun gnus-group-make-directory-group (dir)
4321 "Create an nndir group.
4322The user will be prompted for a directory. The contents of this
4323directory will be used as a newsgroup. The directory should contain
4324mail messages or news articles in files that have numeric names."
4325 (interactive
4326 (list (read-file-name "Create group from directory: ")))
4327 (or (file-exists-p dir) (error "No such directory"))
4328 (or (file-directory-p dir) (error "Not a directory"))
4329 (gnus-group-make-group dir "nndir" dir)
4330 (gnus-group-position-cursor))
4331
4332(defun gnus-group-make-kiboze-group (group address scores)
4333 "Create an nnkiboze group.
4334The user will be prompted for a name, a regexp to match groups, and
4335score file entries for articles to include in the group."
4336 (interactive
4337 (list
4338 (read-string "nnkiboze group name: ")
4339 (read-string "Source groups (regexp): ")
4340 (let ((headers (mapcar (lambda (group) (list group))
4341 '("subject" "from" "number" "date" "message-id"
4342 "references" "chars" "lines" "xref")))
4343 scores header regexp regexps)
4344 (while (not (equal "" (setq header (completing-read
4345 "Match on header: " headers nil t))))
4346 (setq regexps nil)
4347 (while (not (equal "" (setq regexp (read-string
4348 (format "Match on %s (string): "
4349 header)))))
4350 (setq regexps (cons (list regexp nil nil 'r) regexps)))
4351 (setq scores (cons (cons header regexps) scores)))
4352 scores)))
4353 (gnus-group-make-group group "nnkiboze" address)
4354 (save-excursion
4355 (gnus-set-work-buffer)
4356 (let (emacs-lisp-mode-hook)
4357 (pp scores (current-buffer)))
4358 (write-region (point-min) (point-max)
4359 (concat (or gnus-kill-files-directory "~/News")
4360 "nnkiboze:" group "." gnus-score-file-suffix)))
4361 (gnus-group-position-cursor))
4362
4363(defun gnus-group-add-to-virtual (n vgroup)
4364 "Add the current group to a virtual group."
4365 (interactive
4366 (list current-prefix-arg
4367 (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t
4368 "nnvirtual:")))
4369 (or (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
4370 (error "%s is not an nnvirtual group" vgroup))
4371 (let* ((groups (gnus-group-process-prefix n))
4372 (method (nth 4 (nth 2 (gnus-gethash vgroup gnus-newsrc-hashtb)))))
4373 (setcar (cdr method)
4374 (concat
4375 (nth 1 method) "\\|"
4376 (mapconcat
4377 (lambda (s)
4378 (gnus-group-remove-mark s)
4379 (concat "\\(^" (regexp-quote s) "$\\)"))
4380 groups "\\|"))))
4381 (gnus-group-position-cursor))
4382
4383(defun gnus-group-make-empty-virtual (group)
4384 "Create a new, fresh, empty virtual group."
4385 (interactive "sCreate new, empty virtual group: ")
4386 (let* ((method (list 'nnvirtual "^$"))
4387 (pgroup (gnus-group-prefixed-name group method)))
4388 ;; Check whether it exists already.
4389 (and (gnus-gethash pgroup gnus-newsrc-hashtb)
4390 (error "Group %s already exists." pgroup))
4391 ;; Subscribe the new group after the group on the current line.
4392 (gnus-subscribe-group pgroup (gnus-group-group-name) method)
4393 (gnus-group-update-group pgroup)
4394 (forward-line -1)
4395 (gnus-group-position-cursor)))
4396
4397(defun gnus-group-enter-directory (dir)
4398 "Enter an ephemeral nneething group."
4399 (interactive "DDirectory to read: ")
4400 (let* ((method (list 'nneething dir))
4401 (leaf (gnus-group-prefixed-name
4402 (file-name-nondirectory (directory-file-name dir))
4403 method))
4404 (name (gnus-generate-new-group-name leaf)))
4405 (let ((nneething-read-only t))
4406 (or (gnus-group-read-ephemeral-group
4407 name method t
4408 (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode)
4409 'summary 'group)))
4410 (error "Couldn't enter %s" dir)))))
4411
4412;; Group sorting commands
4413;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
4414
4415(defun gnus-group-sort-groups ()
4416 "Sort the group buffer using `gnus-group-sort-function'."
4417 (interactive)
4418 (setq gnus-newsrc-alist
4419 (sort (cdr gnus-newsrc-alist) gnus-group-sort-function))
4420 (gnus-make-hashtable-from-newsrc-alist)
4421 (gnus-group-list-groups))
745bc783 4422
41487370
LMI
4423(defun gnus-group-sort-by-alphabet (info1 info2)
4424 (string< (car info1) (car info2)))
4425
4426(defun gnus-group-sort-by-unread (info1 info2)
4427 (let ((n1 (car (gnus-gethash (car info1) gnus-newsrc-hashtb)))
4428 (n2 (car (gnus-gethash (car info2) gnus-newsrc-hashtb))))
4429 (< (or (and (numberp n1) n1) 0)
4430 (or (and (numberp n2) n2) 0))))
4431
4432(defun gnus-group-sort-by-level (info1 info2)
4433 (< (nth 1 info1) (nth 1 info2)))
4434
4435;; Group catching up.
4436
4437(defun gnus-group-catchup-current (&optional n all)
4438 "Mark all articles not marked as unread in current newsgroup as read.
4439If prefix argument N is numeric, the ARG next newsgroups will be
4440caught up. If ALL is non-nil, marked articles will also be marked as
4441read. Cross references (Xref: header) of articles are ignored.
4442The difference between N and actual number of newsgroups that were
4443caught up is returned."
4444 (interactive "P")
4445 (if (not (or (not gnus-interactive-catchup) ;Without confirmation?
4446 gnus-expert-user
4447 (gnus-y-or-n-p
4448 (if all
4449 "Do you really want to mark all articles as read? "
4450 "Mark all unread articles as read? "))))
4451 n
4452 (let ((groups (gnus-group-process-prefix n))
4453 (ret 0))
4454 (while groups
4455 ;; Virtual groups have to be given special treatment.
4456 (let ((method (gnus-find-method-for-group (car groups))))
4457 (if (eq 'nnvirtual (car method))
4458 (nnvirtual-catchup-group
4459 (gnus-group-real-name (car groups)) (nth 1 method) all)))
4460 (gnus-group-remove-mark (car groups))
4461 (if (prog1
4462 (gnus-group-goto-group (car groups))
4463 (gnus-group-catchup (car groups) all))
4464 (gnus-group-update-group-line)
4465 (setq ret (1+ ret)))
4466 (setq groups (cdr groups)))
4467 (gnus-group-next-unread-group 1)
4468 ret)))
4469
4470(defun gnus-group-catchup-current-all (&optional n)
4471 "Mark all articles in current newsgroup as read.
4472Cross references (Xref: header) of articles are ignored."
4473 (interactive "P")
4474 (gnus-group-catchup-current n 'all))
4475
4476(defun gnus-group-catchup (group &optional all)
4477 "Mark all articles in GROUP as read.
4478If ALL is non-nil, all articles are marked as read.
4479The return value is the number of articles that were marked as read,
4480or nil if no action could be taken."
4481 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
4482 (num (car entry))
4483 (marked (nth 3 (nth 2 entry))))
4484 (if (not (numberp (car entry)))
4485 (gnus-message 1 "Can't catch up; non-active group")
4486 ;; Do the updating only if the newsgroup isn't killed.
4487 (if (not entry)
4488 ()
4489 (gnus-update-read-articles
4490 group (and (not all) (append (cdr (assq 'tick marked))
4491 (cdr (assq 'dormant marked))))
4492 nil (and (not all) (cdr (assq 'tick marked))))
4493 (and all
4494 (setq marked (nth 3 (nth 2 entry)))
4495 (setcar (nthcdr 3 (nth 2 entry))
4496 (delq (assq 'dormant marked)
4497 (nth 3 (nth 2 entry)))))))
4498 num))
4499
4500(defun gnus-group-expire-articles (&optional n)
4501 "Expire all expirable articles in the current newsgroup."
4502 (interactive "P")
4503 (let ((groups (gnus-group-process-prefix n))
4504 group)
4505 (or groups (error "No groups to expire"))
4506 (while groups
4507 (setq group (car groups)
4508 groups (cdr groups))
4509 (gnus-group-remove-mark group)
4510 (if (not (gnus-check-backend-function 'request-expire-articles group))
4511 ()
4512 (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
4513 (expirable (if (memq 'total-expire (nth 5 info))
4514 (cons nil (gnus-list-of-read-articles group))
4515 (assq 'expire (nth 3 info)))))
4516 (and expirable
4517 (setcdr expirable
4518 (gnus-request-expire-articles
4519 (cdr expirable) group))))))))
4520
4521(defun gnus-group-expire-all-groups ()
4522 "Expire all expirable articles in all newsgroups."
4523 (interactive)
4524 (save-excursion
4525 (gnus-message 5 "Expiring...")
4526 (let ((gnus-group-marked (mapcar (lambda (info) (car info))
4527 (cdr gnus-newsrc-alist))))
4528 (gnus-group-expire-articles nil)))
4529 (gnus-group-position-cursor)
4530 (gnus-message 5 "Expiring...done"))
4531
4532(defun gnus-group-set-current-level (n level)
4533 "Set the level of the next N groups to LEVEL."
4534 (interactive "P\nnLevel: ")
4535 (or (and (>= level 1) (<= level gnus-level-killed))
4536 (error "Illegal level: %d" level))
4537 (let ((groups (gnus-group-process-prefix n))
4538 group)
4539 (while groups
4540 (setq group (car groups)
4541 groups (cdr groups))
4542 (gnus-group-remove-mark group)
4543 (gnus-message 6 "Changed level of %s from %d to %d"
4544 group (gnus-group-group-level) level)
4545 (gnus-group-change-level group level
4546 (gnus-group-group-level))
4547 (gnus-group-update-group-line)))
4548 (gnus-group-position-cursor))
4549
4550(defun gnus-group-unsubscribe-current-group (&optional n)
4551 "Toggle subscription of the current group.
4552If given numerical prefix, toggle the N next groups."
4553 (interactive "P")
4554 (let ((groups (gnus-group-process-prefix n))
4555 group)
4556 (while groups
4557 (setq group (car groups)
4558 groups (cdr groups))
4559 (gnus-group-remove-mark group)
4560 (gnus-group-unsubscribe-group
4561 group (if (<= (gnus-group-group-level) gnus-level-subscribed)
4562 gnus-level-default-unsubscribed
4563 gnus-level-default-subscribed))
4564 (gnus-group-update-group-line))
4565 (gnus-group-next-group 1)))
4566
4567(defun gnus-group-unsubscribe-group (group &optional level)
745bc783 4568 "Toggle subscribe from/to unsubscribe GROUP.
41487370 4569New newsgroup is added to .newsrc automatically."
745bc783 4570 (interactive
41487370
LMI
4571 (list (completing-read
4572 "Group: " gnus-active-hashtb nil
4573 (memq gnus-select-method gnus-have-read-active-file))))
b027f415 4574 (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb)))
41487370
LMI
4575 (cond
4576 ((string-match "^[ \t]$" group)
4577 (error "Empty group name"))
4578 (newsrc
4579 ;; Toggle subscription flag.
4580 (gnus-group-change-level
4581 newsrc (if level level (if (<= (nth 1 (nth 2 newsrc))
4582 gnus-level-subscribed)
4583 (1+ gnus-level-subscribed)
4584 gnus-level-default-subscribed)))
4585 (gnus-group-update-group group))
4586 ((and (stringp group)
4587 (or (not (memq gnus-select-method gnus-have-read-active-file))
4588 (gnus-gethash group gnus-active-hashtb)))
4589 ;; Add new newsgroup.
4590 (gnus-group-change-level
4591 group
4592 (if level level gnus-level-default-subscribed)
4593 (or (and (member group gnus-zombie-list)
4594 gnus-level-zombie)
4595 gnus-level-killed)
4596 (and (gnus-group-group-name)
4597 (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb)))
4598 (gnus-group-update-group group))
4599 (t (error "No such newsgroup: %s" group)))
4600 (gnus-group-position-cursor)))
4601
4602(defun gnus-group-transpose-groups (n)
4603 "Move the current newsgroup up N places.
4604If given a negative prefix, move down instead. The difference between
4605N and the number of steps taken is returned."
4606 (interactive "p")
4607 (or (gnus-group-group-name)
4608 (error "No group on current line"))
4609 (gnus-group-kill-group 1)
4610 (prog1
4611 (forward-line (- n))
4612 (gnus-group-yank-group)
4613 (gnus-group-position-cursor)))
4614
4615(defun gnus-group-kill-all-zombies ()
4616 "Kill all zombie newsgroups."
745bc783 4617 (interactive)
41487370
LMI
4618 (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
4619 (setq gnus-zombie-list nil)
4620 (gnus-group-list-groups))
745bc783 4621
41487370
LMI
4622(defun gnus-group-kill-region (begin end)
4623 "Kill newsgroups in current region (excluding current point).
4624The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
4625 (interactive "r")
4626 (let ((lines
4627 ;; Count lines.
4628 (save-excursion
4629 (count-lines
4630 (progn
4631 (goto-char begin)
4632 (beginning-of-line)
4633 (point))
4634 (progn
4635 (goto-char end)
4636 (beginning-of-line)
4637 (point))))))
4638 (goto-char begin)
4639 (beginning-of-line) ;Important when LINES < 1
4640 (gnus-group-kill-group lines)))
4641
4642(defun gnus-group-kill-group (&optional n)
4643 "The the next N groups.
4644The killed newsgroups can be yanked by using \\[gnus-group-yank-group].
4645However, only groups that were alive can be yanked; already killed
4646groups or zombie groups can't be yanked.
4647The return value is the name of the (last) group that was killed."
4648 (interactive "P")
4649 (let ((buffer-read-only nil)
4650 (groups (gnus-group-process-prefix n))
4651 group entry level)
4652 (while groups
4653 (setq group (car groups)
4654 groups (cdr groups))
4655 (gnus-group-remove-mark group)
4656 (setq level (gnus-group-group-level))
4657 (gnus-delete-line)
4658 (if (setq entry (gnus-gethash group gnus-newsrc-hashtb))
4659 (setq gnus-list-of-killed-groups
4660 (cons (cons (car entry) (nth 2 entry))
4661 gnus-list-of-killed-groups)))
4662 (gnus-group-change-level
4663 (if entry entry group) gnus-level-killed (if entry nil level)))
4664 (gnus-group-position-cursor)
4665 group))
4666
4667(defun gnus-group-yank-group (&optional arg)
4668 "Yank the last newsgroups killed with \\[gnus-group-kill-group],
4669inserting it before the current newsgroup. The numeric ARG specifies
4670how many newsgroups are to be yanked. The name of the (last)
4671newsgroup yanked is returned."
4672 (interactive "p")
4673 (if (not arg) (setq arg 1))
4674 (let (info group prev)
4675 (while (>= (setq arg (1- arg)) 0)
4676 (if (not (setq info (car gnus-list-of-killed-groups)))
4677 (error "No more newsgroups to yank"))
4678 (setq group (nth 2 info))
4679 ;; Find which newsgroup to insert this one before - search
4680 ;; backward until something suitable is found. If there are no
4681 ;; other newsgroups in this buffer, just make this newsgroup the
4682 ;; first newsgroup.
4683 (setq prev (gnus-group-group-name))
4684 (gnus-group-change-level
4685 info (nth 2 info) gnus-level-killed
4686 (and prev (gnus-gethash prev gnus-newsrc-hashtb))
4687 t)
4688 (gnus-group-insert-group-line-info (nth 1 info))
4689 (setq gnus-list-of-killed-groups
4690 (cdr gnus-list-of-killed-groups)))
4691 (forward-line -1)
4692 (gnus-group-position-cursor)
4693 group))
4694
4695(defun gnus-group-list-all-groups (&optional arg)
4696 "List all newsgroups with level ARG or lower.
4697Default is gnus-level-unsubscribed, which lists all subscribed and most
4698unsubscribed groups."
4699 (interactive "P")
4700 (gnus-group-list-groups (or arg gnus-level-unsubscribed) t))
745bc783 4701
41487370
LMI
4702(defun gnus-group-list-killed ()
4703 "List all killed newsgroups in the group buffer."
4704 (interactive)
4705 (if (not gnus-killed-list)
4706 (gnus-message 6 "No killed groups")
4707 (let (gnus-group-list-mode)
4708 (funcall gnus-group-prepare-function
4709 gnus-level-killed t gnus-level-killed))
4710 (goto-char (point-min)))
4711 (gnus-group-position-cursor))
4712
4713(defun gnus-group-list-zombies ()
4714 "List all zombie newsgroups in the group buffer."
4715 (interactive)
4716 (if (not gnus-zombie-list)
4717 (gnus-message 6 "No zombie groups")
4718 (let (gnus-group-list-mode)
4719 (funcall gnus-group-prepare-function
4720 gnus-level-zombie t gnus-level-zombie))
4721 (goto-char (point-min)))
4722 (gnus-group-position-cursor))
4723
4724(defun gnus-group-get-new-news (&optional arg)
4725 "Get newly arrived articles.
4726If ARG is non-nil, it should be a number between one and nine to
4727specify which levels you are interested in re-scanning."
4728 (interactive "P")
4729 (run-hooks 'gnus-get-new-news-hook)
4730 (setq arg (gnus-group-default-level arg t))
4731 (if (and gnus-read-active-file (not arg))
4732 (progn
4733 (gnus-read-active-file)
4734 (gnus-get-unread-articles (or arg (1+ gnus-level-subscribed))))
4735 (let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
4736 (gnus-get-unread-articles (or arg (1+ gnus-level-subscribed)))))
4737 (gnus-group-list-groups))
4738
4739(defun gnus-group-get-new-news-this-group (&optional n)
4740 "Check for newly arrived news in the current group (and the N-1 next groups).
4741The difference between N and the number of newsgroup checked is returned.
4742If N is negative, this group and the N-1 previous groups will be checked."
4743 (interactive "P")
4744 (let* ((groups (gnus-group-process-prefix n))
4745 (ret (if (numberp n) (- n (length groups)) 0))
4746 group)
4747 (while groups
4748 (setq group (car groups)
4749 groups (cdr groups))
4750 (gnus-group-remove-mark group)
4751 (or (gnus-get-new-news-in-group group)
4752 (progn
4753 (ding)
4754 (message "%s error: %s" group (gnus-status-message group))
4755 (sit-for 2))))
4756 (gnus-group-next-unread-group 1 t)
4757 (gnus-summary-position-cursor)
4758 ret))
4759
4760(defun gnus-get-new-news-in-group (group)
4761 (and group
4762 (gnus-activate-group group)
4763 (progn
4764 (gnus-get-unread-articles-in-group
4765 (nth 2 (gnus-gethash group gnus-newsrc-hashtb))
4766 (gnus-gethash group gnus-active-hashtb))
4767 (gnus-group-update-group-line)
4768 t)))
4769
4770(defun gnus-group-fetch-faq (group)
4771 "Fetch the FAQ for the current group."
4772 (interactive (list (gnus-group-real-name (gnus-group-group-name))))
4773 (or group (error "No group name given"))
4774 (let ((file (concat gnus-group-faq-directory (gnus-group-real-name group))))
4775 (if (not (file-exists-p file))
4776 (error "No such file: %s" file)
4777 (find-file file))))
4778
4779(defun gnus-group-describe-group (force &optional group)
4780 "Display a description of the current newsgroup."
4781 (interactive (list current-prefix-arg (gnus-group-group-name)))
4782 (and force (setq gnus-description-hashtb nil))
4783 (let ((method (gnus-find-method-for-group group))
4784 desc)
4785 (or group (error "No group name given"))
4786 (and (or (and gnus-description-hashtb
4787 ;; We check whether this group's method has been
4788 ;; queried for a description file.
4789 (gnus-gethash
4790 (gnus-group-prefixed-name "" method)
4791 gnus-description-hashtb))
4792 (setq desc (gnus-group-get-description group))
4793 (gnus-read-descriptions-file method))
4794 (message
4795 (or desc (gnus-gethash group gnus-description-hashtb)
4796 "No description available")))))
4797
4798;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
4799(defun gnus-group-describe-all-groups (&optional force)
4800 "Pop up a buffer with descriptions of all newsgroups."
4801 (interactive "P")
4802 (and force (setq gnus-description-hashtb nil))
4803 (if (not (or gnus-description-hashtb
4804 (gnus-read-all-descriptions-files)))
4805 (error "Couldn't request descriptions file"))
4806 (let ((buffer-read-only nil)
4807 b)
4808 (erase-buffer)
4809 (mapatoms
4810 (lambda (group)
4811 (setq b (point))
4812 (insert (format " *: %-20s %s\n" (symbol-name group)
4813 (symbol-value group)))
4814 (add-text-properties
4815 b (1+ b) (list 'gnus-group group
4816 'gnus-unread t 'gnus-marked nil
4817 'gnus-level (1+ gnus-level-subscribed))))
4818 gnus-description-hashtb)
4819 (goto-char (point-min))
4820 (gnus-group-position-cursor)))
4821
4822;; Suggested by by Daniel Quinlan <quinlan@best.com>.
4823(defun gnus-group-apropos (regexp &optional search-description)
4824 "List all newsgroups that have names that match a regexp."
4825 (interactive "sGnus apropos (regexp): ")
4826 (let ((prev "")
4827 (obuf (current-buffer))
4828 groups des)
4829 ;; Go through all newsgroups that are known to Gnus.
4830 (mapatoms
4831 (lambda (group)
4832 (and (symbol-name group)
4833 (string-match regexp (symbol-name group))
4834 (setq groups (cons (symbol-name group) groups))))
4835 gnus-active-hashtb)
4836 ;; Go through all descriptions that are known to Gnus.
4837 (if search-description
4838 (mapatoms
4839 (lambda (group)
4840 (and (string-match regexp (symbol-value group))
4841 (gnus-gethash (symbol-name group) gnus-active-hashtb)
4842 (setq groups (cons (symbol-name group) groups))))
4843 gnus-description-hashtb))
4844 (if (not groups)
4845 (gnus-message 3 "No groups matched \"%s\"." regexp)
4846 ;; Print out all the groups.
4847 (save-excursion
4848 (pop-to-buffer "*Gnus Help*")
4849 (buffer-disable-undo (current-buffer))
4850 (erase-buffer)
4851 (setq groups (sort groups 'string<))
4852 (while groups
4853 ;; Groups may be entered twice into the list of groups.
4854 (if (not (string= (car groups) prev))
4855 (progn
4856 (insert (setq prev (car groups)) "\n")
4857 (if (and gnus-description-hashtb
4858 (setq des (gnus-gethash (car groups)
4859 gnus-description-hashtb)))
4860 (insert " " des "\n"))))
4861 (setq groups (cdr groups)))
4862 (goto-char (point-min))))
4863 (pop-to-buffer obuf)))
4864
4865(defun gnus-group-description-apropos (regexp)
4866 "List all newsgroups that have names or descriptions that match a regexp."
4867 (interactive "sGnus description apropos (regexp): ")
4868 (if (not (or gnus-description-hashtb
4869 (gnus-read-all-descriptions-files)))
4870 (error "Couldn't request descriptions file"))
4871 (gnus-group-apropos regexp t))
4872
4873;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
4874(defun gnus-group-list-matching (level regexp &optional all lowest)
4875 "List all groups with unread articles that match REGEXP.
4876If the prefix LEVEL is non-nil, it should be a number that says which
4877level to cut off listing groups.
4878If ALL, also list groups with no unread articles.
4879If LOWEST, don't list groups with level lower than LOWEST."
4880 (interactive "P\nsList newsgroups matching: ")
4881 (gnus-group-prepare-flat (or level gnus-level-subscribed)
4882 all (or lowest 1) regexp)
4883 (goto-char (point-min))
4884 (gnus-group-position-cursor))
4885
4886(defun gnus-group-list-all-matching (level regexp &optional lowest)
4887 "List all groups that match REGEXP.
4888If the prefix LEVEL is non-nil, it should be a number that says which
4889level to cut off listing groups.
4890If LOWEST, don't list groups with level lower than LOWEST."
4891 (interactive "P\nsList newsgroups matching: ")
4892 (gnus-group-list-matching (or level gnus-level-killed) regexp t lowest))
4893
4894;; Suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.
4895(defun gnus-group-save-newsrc ()
4896 "Save the Gnus startup files."
745bc783 4897 (interactive)
41487370
LMI
4898 (gnus-save-newsrc-file))
4899
4900(defun gnus-group-restart (&optional arg)
4901 "Force Gnus to read the .newsrc file."
4902 (interactive "P")
745bc783 4903 (gnus-save-newsrc-file)
41487370
LMI
4904 (gnus-setup-news 'force)
4905 (gnus-group-list-groups arg))
745bc783 4906
41487370
LMI
4907(defun gnus-group-read-init-file ()
4908 "Read the Gnus elisp init file."
745bc783 4909 (interactive)
41487370 4910 (gnus-read-init-file))
745bc783 4911
41487370
LMI
4912(defun gnus-group-check-bogus-groups (&optional silent)
4913 "Check bogus newsgroups.
4914If given a prefix, don't ask for confirmation before removing a bogus
4915group."
4916 (interactive "P")
4917 (gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user)))
4918 (gnus-group-list-groups))
745bc783 4919
41487370
LMI
4920(defun gnus-group-edit-global-kill (&optional article group)
4921 "Edit the global kill file.
4922If GROUP, edit that local kill file instead."
4923 (interactive "P")
4924 (setq gnus-current-kill-article article)
4925 (gnus-kill-file-edit-file group)
4926 (gnus-message
4927 6
745bc783 4928 (substitute-command-keys
41487370 4929 "Editing a global kill file (Type \\[gnus-kill-file-exit] to exit)")))
745bc783 4930
41487370
LMI
4931(defun gnus-group-edit-local-kill (article group)
4932 "Edit a local kill file."
4933 (interactive (list nil (gnus-group-group-name)))
4934 (gnus-group-edit-global-kill article group))
745bc783 4935
b027f415 4936(defun gnus-group-force-update ()
ef97d5a2 4937 "Update `.newsrc' file."
745bc783
JB
4938 (interactive)
4939 (gnus-save-newsrc-file))
4940
b027f415 4941(defun gnus-group-suspend ()
41487370
LMI
4942 "Suspend the current Gnus session.
4943In fact, cleanup buffers except for group mode buffer.
4944The hook gnus-suspend-gnus-hook is called before actually suspending."
745bc783 4945 (interactive)
b027f415 4946 (run-hooks 'gnus-suspend-gnus-hook)
41487370
LMI
4947 ;; Kill Gnus buffers except for group mode buffer.
4948 (let ((group-buf (get-buffer gnus-group-buffer)))
4949 ;; Do this on a separate list in case the user does a ^G before we finish
4950 (let ((gnus-buffer-list
4951 (delq group-buf (delq gnus-dribble-buffer
4952 (append gnus-buffer-list nil)))))
4953 (while gnus-buffer-list
4954 (gnus-kill-buffer (car gnus-buffer-list))
4955 (setq gnus-buffer-list (cdr gnus-buffer-list))))
4956 (if group-buf
4957 (progn
4958 (setq gnus-buffer-list (list group-buf))
4959 (bury-buffer group-buf)
4960 (delete-windows-on group-buf t)))))
4961
4962(defun gnus-group-clear-dribble ()
4963 "Clear all information from the dribble buffer."
4964 (interactive)
4965 (gnus-dribble-clear))
745bc783 4966
b027f415 4967(defun gnus-group-exit ()
41487370
LMI
4968 "Quit reading news after updating .newsrc.eld and .newsrc.
4969The hook `gnus-exit-gnus-hook' is called before actually exiting."
745bc783
JB
4970 (interactive)
4971 (if (or noninteractive ;For gnus-batch-kill
41487370 4972 (not (gnus-server-opened gnus-select-method)) ;NNTP connection closed
b027f415 4973 (not gnus-interactive-exit) ;Without confirmation
41487370
LMI
4974 gnus-expert-user
4975 (gnus-y-or-n-p "Are you sure you want to quit reading news? "))
745bc783 4976 (progn
b027f415 4977 (run-hooks 'gnus-exit-gnus-hook)
41487370
LMI
4978 ;; Offer to save data from non-quitted summary buffers.
4979 (gnus-offer-save-summaries)
4980 ;; Save the newsrc file(s).
745bc783 4981 (gnus-save-newsrc-file)
41487370
LMI
4982 ;; Kill-em-all.
4983 (gnus-close-backends)
4984 ;; Reset everything.
4985 (gnus-clear-system))))
4986
4987(defun gnus-close-backends ()
4988 ;; Send a close request to all backends that support such a request.
4989 (let ((methods gnus-valid-select-methods)
4990 func)
4991 (while methods
4992 (if (fboundp (setq func (intern (concat (car (car methods))
4993 "-request-close"))))
4994 (funcall func))
4995 (setq methods (cdr methods)))))
745bc783 4996
b027f415 4997(defun gnus-group-quit ()
41487370
LMI
4998 "Quit reading news without updating .newsrc.eld or .newsrc.
4999The hook `gnus-exit-gnus-hook' is called before actually exiting."
745bc783 5000 (interactive)
b027f415
RS
5001 (if (or noninteractive ;For gnus-batch-kill
5002 (zerop (buffer-size))
41487370
LMI
5003 (not (gnus-server-opened gnus-select-method))
5004 gnus-expert-user
5005 (not gnus-current-startup-file)
5006 (gnus-yes-or-no-p
745bc783
JB
5007 (format "Quit reading news without saving %s? "
5008 (file-name-nondirectory gnus-current-startup-file))))
5009 (progn
b027f415 5010 (run-hooks 'gnus-exit-gnus-hook)
41487370
LMI
5011 (if gnus-use-full-window
5012 (delete-other-windows)
5013 (gnus-remove-some-windows))
5014 (gnus-dribble-save)
5015 (gnus-close-backends)
5016 (gnus-clear-system))))
5017
5018(defun gnus-offer-save-summaries ()
5019 (save-excursion
5020 (let ((buflist (buffer-list))
5021 buffers bufname)
5022 (while buflist
5023 (and (setq bufname (buffer-name (car buflist)))
5024 (string-match "Summary" bufname)
5025 (save-excursion
5026 (set-buffer bufname)
5027 ;; We check that this is, indeed, a summary buffer.
5028 (eq major-mode 'gnus-summary-mode))
5029 (setq buffers (cons bufname buffers)))
5030 (setq buflist (cdr buflist)))
5031 (and buffers
5032 (map-y-or-n-p
5033 "Update summary buffer %s? "
5034 (lambda (buf)
5035 (set-buffer buf)
5036 (gnus-summary-exit))
5037 buffers)))))
745bc783 5038
b027f415 5039(defun gnus-group-describe-briefly ()
41487370
LMI
5040 "Give a one line description of the group mode commands."
5041 (interactive)
5042 (gnus-message 7 (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help")))
5043
5044(defun gnus-group-browse-foreign-server (method)
5045 "Browse a foreign news server.
5046If called interactively, this function will ask for a select method
5047 (nntp, nnspool, etc.) and a server address (eg. nntp.some.where).
5048If not, METHOD should be a list where the first element is the method
5049and the second element is the address."
5050 (interactive
5051 (list (let ((how (completing-read
5052 "Which backend: "
5053 (append gnus-valid-select-methods gnus-server-alist)
5054 nil t "nntp")))
5055 ;; We either got a backend name or a virtual server name.
5056 ;; If the first, we also need an address.
5057 (if (assoc how gnus-valid-select-methods)
5058 (list (intern how)
5059 ;; Suggested by mapjph@bath.ac.uk.
5060 (completing-read
5061 "Address: "
5062 (mapcar (lambda (server) (list server))
5063 gnus-secondary-servers)))
5064 ;; We got a server name, so we find the method.
5065 (gnus-server-to-method how)))))
5066 (gnus-browse-foreign-server method))
5067
5068\f
5069;;;
5070;;; Browse Server Mode
5071;;;
5072
5073(defvar gnus-browse-mode-hook nil)
5074(defvar gnus-browse-mode-map nil)
5075(put 'gnus-browse-mode 'mode-class 'special)
5076
5077(if gnus-browse-mode-map
5078 nil
5079 (setq gnus-browse-mode-map (make-keymap))
5080 (suppress-keymap gnus-browse-mode-map)
5081 (define-key gnus-browse-mode-map " " 'gnus-browse-read-group)
5082 (define-key gnus-browse-mode-map "=" 'gnus-browse-select-group)
5083 (define-key gnus-browse-mode-map "n" 'gnus-browse-next-group)
5084 (define-key gnus-browse-mode-map "p" 'gnus-browse-prev-group)
5085 (define-key gnus-browse-mode-map "\177" 'gnus-browse-prev-group)
5086 (define-key gnus-browse-mode-map "N" 'gnus-browse-next-group)
5087 (define-key gnus-browse-mode-map "P" 'gnus-browse-prev-group)
5088 (define-key gnus-browse-mode-map "\M-n" 'gnus-browse-next-group)
5089 (define-key gnus-browse-mode-map "\M-p" 'gnus-browse-prev-group)
5090 (define-key gnus-browse-mode-map "\r" 'gnus-browse-select-group)
5091 (define-key gnus-browse-mode-map "u" 'gnus-browse-unsubscribe-current-group)
5092 (define-key gnus-browse-mode-map "l" 'gnus-browse-exit)
5093 (define-key gnus-browse-mode-map "L" 'gnus-browse-exit)
5094 (define-key gnus-browse-mode-map "q" 'gnus-browse-exit)
5095 (define-key gnus-browse-mode-map "Q" 'gnus-browse-exit)
5096 (define-key gnus-browse-mode-map "\C-c\C-c" 'gnus-browse-exit)
5097 (define-key gnus-browse-mode-map "?" 'gnus-browse-describe-briefly)
5098 (define-key gnus-browse-mode-map "\C-c\C-i" 'gnus-info-find-node)
5099 )
5100
5101(defvar gnus-browse-current-method nil)
5102(defvar gnus-browse-return-buffer nil)
5103
5104(defvar gnus-browse-buffer "*Gnus Browse Server*")
5105
5106(defun gnus-browse-foreign-server (method &optional return-buffer)
5107 (setq gnus-browse-current-method method)
5108 (setq gnus-browse-return-buffer return-buffer)
5109 (let ((gnus-select-method method)
5110 groups group)
5111 (gnus-message 5 "Connecting to %s..." (nth 1 method))
5112 (or (gnus-check-server method)
5113 (error "Unable to contact server: %s" (gnus-status-message method)))
5114 (or (gnus-request-list method)
5115 (error "Couldn't request list: %s" (gnus-status-message method)))
5116 (get-buffer-create gnus-browse-buffer)
5117 (gnus-add-current-to-buffer-list)
5118 (and gnus-carpal (gnus-carpal-setup-buffer 'browse))
5119 (gnus-configure-windows 'browse)
5120 (buffer-disable-undo (current-buffer))
5121 (let ((buffer-read-only nil))
5122 (erase-buffer))
5123 (gnus-browse-mode)
5124 (setq mode-line-buffer-identification
5125 (format
5126 "Gnus Browse Server {%s:%s}" (car method) (car (cdr method))))
5127 (save-excursion
5128 (set-buffer nntp-server-buffer)
5129 (let ((cur (current-buffer)))
5130 (goto-char (point-min))
5131 (or (string= gnus-ignored-newsgroups "")
5132 (delete-matching-lines gnus-ignored-newsgroups))
5133 (while (re-search-forward
5134 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
5135 (goto-char (match-end 1))
5136 (setq groups (cons (cons (buffer-substring (match-beginning 1)
5137 (match-end 1))
5138 (max 0 (- (1+ (read cur)) (read cur))))
5139 groups)))))
5140 (setq groups (sort groups
5141 (lambda (l1 l2)
5142 (string< (car l1) (car l2)))))
5143 (let ((buffer-read-only nil))
5144 (while groups
5145 (setq group (car groups))
5146 (insert
5147 (format "K%7d: %s\n" (cdr group) (car group)))
5148 (setq groups (cdr groups))))
5149 (switch-to-buffer (current-buffer))
5150 (goto-char (point-min))
5151 (gnus-group-position-cursor)))
5152
5153(defun gnus-browse-mode ()
5154 "Major mode for browsing a foreign server.
5155
5156All normal editing commands are switched off.
5157
5158\\<gnus-browse-mode-map>
5159The only things you can do in this buffer is
5160
51611) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
5162The group will be inserted into the group buffer upon exit from this
5163buffer.
5164
51652) `\\[gnus-browse-read-group]' to read a group ephemerally.
5166
51673) `\\[gnus-browse-exit]' to return to the group buffer."
5168 (interactive)
5169 (kill-all-local-variables)
5170 (if gnus-visual (gnus-browse-make-menu-bar))
a828a776 5171 (gnus-simplify-mode-line)
41487370
LMI
5172 (setq major-mode 'gnus-browse-mode)
5173 (setq mode-name "Browse Server")
5174 (setq mode-line-process nil)
5175 (use-local-map gnus-browse-mode-map)
5176 (buffer-disable-undo (current-buffer))
5177 (setq truncate-lines t)
5178 (setq buffer-read-only t)
5179 (run-hooks 'gnus-browse-mode-hook))
5180
5181(defun gnus-browse-read-group (&optional no-article)
5182 "Enter the group at the current line."
5183 (interactive)
5184 (let ((group (gnus-browse-group-name)))
5185 (or (gnus-group-read-ephemeral-group
5186 group gnus-browse-current-method nil
5187 (cons (current-buffer) 'browse))
5188 (error "Couldn't enter %s" group))))
5189
5190(defun gnus-browse-select-group ()
5191 "Select the current group."
5192 (interactive)
5193 (gnus-browse-read-group 'no))
5194
5195(defun gnus-browse-next-group (n)
5196 "Go to the next group."
5197 (interactive "p")
5198 (prog1
5199 (forward-line n)
5200 (gnus-group-position-cursor)))
5201
5202(defun gnus-browse-prev-group (n)
5203 "Go to the next group."
5204 (interactive "p")
5205 (gnus-browse-next-group (- n)))
5206
5207(defun gnus-browse-unsubscribe-current-group (arg)
5208 "(Un)subscribe to the next ARG groups."
5209 (interactive "p")
5210 (and (eobp)
5211 (error "No group at current line."))
5212 (let ((ward (if (< arg 0) -1 1))
5213 (arg (abs arg)))
5214 (while (and (> arg 0)
5215 (not (eobp))
5216 (gnus-browse-unsubscribe-group)
5217 (zerop (gnus-browse-next-group ward)))
5218 (setq arg (1- arg)))
5219 (gnus-group-position-cursor)
5220 (if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
5221 arg))
5222
5223(defun gnus-browse-group-name ()
5224 (save-excursion
5225 (beginning-of-line)
5226 (if (not (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t))
5227 ()
5228 (gnus-group-prefixed-name
5229 (buffer-substring (match-beginning 1) (match-end 1))
5230 gnus-browse-current-method))))
5231
5232(defun gnus-browse-unsubscribe-group ()
5233 "Toggle subscription of the current group in the browse buffer."
5234 (let ((sub nil)
5235 (buffer-read-only nil)
5236 group)
5237 (save-excursion
5238 (beginning-of-line)
5239 ;; If this group it killed, then we want to subscribe it.
5240 (if (= (following-char) ?K) (setq sub t))
5241 (setq group (gnus-browse-group-name))
5242 (delete-char 1)
5243 (if sub
5244 (progn
5245 (gnus-group-change-level
5246 (list t group gnus-level-default-subscribed
5247 nil nil gnus-browse-current-method)
5248 gnus-level-default-subscribed gnus-level-killed
5249 (and (car (nth 1 gnus-newsrc-alist))
5250 (gnus-gethash (car (nth 1 gnus-newsrc-alist))
5251 gnus-newsrc-hashtb))
5252 t)
5253 (insert ? ))
5254 (gnus-group-change-level
5255 group gnus-level-killed gnus-level-default-subscribed)
5256 (insert ?K)))
5257 t))
5258
5259(defun gnus-browse-exit ()
5260 "Quit browsing and return to the group buffer."
745bc783 5261 (interactive)
41487370
LMI
5262 (if (eq major-mode 'gnus-browse-mode)
5263 (kill-buffer (current-buffer)))
5264 (if gnus-browse-return-buffer
5265 (gnus-configure-windows 'server 'force)
5266 (gnus-configure-windows 'group 'force)
5267 (gnus-group-list-groups nil)))
745bc783 5268
41487370
LMI
5269(defun gnus-browse-describe-briefly ()
5270 "Give a one line description of the group mode commands."
5271 (interactive)
5272 (gnus-message 6
5273 (substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help")))
5274
745bc783
JB
5275\f
5276;;;
41487370 5277;;; Gnus summary mode
745bc783
JB
5278;;;
5279
41487370
LMI
5280(defvar gnus-summary-mode-map nil)
5281(defvar gnus-summary-mark-map nil)
5282(defvar gnus-summary-mscore-map nil)
5283(defvar gnus-summary-article-map nil)
5284(defvar gnus-summary-thread-map nil)
5285(defvar gnus-summary-goto-map nil)
5286(defvar gnus-summary-exit-map nil)
5287(defvar gnus-summary-interest-map nil)
5288(defvar gnus-summary-sort-map nil)
5289(defvar gnus-summary-backend-map nil)
5290(defvar gnus-summary-save-map nil)
5291(defvar gnus-summary-wash-map nil)
5292(defvar gnus-summary-wash-hide-map nil)
5293(defvar gnus-summary-wash-highlight-map nil)
5294(defvar gnus-summary-wash-time-map nil)
5295(defvar gnus-summary-help-map nil)
5296
5297(put 'gnus-summary-mode 'mode-class 'special)
5298
b027f415 5299(if gnus-summary-mode-map
745bc783 5300 nil
b027f415
RS
5301 (setq gnus-summary-mode-map (make-keymap))
5302 (suppress-keymap gnus-summary-mode-map)
41487370
LMI
5303
5304 ;; Non-orthogonal keys
5305
b027f415
RS
5306 (define-key gnus-summary-mode-map " " 'gnus-summary-next-page)
5307 (define-key gnus-summary-mode-map "\177" 'gnus-summary-prev-page)
5308 (define-key gnus-summary-mode-map "\r" 'gnus-summary-scroll-up)
5309 (define-key gnus-summary-mode-map "n" 'gnus-summary-next-unread-article)
5310 (define-key gnus-summary-mode-map "p" 'gnus-summary-prev-unread-article)
5311 (define-key gnus-summary-mode-map "N" 'gnus-summary-next-article)
5312 (define-key gnus-summary-mode-map "P" 'gnus-summary-prev-article)
41487370
LMI
5313 (define-key gnus-summary-mode-map "\M-\C-n" 'gnus-summary-next-same-subject)
5314 (define-key gnus-summary-mode-map "\M-\C-p" 'gnus-summary-prev-same-subject)
5315 (define-key gnus-summary-mode-map "\M-n" 'gnus-summary-next-unread-subject)
5316 (define-key gnus-summary-mode-map "\M-p" 'gnus-summary-prev-unread-subject)
b027f415 5317 (define-key gnus-summary-mode-map "." 'gnus-summary-first-unread-article)
41487370
LMI
5318 (define-key gnus-summary-mode-map "," 'gnus-summary-best-unread-article)
5319 (define-key gnus-summary-mode-map
5320 "\M-s" 'gnus-summary-search-article-forward)
5321 (define-key gnus-summary-mode-map
5322 "\M-r" 'gnus-summary-search-article-backward)
b027f415
RS
5323 (define-key gnus-summary-mode-map "<" 'gnus-summary-beginning-of-article)
5324 (define-key gnus-summary-mode-map ">" 'gnus-summary-end-of-article)
5325 (define-key gnus-summary-mode-map "j" 'gnus-summary-goto-subject)
b027f415 5326 (define-key gnus-summary-mode-map "^" 'gnus-summary-refer-parent-article)
41487370
LMI
5327 (define-key gnus-summary-mode-map "\M-^" 'gnus-summary-refer-article)
5328 (define-key gnus-summary-mode-map "u" 'gnus-summary-tick-article-forward)
5329 (define-key gnus-summary-mode-map "!" 'gnus-summary-tick-article-forward)
5330 (define-key gnus-summary-mode-map "U" 'gnus-summary-tick-article-backward)
b027f415
RS
5331 (define-key gnus-summary-mode-map "d" 'gnus-summary-mark-as-read-forward)
5332 (define-key gnus-summary-mode-map "D" 'gnus-summary-mark-as-read-backward)
41487370
LMI
5333 (define-key gnus-summary-mode-map "E" 'gnus-summary-mark-as-expirable)
5334 (define-key gnus-summary-mode-map "\M-u" 'gnus-summary-clear-mark-forward)
5335 (define-key gnus-summary-mode-map "\M-U" 'gnus-summary-clear-mark-backward)
5336 (define-key gnus-summary-mode-map
5337 "k" 'gnus-summary-kill-same-subject-and-select)
b027f415 5338 (define-key gnus-summary-mode-map "\C-k" 'gnus-summary-kill-same-subject)
41487370
LMI
5339 (define-key gnus-summary-mode-map "\M-\C-k" 'gnus-summary-kill-thread)
5340 (define-key gnus-summary-mode-map "\M-\C-l" 'gnus-summary-lower-thread)
5341 (define-key gnus-summary-mode-map "e" 'gnus-summary-edit-article)
5342 (define-key gnus-summary-mode-map "#" 'gnus-summary-mark-as-processable)
5343 (define-key gnus-summary-mode-map "\M-#" 'gnus-summary-unmark-as-processable)
5344 (define-key gnus-summary-mode-map "\M-\C-t" 'gnus-summary-toggle-threads)
5345 (define-key gnus-summary-mode-map "\M-\C-s" 'gnus-summary-show-thread)
5346 (define-key gnus-summary-mode-map "\M-\C-h" 'gnus-summary-hide-thread)
5347 (define-key gnus-summary-mode-map "\M-\C-f" 'gnus-summary-next-thread)
5348 (define-key gnus-summary-mode-map "\M-\C-b" 'gnus-summary-prev-thread)
5349 (define-key gnus-summary-mode-map "\M-\C-u" 'gnus-summary-up-thread)
5350 (define-key gnus-summary-mode-map "\M-\C-d" 'gnus-summary-down-thread)
b027f415 5351 (define-key gnus-summary-mode-map "&" 'gnus-summary-execute-command)
b027f415 5352 (define-key gnus-summary-mode-map "c" 'gnus-summary-catchup-and-exit)
41487370 5353 (define-key gnus-summary-mode-map "\C-w" 'gnus-summary-mark-region-as-read)
b027f415 5354 (define-key gnus-summary-mode-map "\C-t" 'gnus-summary-toggle-truncation)
41487370
LMI
5355 (define-key gnus-summary-mode-map "?" 'gnus-summary-mark-as-dormant)
5356 (define-key gnus-summary-mode-map
5357 "\C-c\M-\C-s" 'gnus-summary-show-all-expunged)
5358 (define-key gnus-summary-mode-map
5359 "\C-c\C-s\C-n" 'gnus-summary-sort-by-number)
5360 (define-key gnus-summary-mode-map
5361 "\C-c\C-s\C-a" 'gnus-summary-sort-by-author)
5362 (define-key gnus-summary-mode-map
5363 "\C-c\C-s\C-s" 'gnus-summary-sort-by-subject)
b027f415 5364 (define-key gnus-summary-mode-map "\C-c\C-s\C-d" 'gnus-summary-sort-by-date)
41487370 5365 (define-key gnus-summary-mode-map "\C-c\C-s\C-i" 'gnus-summary-sort-by-score)
b027f415 5366 (define-key gnus-summary-mode-map "=" 'gnus-summary-expand-window)
41487370
LMI
5367 (define-key gnus-summary-mode-map
5368 "\C-x\C-s" 'gnus-summary-reselect-current-group)
5369 (define-key gnus-summary-mode-map "\M-g" 'gnus-summary-rescan-group)
b027f415
RS
5370 (define-key gnus-summary-mode-map "w" 'gnus-summary-stop-page-breaking)
5371 (define-key gnus-summary-mode-map "\C-c\C-r" 'gnus-summary-caesar-message)
41487370 5372 (define-key gnus-summary-mode-map "\M-t" 'gnus-summary-toggle-mime)
b027f415
RS
5373 (define-key gnus-summary-mode-map "f" 'gnus-summary-followup)
5374 (define-key gnus-summary-mode-map "F" 'gnus-summary-followup-with-original)
5375 (define-key gnus-summary-mode-map "C" 'gnus-summary-cancel-article)
5376 (define-key gnus-summary-mode-map "r" 'gnus-summary-reply)
5377 (define-key gnus-summary-mode-map "R" 'gnus-summary-reply-with-original)
5378 (define-key gnus-summary-mode-map "\C-c\C-f" 'gnus-summary-mail-forward)
b027f415 5379 (define-key gnus-summary-mode-map "o" 'gnus-summary-save-article)
41487370 5380 (define-key gnus-summary-mode-map "\C-o" 'gnus-summary-save-article-mail)
b027f415 5381 (define-key gnus-summary-mode-map "|" 'gnus-summary-pipe-output)
41487370
LMI
5382 (define-key gnus-summary-mode-map "\M-k" 'gnus-summary-edit-local-kill)
5383 (define-key gnus-summary-mode-map "\M-K" 'gnus-summary-edit-global-kill)
b027f415 5384 (define-key gnus-summary-mode-map "V" 'gnus-version)
41487370 5385 (define-key gnus-summary-mode-map "\C-c\C-d" 'gnus-summary-describe-group)
b027f415 5386 (define-key gnus-summary-mode-map "q" 'gnus-summary-exit)
41487370 5387 (define-key gnus-summary-mode-map "Q" 'gnus-summary-exit-no-update)
ef97d5a2 5388 (define-key gnus-summary-mode-map "\C-c\C-i" 'gnus-info-find-node)
41487370
LMI
5389 (define-key gnus-summary-mode-map gnus-mouse-2 'gnus-mouse-pick-article)
5390 (define-key gnus-summary-mode-map "m" 'gnus-summary-mail-other-window)
5391 (define-key gnus-summary-mode-map "a" 'gnus-summary-post-news)
5392 (define-key gnus-summary-mode-map
5393 "x" 'gnus-summary-remove-lines-marked-as-read)
5394; (define-key gnus-summary-mode-map "X" 'gnus-summary-remove-lines-marked-with)
5395 (define-key gnus-summary-mode-map "s" 'gnus-summary-isearch-article)
5396 (define-key gnus-summary-mode-map "t" 'gnus-summary-toggle-header)
5397 (define-key gnus-summary-mode-map "g" 'gnus-summary-show-article)
5398; (define-key gnus-summary-mode-map "?" 'gnus-summary-describe-briefly)
5399 (define-key gnus-summary-mode-map "l" 'gnus-summary-goto-last-article)
5400 (define-key gnus-summary-mode-map "\C-c\C-v\C-v" 'gnus-uu-decode-uu-view)
5401 (define-key gnus-summary-mode-map "\C-d" 'gnus-summary-enter-digest-group)
5402 (define-key gnus-summary-mode-map "v" 'gnus-summary-verbose-headers)
5403 (define-key gnus-summary-mode-map "\C-c\C-b" 'gnus-bug)
5404
5405
5406 ;; Sort of orthogonal keymap
5407 (define-prefix-command 'gnus-summary-mark-map)
5408 (define-key gnus-summary-mode-map "M" 'gnus-summary-mark-map)
5409 (define-key gnus-summary-mark-map "t" 'gnus-summary-tick-article-forward)
5410 (define-key gnus-summary-mark-map "!" 'gnus-summary-tick-article-forward)
5411 (define-key gnus-summary-mark-map "d" 'gnus-summary-mark-as-read-forward)
5412 (define-key gnus-summary-mark-map "r" 'gnus-summary-mark-as-read-forward)
5413 (define-key gnus-summary-mark-map "c" 'gnus-summary-clear-mark-forward)
5414 (define-key gnus-summary-mark-map " " 'gnus-summary-clear-mark-forward)
5415 (define-key gnus-summary-mark-map "e" 'gnus-summary-mark-as-expirable)
5416 (define-key gnus-summary-mark-map "x" 'gnus-summary-mark-as-expirable)
5417 (define-key gnus-summary-mark-map "?" 'gnus-summary-mark-as-dormant)
5418 (define-key gnus-summary-mark-map "b" 'gnus-summary-set-bookmark)
5419 (define-key gnus-summary-mark-map "B" 'gnus-summary-remove-bookmark)
5420 (define-key gnus-summary-mark-map "#" 'gnus-summary-mark-as-processable)
5421 (define-key gnus-summary-mark-map "\M-#" 'gnus-summary-unmark-as-processable)
5422 (define-key gnus-summary-mark-map
5423 "\M-r" 'gnus-summary-remove-lines-marked-as-read)
5424 (define-key gnus-summary-mark-map
5425 "\M-\C-r" 'gnus-summary-remove-lines-marked-with)
5426 (define-key gnus-summary-mark-map "D" 'gnus-summary-show-all-dormant)
5427 (define-key gnus-summary-mark-map "\M-D" 'gnus-summary-hide-all-dormant)
5428 (define-key gnus-summary-mark-map "S" 'gnus-summary-show-all-expunged)
5429 (define-key gnus-summary-mark-map "C" 'gnus-summary-catchup)
5430 (define-key gnus-summary-mark-map "H" 'gnus-summary-catchup-to-here)
5431 (define-key gnus-summary-mark-map "\C-c" 'gnus-summary-catchup-all)
5432 (define-key gnus-summary-mark-map
5433 "k" 'gnus-summary-kill-same-subject-and-select)
5434 (define-key gnus-summary-mark-map "K" 'gnus-summary-kill-same-subject)
5435
5436 (define-prefix-command 'gnus-summary-mscore-map)
5437 (define-key gnus-summary-mark-map "V" 'gnus-summary-mscore-map)
5438 (define-key gnus-summary-mscore-map "c" 'gnus-summary-clear-above)
5439 (define-key gnus-summary-mscore-map "u" 'gnus-summary-tick-above)
5440 (define-key gnus-summary-mscore-map "m" 'gnus-summary-mark-above)
5441 (define-key gnus-summary-mscore-map "k" 'gnus-summary-kill-below)
5442
5443 (define-key gnus-summary-mark-map "P" 'gnus-uu-mark-map)
5444
5445 (define-key gnus-summary-mode-map "S" 'gnus-summary-send-map)
5446
5447 (define-prefix-command 'gnus-summary-goto-map)
5448 (define-key gnus-summary-mode-map "G" 'gnus-summary-goto-map)
5449 (define-key gnus-summary-goto-map "n" 'gnus-summary-next-unread-article)
5450 (define-key gnus-summary-goto-map "p" 'gnus-summary-prev-unread-article)
5451 (define-key gnus-summary-goto-map "N" 'gnus-summary-next-article)
5452 (define-key gnus-summary-goto-map "P" 'gnus-summary-prev-article)
5453 (define-key gnus-summary-goto-map "\C-n" 'gnus-summary-next-same-subject)
5454 (define-key gnus-summary-goto-map "\C-p" 'gnus-summary-prev-same-subject)
5455 (define-key gnus-summary-goto-map "\M-n" 'gnus-summary-next-unread-subject)
5456 (define-key gnus-summary-goto-map "\M-p" 'gnus-summary-prev-unread-subject)
5457 (define-key gnus-summary-goto-map "f" 'gnus-summary-first-unread-article)
5458 (define-key gnus-summary-goto-map "b" 'gnus-summary-best-unread-article)
5459 (define-key gnus-summary-goto-map "g" 'gnus-summary-goto-subject)
5460 (define-key gnus-summary-goto-map "l" 'gnus-summary-goto-last-article)
5461 (define-key gnus-summary-goto-map "p" 'gnus-summary-pop-article)
5462
5463
5464 (define-prefix-command 'gnus-summary-thread-map)
5465 (define-key gnus-summary-mode-map "T" 'gnus-summary-thread-map)
5466 (define-key gnus-summary-thread-map "k" 'gnus-summary-kill-thread)
5467 (define-key gnus-summary-thread-map "l" 'gnus-summary-lower-thread)
5468 (define-key gnus-summary-thread-map "i" 'gnus-summary-raise-thread)
5469 (define-key gnus-summary-thread-map "T" 'gnus-summary-toggle-threads)
5470 (define-key gnus-summary-thread-map "s" 'gnus-summary-show-thread)
5471 (define-key gnus-summary-thread-map "S" 'gnus-summary-show-all-threads)
5472 (define-key gnus-summary-thread-map "h" 'gnus-summary-hide-thread)
5473 (define-key gnus-summary-thread-map "H" 'gnus-summary-hide-all-threads)
5474 (define-key gnus-summary-thread-map "n" 'gnus-summary-next-thread)
5475 (define-key gnus-summary-thread-map "p" 'gnus-summary-prev-thread)
5476 (define-key gnus-summary-thread-map "u" 'gnus-summary-up-thread)
5477 (define-key gnus-summary-thread-map "d" 'gnus-summary-down-thread)
5478 (define-key gnus-summary-thread-map "#" 'gnus-uu-mark-thread)
5479
5480
5481 (define-prefix-command 'gnus-summary-exit-map)
5482 (define-key gnus-summary-mode-map "Z" 'gnus-summary-exit-map)
5483 (define-key gnus-summary-exit-map "c" 'gnus-summary-catchup-and-exit)
5484 (define-key gnus-summary-exit-map "C" 'gnus-summary-catchup-all-and-exit)
5485 (define-key gnus-summary-exit-map "E" 'gnus-summary-exit-no-update)
5486 (define-key gnus-summary-exit-map "Q" 'gnus-summary-exit)
5487 (define-key gnus-summary-exit-map "Z" 'gnus-summary-exit)
5488 (define-key gnus-summary-exit-map
5489 "n" 'gnus-summary-catchup-and-goto-next-group)
5490 (define-key gnus-summary-exit-map "R" 'gnus-summary-reselect-current-group)
5491 (define-key gnus-summary-exit-map "G" 'gnus-summary-rescan-group)
5492 (define-key gnus-summary-exit-map "N" 'gnus-summary-next-group)
5493 (define-key gnus-summary-exit-map "P" 'gnus-summary-prev-group)
5494
5495
5496 (define-prefix-command 'gnus-summary-article-map)
5497 (define-key gnus-summary-mode-map "A" 'gnus-summary-article-map)
5498 (define-key gnus-summary-article-map " " 'gnus-summary-next-page)
5499 (define-key gnus-summary-article-map "n" 'gnus-summary-next-page)
5500 (define-key gnus-summary-article-map "\177" 'gnus-summary-prev-page)
5501 (define-key gnus-summary-article-map "p" 'gnus-summary-prev-page)
5502 (define-key gnus-summary-article-map "\r" 'gnus-summary-scroll-up)
5503 (define-key gnus-summary-article-map "<" 'gnus-summary-beginning-of-article)
5504 (define-key gnus-summary-article-map ">" 'gnus-summary-end-of-article)
5505 (define-key gnus-summary-article-map "b" 'gnus-summary-beginning-of-article)
5506 (define-key gnus-summary-article-map "e" 'gnus-summary-end-of-article)
5507 (define-key gnus-summary-article-map "^" 'gnus-summary-refer-parent-article)
5508 (define-key gnus-summary-article-map "r" 'gnus-summary-refer-parent-article)
5509 (define-key gnus-summary-article-map "g" 'gnus-summary-show-article)
5510 (define-key gnus-summary-article-map "s" 'gnus-summary-isearch-article)
5511
5512
5513
5514 (define-prefix-command 'gnus-summary-wash-map)
5515 (define-key gnus-summary-mode-map "W" 'gnus-summary-wash-map)
5516
5517 (define-prefix-command 'gnus-summary-wash-hide-map)
5518 (define-key gnus-summary-wash-map "W" 'gnus-summary-wash-hide-map)
5519 (define-key gnus-summary-wash-hide-map "a" 'gnus-article-hide)
5520 (define-key gnus-summary-wash-hide-map "h" 'gnus-article-hide-headers)
5521 (define-key gnus-summary-wash-hide-map "s" 'gnus-article-hide-signature)
5522 (define-key gnus-summary-wash-hide-map "c" 'gnus-article-hide-citation)
5523 (define-key gnus-summary-wash-hide-map
5524 "\C-c" 'gnus-article-hide-citation-maybe)
5525
5526 (define-prefix-command 'gnus-summary-wash-highlight-map)
5527 (define-key gnus-summary-wash-map "H" 'gnus-summary-wash-highlight-map)
5528 (define-key gnus-summary-wash-highlight-map "a" 'gnus-article-highlight)
5529 (define-key gnus-summary-wash-highlight-map
5530 "h" 'gnus-article-highlight-headers)
5531 (define-key gnus-summary-wash-highlight-map
5532 "c" 'gnus-article-highlight-citation)
5533 (define-key gnus-summary-wash-highlight-map
5534 "s" 'gnus-article-highlight-signature)
5535
5536 (define-prefix-command 'gnus-summary-wash-time-map)
5537 (define-key gnus-summary-wash-map "T" 'gnus-summary-wash-time-map)
5538 (define-key gnus-summary-wash-time-map "z" 'gnus-article-date-ut)
5539 (define-key gnus-summary-wash-time-map "u" 'gnus-article-date-ut)
5540 (define-key gnus-summary-wash-time-map "l" 'gnus-article-date-local)
5541 (define-key gnus-summary-wash-time-map "e" 'gnus-article-date-lapsed)
5542
5543 (define-key gnus-summary-wash-map "b" 'gnus-article-add-buttons)
5544 (define-key gnus-summary-wash-map "o" 'gnus-article-treat-overstrike)
5545 (define-key gnus-summary-wash-map "w" 'gnus-article-word-wrap)
5546 (define-key gnus-summary-wash-map "c" 'gnus-article-remove-cr)
5547 (define-key gnus-summary-wash-map "q" 'gnus-article-de-quoted-unreadable)
5548 (define-key gnus-summary-wash-map "f" 'gnus-article-display-x-face)
5549 (define-key gnus-summary-wash-map "l" 'gnus-summary-stop-page-breaking)
5550 (define-key gnus-summary-wash-map "r" 'gnus-summary-caesar-message)
5551 (define-key gnus-summary-wash-map "t" 'gnus-summary-toggle-header)
5552 (define-key gnus-summary-wash-map "m" 'gnus-summary-toggle-mime)
5553
5554
5555 (define-prefix-command 'gnus-summary-help-map)
5556 (define-key gnus-summary-mode-map "H" 'gnus-summary-help-map)
5557 (define-key gnus-summary-help-map "v" 'gnus-version)
5558 (define-key gnus-summary-help-map "f" 'gnus-summary-fetch-faq)
5559 (define-key gnus-summary-help-map "d" 'gnus-summary-describe-group)
5560 (define-key gnus-summary-help-map "h" 'gnus-summary-describe-briefly)
5561 (define-key gnus-summary-help-map "i" 'gnus-info-find-node)
5562
5563
5564 (define-prefix-command 'gnus-summary-backend-map)
5565 (define-key gnus-summary-mode-map "B" 'gnus-summary-backend-map)
5566 (define-key gnus-summary-backend-map "e" 'gnus-summary-expire-articles)
5567 (define-key gnus-summary-backend-map "\M-\C-e"
5568 'gnus-summary-expire-articles-now)
5569 (define-key gnus-summary-backend-map "\177" 'gnus-summary-delete-article)
5570 (define-key gnus-summary-backend-map "m" 'gnus-summary-move-article)
5571 (define-key gnus-summary-backend-map "r" 'gnus-summary-respool-article)
5572 (define-key gnus-summary-backend-map "w" 'gnus-summary-edit-article)
5573 (define-key gnus-summary-backend-map "c" 'gnus-summary-copy-article)
5574 (define-key gnus-summary-backend-map "q" 'gnus-summary-fancy-query)
5575 (define-key gnus-summary-backend-map "i" 'gnus-summary-import-article)
5576
5577
5578 (define-prefix-command 'gnus-summary-save-map)
5579 (define-key gnus-summary-mode-map "O" 'gnus-summary-save-map)
5580 (define-key gnus-summary-save-map "o" 'gnus-summary-save-article)
5581 (define-key gnus-summary-save-map "m" 'gnus-summary-save-article-mail)
5582 (define-key gnus-summary-save-map "r" 'gnus-summary-save-article-rmail)
5583 (define-key gnus-summary-save-map "f" 'gnus-summary-save-article-file)
5584 (define-key gnus-summary-save-map "h" 'gnus-summary-save-article-folder)
5585 (define-key gnus-summary-save-map "v" 'gnus-summary-save-article-vm)
5586 (define-key gnus-summary-save-map "p" 'gnus-summary-pipe-output)
5587; (define-key gnus-summary-save-map "s" 'gnus-soup-add-article)
5588
5589 (define-key gnus-summary-mode-map "X" 'gnus-uu-extract-map)
5590
5591 (define-key gnus-summary-mode-map "\M-&" 'gnus-summary-universal-argument)
5592; (define-key gnus-summary-various-map "\C-s" 'gnus-summary-search-article-forward)
5593; (define-key gnus-summary-various-map "\C-r" 'gnus-summary-search-article-backward)
5594; (define-key gnus-summary-various-map "r" 'gnus-summary-refer-article)
5595; (define-key gnus-summary-various-map "&" 'gnus-summary-execute-command)
5596; (define-key gnus-summary-various-map "T" 'gnus-summary-toggle-truncation)
5597; (define-key gnus-summary-various-map "e" 'gnus-summary-expand-window)
5598 (define-key gnus-summary-article-map "D" 'gnus-summary-enter-digest-group)
5599; (define-key gnus-summary-various-map "k" 'gnus-summary-edit-local-kill)
5600; (define-key gnus-summary-various-map "K" 'gnus-summary-edit-global-kill)
5601
5602 (define-key gnus-summary-mode-map "V" 'gnus-summary-score-map)
5603
5604; (define-prefix-command 'gnus-summary-sort-map)
5605; (define-key gnus-summary-various-map "s" 'gnus-summary-sort-map)
5606; (define-key gnus-summary-sort-map "n" 'gnus-summary-sort-by-number)
5607; (define-key gnus-summary-sort-map "a" 'gnus-summary-sort-by-author)
5608; (define-key gnus-summary-sort-map "s" 'gnus-summary-sort-by-subject)
5609; (define-key gnus-summary-sort-map "d" 'gnus-summary-sort-by-date)
5610; (define-key gnus-summary-sort-map "i" 'gnus-summary-sort-by-score)
5611
5612 (define-key gnus-summary-mode-map "I" 'gnus-summary-increase-score)
5613 (define-key gnus-summary-mode-map "L" 'gnus-summary-lower-score)
ef97d5a2 5614 )
41487370
LMI
5615
5616
ef97d5a2 5617\f
b027f415 5618
41487370
LMI
5619(defun gnus-summary-mode (&optional group)
5620 "Major mode for reading articles.
5621
5622All normal editing commands are switched off.
5623\\<gnus-summary-mode-map>
5624Each line in this buffer represents one article. To read an
5625article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards
5626and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]',
5627respectively.
5628
5629You can also post articles and send mail from this buffer. To
5630follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author
5631of an article, type `\\[gnus-summary-reply]'.
5632
5633There are approx. one gazillion commands you can execute in this
5634buffer; read the info pages for more information (`\\[gnus-info-find-node]').
5635
5636The following commands are available:
5637
5638\\{gnus-summary-mode-map}"
745bc783 5639 (interactive)
41487370 5640 (if gnus-visual (gnus-summary-make-menu-bar))
745bc783 5641 (kill-all-local-variables)
41487370
LMI
5642 (let ((locals gnus-summary-local-variables))
5643 (while locals
5644 (if (consp (car locals))
5645 (progn
5646 (make-local-variable (car (car locals)))
5647 (set (car (car locals)) (eval (cdr (car locals)))))
5648 (make-local-variable (car locals))
5649 (set (car locals) nil))
5650 (setq locals (cdr locals))))
5651 (gnus-make-thread-indent-array)
a828a776 5652 (gnus-simplify-mode-line)
b027f415
RS
5653 (setq major-mode 'gnus-summary-mode)
5654 (setq mode-name "Summary")
745bc783 5655 (make-local-variable 'minor-mode-alist)
b027f415 5656 (use-local-map gnus-summary-mode-map)
41487370 5657 (buffer-disable-undo (current-buffer))
745bc783 5658 (setq buffer-read-only t) ;Disable modification
41487370 5659 (setq truncate-lines t)
745bc783
JB
5660 (setq selective-display t)
5661 (setq selective-display-ellipses t) ;Display `...'
41487370
LMI
5662 (setq buffer-display-table gnus-summary-display-table)
5663 (setq gnus-newsgroup-name group)
b027f415
RS
5664 (run-hooks 'gnus-summary-mode-hook))
5665
41487370
LMI
5666(defun gnus-summary-make-display-table ()
5667 ;; Change the display table. Odd characters have a tendency to mess
5668 ;; up nicely formatted displays - we make all possible glyphs
5669 ;; display only a single character.
5670
5671 ;; We start from the standard display table, if any.
5672 (setq gnus-summary-display-table
5673 (or (copy-sequence standard-display-table)
5674 (make-display-table)))
5675 ;; Nix out all the control chars...
5676 (let ((i 32))
5677 (while (>= (setq i (1- i)) 0)
5678 (aset gnus-summary-display-table i [??])))
5679 ;; ... but not newline and cr, of course. (cr is necessary for the
5680 ;; selective display).
5681 (aset gnus-summary-display-table ?\n nil)
5682 (aset gnus-summary-display-table ?\r nil)
5683 ;; We nix out any glyphs over 126 that are not set already.
5684 (let ((i 256))
5685 (while (>= (setq i (1- i)) 127)
5686 ;; Only modify if the entry is nil.
5687 (or (aref gnus-summary-display-table i)
5688 (aset gnus-summary-display-table i [??])))))
5689
5690(defun gnus-summary-clear-local-variables ()
5691 (let ((locals gnus-summary-local-variables))
5692 (while locals
5693 (if (consp (car locals))
5694 (and (vectorp (car (car locals)))
5695 (set (car (car locals)) nil))
5696 (and (vectorp (car locals))
5697 (set (car locals) nil)))
5698 (setq locals (cdr locals)))))
5699
5700;; Some summary mode macros.
5701
5702;; Return a header specified by a NUMBER.
5703(defun gnus-get-header-by-number (number)
745bc783 5704 (save-excursion
41487370
LMI
5705 (set-buffer gnus-summary-buffer)
5706 (or gnus-newsgroup-headers-hashtb-by-number
5707 (gnus-make-headers-hashtable-by-number))
5708 (gnus-gethash (int-to-string number)
5709 gnus-newsgroup-headers-hashtb-by-number)))
745bc783 5710
41487370
LMI
5711;; Fast version of the function above.
5712(defmacro gnus-get-header-by-num (number)
5713 (` (gnus-gethash (int-to-string (, number))
5714 gnus-newsgroup-headers-hashtb-by-number)))
745bc783 5715
41487370 5716(defmacro gnus-summary-search-forward (&optional unread subject backward)
745bc783 5717 "Search for article forward.
41487370
LMI
5718If UNREAD is non-nil, only unread articles are selected.
5719If SUBJECT is non-nil, the article which has the same subject will be
5720searched for.
5721If BACKWARD is non-nil, the search will be performed backwards instead."
5722 (` (gnus-summary-search-subject (, backward) (, unread) (, subject))))
745bc783 5723
41487370 5724(defmacro gnus-summary-search-backward (&optional unread subject)
745bc783 5725 "Search for article backward.
b027f415
RS
5726If 1st optional argument UNREAD is non-nil, only unread article is selected.
5727If 2nd optional argument SUBJECT is non-nil, the article which has
745bc783 5728the same subject will be searched for."
41487370
LMI
5729 (` (gnus-summary-search-forward (, unread) (, subject) t)))
5730
5731(defmacro gnus-summary-article-number (&optional number-or-nil)
5732 "The article number of the article on the current line.
5733If there isn's an article number here, then we return the current
5734article number."
5735 (if number-or-nil
5736 '(get-text-property (gnus-point-at-bol) 'gnus-number)
5737 '(or (get-text-property (gnus-point-at-bol) 'gnus-number)
5738 gnus-current-article)))
5739
5740(defmacro gnus-summary-thread-level ()
5741 "The thread level of the article on the current line."
5742 '(or (get-text-property (gnus-point-at-bol) 'gnus-level)
5743 0))
5744
5745(defmacro gnus-summary-article-mark ()
5746 "The mark on the current line."
5747 '(get-text-property (gnus-point-at-bol) 'gnus-mark))
745bc783 5748
b027f415 5749(defun gnus-summary-subject-string ()
745bc783 5750 "Return current subject string or nil if nothing."
41487370
LMI
5751 (let ((article (gnus-summary-article-number))
5752 header)
5753 (and article
5754 (setq header (gnus-get-header-by-num article))
5755 (vectorp header)
5756 (mail-header-subject header))))
745bc783 5757
41487370 5758;; Various summary mode internalish functions.
745bc783 5759
41487370
LMI
5760(defun gnus-mouse-pick-article (e)
5761 (interactive "e")
5762 (mouse-set-point e)
5763 (gnus-summary-next-page nil t))
745bc783 5764
41487370
LMI
5765(defun gnus-summary-setup-buffer (group)
5766 "Initialize summary buffer."
5767 (let ((buffer (concat "*Summary " group "*")))
5768 (if (get-buffer buffer)
745bc783 5769 (progn
41487370
LMI
5770 (set-buffer buffer)
5771 (not gnus-newsgroup-begin))
5772 ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
5773 (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer)))
5774 (gnus-add-current-to-buffer-list)
5775 (gnus-summary-mode group)
5776 (and gnus-carpal (gnus-carpal-setup-buffer 'summary))
5777 (setq gnus-newsgroup-name group)
5778 t)))
5779
5780(defun gnus-set-global-variables ()
5781 ;; Set the global equivalents of the summary buffer-local variables
5782 ;; to the latest values they had. These reflect the summary buffer
5783 ;; that was in action when the last article was fetched.
5784 (if (eq major-mode 'gnus-summary-mode)
5785 (progn
5786 (setq gnus-summary-buffer (current-buffer))
5787 (let ((name gnus-newsgroup-name)
5788 (marked gnus-newsgroup-marked)
5789 (unread gnus-newsgroup-unreads)
5790 (headers gnus-current-headers)
5791 (score-file gnus-current-score-file))
5792 (save-excursion
5793 (set-buffer gnus-group-buffer)
5794 (setq gnus-newsgroup-name name)
5795 (setq gnus-newsgroup-marked marked)
5796 (setq gnus-newsgroup-unreads unread)
5797 (setq gnus-current-headers headers)
5798 (setq gnus-current-score-file score-file))))))
5799
5800(defun gnus-summary-insert-dummy-line (sformat subject number)
5801 (if (not sformat)
5802 (setq sformat gnus-summary-dummy-line-format-spec))
5803 (let (b)
5804 (beginning-of-line)
5805 (setq b (point))
5806 (insert (eval sformat))
5807 (add-text-properties
5808 b (1+ b)
5809 (list 'gnus-number number
5810 'gnus-mark gnus-dummy-mark
5811 'gnus-level 0))))
5812
5813(defvar gnus-thread-indent-array nil)
5814(defvar gnus-thread-indent-array-level gnus-thread-indent-level)
5815(defun gnus-make-thread-indent-array ()
5816 (let ((n 200))
5817 (if (and gnus-thread-indent-array
5818 (= gnus-thread-indent-level gnus-thread-indent-array-level))
5819 nil
5820 (setq gnus-thread-indent-array (make-vector 201 "")
5821 gnus-thread-indent-array-level gnus-thread-indent-level)
5822 (while (>= n 0)
5823 (aset gnus-thread-indent-array n
5824 (make-string (* n gnus-thread-indent-level) ? ))
5825 (setq n (1- n))))))
5826
5827(defun gnus-summary-insert-line
5828 (sformat header level current unread replied expirable subject-or-nil
5829 &optional dummy score process)
5830 (or sformat (setq sformat gnus-summary-line-format-spec))
5831 (let* ((indentation (aref gnus-thread-indent-array level))
5832 (lines (mail-header-lines header))
5833 (score (or score gnus-summary-default-score 0))
5834 (score-char
5835 (if (or (null gnus-summary-default-score)
5836 (<= (abs (- score gnus-summary-default-score))
5837 gnus-summary-zcore-fuzz)) ?
5838 (if (< score gnus-summary-default-score)
5839 gnus-score-below-mark gnus-score-over-mark)))
5840 (replied (cond (process gnus-process-mark)
5841 (replied gnus-replied-mark)
5842 (t gnus-unread-mark)))
5843 (from (mail-header-from header))
5844 (name (cond
5845 ((string-match "(.+)" from)
5846 (substring from (1+ (match-beginning 0)) (1- (match-end 0))))
5847 ((string-match "<[^>]+> *$" from)
5848 (let ((beg (match-beginning 0)))
5849 (or (and (string-match "^\"[^\"]*\"" from)
5850 (substring from (1+ (match-beginning 0))
5851 (1- (match-end 0))))
5852 (substring from 0 beg))))
5853 (t from)))
5854 (subject (mail-header-subject header))
5855 (number (mail-header-number header))
5856 (opening-bracket (if dummy ?\< ?\[))
5857 (closing-bracket (if dummy ?\> ?\]))
5858 (buffer-read-only nil)
5859 (b (progn (beginning-of-line) (point))))
5860 (or (numberp lines) (setq lines 0))
5861 (insert (eval sformat))
5862 (add-text-properties
5863 b (1+ b) (list 'gnus-number number
5864 'gnus-mark (or unread gnus-unread-mark)
5865 'gnus-level level))))
5866
5867(defun gnus-summary-update-line (&optional dont-update)
5868 ;; Update summary line after change.
5869 (or (not gnus-summary-default-score)
5870 gnus-summary-inhibit-highlight
5871 (let ((gnus-summary-inhibit-highlight t)
5872 (article (gnus-summary-article-number)))
745bc783 5873 (progn
41487370
LMI
5874 (or dont-update
5875 (if (and gnus-summary-mark-below
5876 (< (gnus-summary-article-score)
5877 gnus-summary-mark-below))
5878 (and (not (memq article gnus-newsgroup-marked))
5879 (not (memq article gnus-newsgroup-dormant))
5880 (memq article gnus-newsgroup-unreads)
5881 (gnus-summary-mark-article-as-read gnus-low-score-mark))
5882 (and (eq (gnus-summary-article-mark) gnus-low-score-mark)
5883 (gnus-summary-mark-article-as-unread gnus-unread-mark))))
5884 (and gnus-visual
5885 (run-hooks 'gnus-summary-update-hook))))))
5886
5887(defun gnus-summary-update-lines (&optional beg end)
5888 ;; Mark article as read (or not) by taking into account scores.
5889 (let ((beg (or beg (point-min)))
5890 (end (or end (point-max))))
5891 (if (or (not gnus-summary-default-score)
5892 gnus-summary-inhibit-highlight)
5893 ()
5894 (let ((gnus-summary-inhibit-highlight t)
5895 article)
5896 (save-excursion
5897 (set-buffer gnus-summary-buffer)
5898 (goto-char beg)
5899 (beginning-of-line)
5900 (while (and (not (eobp)) (< (point) end))
5901 (if (and gnus-summary-mark-below
5902 (< (or (cdr (assq
5903 (setq article (get-text-property
5904 (point) 'gnus-number))
5905 gnus-newsgroup-scored))
5906 gnus-summary-default-score 0)
5907 gnus-summary-mark-below))
5908 ;; We want to possibly mark it as read...
5909 (and (not (memq article gnus-newsgroup-marked))
5910 (not (memq article gnus-newsgroup-dormant))
5911 (memq article gnus-newsgroup-unreads)
5912 (gnus-summary-mark-article-as-read gnus-low-score-mark))
5913 ;; We want to possibly mark it as unread.
5914 (and (eq (get-text-property (point) 'gnus-mark)
5915 gnus-low-score-mark)
5916 (gnus-summary-mark-article-as-unread gnus-unread-mark)))
5917 ;; Do the visual highlights at the same time.
5918 (and gnus-visual (run-hooks 'gnus-summary-update-hook))
5919 (forward-line 1)))))))
5920
5921(defvar gnus-tmp-gathered nil)
5922
5923(defun gnus-summary-number-of-articles-in-thread (thread &optional char)
5924 ;; Sum up all elements (and sub-elements) in a list.
5925 (let* ((number
5926 ;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>.
5927 (if (and (consp thread) (cdr thread))
5928 (apply
5929 '+ 1 (mapcar
5930 'gnus-summary-number-of-articles-in-thread
5931 (cdr thread)))
5932 1)))
5933 (if char
5934 (if (> number 1) gnus-not-empty-thread-mark
5935 gnus-empty-thread-mark)
5936 number)))
5937
5938(defun gnus-summary-read-group
5939 (group &optional show-all no-article kill-buffer)
5940 "Start reading news in newsgroup GROUP.
5941If SHOW-ALL is non-nil, already read articles are also listed.
5942If NO-ARTICLE is non-nil, no article is selected initially."
5943 (gnus-message 5 "Retrieving newsgroup: %s..." group)
5944 (let* ((new-group (gnus-summary-setup-buffer group))
5945 (quit-config (gnus-group-quit-config group))
5946 (did-select (and new-group (gnus-select-newsgroup group show-all))))
5947 (cond
5948 ((not new-group)
5949 (gnus-set-global-variables)
5950 (gnus-kill-buffer kill-buffer)
5951 (gnus-configure-windows 'summary 'force)
5952 (gnus-set-mode-line 'summary)
5953 (gnus-summary-position-cursor)
5954 (message "")
5955 t)
5956 ((null did-select)
5957 (and (eq major-mode 'gnus-summary-mode)
5958 (not (equal (current-buffer) kill-buffer))
5959 (progn
5960 (kill-buffer (current-buffer))
5961 (if (not quit-config)
5962 (progn
5963 (set-buffer gnus-group-buffer)
5964 (gnus-group-jump-to-group group)
5965 (gnus-group-next-unread-group 1))
5966 (if (not (buffer-name (car quit-config)))
5967 (gnus-configure-windows 'group 'force)
5968 (set-buffer (car quit-config))
5969 (and (eq major-mode 'gnus-summary-mode)
5970 (gnus-set-global-variables))
5971 (gnus-configure-windows (cdr quit-config))))))
5972 (message "Can't select group")
5973 nil)
5974 ((eq did-select 'quit)
5975 (and (eq major-mode 'gnus-summary-mode)
5976 (not (equal (current-buffer) kill-buffer))
5977 (kill-buffer (current-buffer)))
5978 (gnus-kill-buffer kill-buffer)
5979 (if (not quit-config)
5980 (progn
5981 (set-buffer gnus-group-buffer)
5982 (gnus-group-jump-to-group group)
5983 (gnus-group-next-unread-group 1)
5984 (gnus-configure-windows 'group 'force))
5985 (if (not (buffer-name (car quit-config)))
5986 (gnus-configure-windows 'group 'force)
5987 (set-buffer (car quit-config))
5988 (and (eq major-mode 'gnus-summary-mode)
5989 (gnus-set-global-variables))
5990 (gnus-configure-windows (cdr quit-config))))
5991 (signal 'quit nil))
5992 (t
5993 (gnus-set-global-variables)
5994 ;; Save the active value in effect when the group was entered.
5995 (setq gnus-newsgroup-active
5996 (gnus-copy-sequence
5997 (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))
5998 ;; You can change the subjects in this hook.
5999 (run-hooks 'gnus-select-group-hook)
6000 ;; Do score processing.
6001 (and gnus-use-scoring (gnus-possibly-score-headers))
6002 (gnus-update-format-specifications)
6003 ;; Generate the summary buffer.
6004 (gnus-summary-prepare)
6005 (if (zerop (buffer-size))
6006 (cond (gnus-newsgroup-dormant
6007 (gnus-summary-show-all-dormant))
6008 ((and gnus-newsgroup-scored show-all)
6009 (gnus-summary-show-all-expunged))))
6010 ;; Function `gnus-apply-kill-file' must be called in this hook.
6011 (run-hooks 'gnus-apply-kill-hook)
6012 (if (zerop (buffer-size))
6013 (progn
6014 ;; This newsgroup is empty.
6015 (gnus-summary-catchup-and-exit nil t) ;Without confirmations.
6016 (gnus-message 6 "No unread news")
6017 (gnus-kill-buffer kill-buffer)
6018 nil)
6019 ;;(save-excursion
6020 ;; (if kill-buffer
6021 ;; (let ((gnus-summary-buffer kill-buffer))
6022 ;; (gnus-configure-windows 'group))))
6023 ;; Hide conversation thread subtrees. We cannot do this in
6024 ;; gnus-summary-prepare-hook since kill processing may not
6025 ;; work with hidden articles.
6026 (and gnus-show-threads
6027 gnus-thread-hide-subtree
6028 (gnus-summary-hide-all-threads))
6029 ;; Show first unread article if requested.
6030 (goto-char (point-min))
6031 (if (and (not no-article)
6032 gnus-auto-select-first
6033 (gnus-summary-first-unread-article))
6034 ()
6035 (gnus-configure-windows 'summary 'force))
6036 (gnus-set-mode-line 'summary)
6037 (gnus-summary-position-cursor)
6038 ;; If in async mode, we send some info to the backend.
6039 (and gnus-newsgroup-async
6040 (setq gnus-newsgroup-threads (nreverse gnus-newsgroup-threads))
6041 (gnus-request-asynchronous
6042 gnus-newsgroup-name
6043 (if (and gnus-asynchronous-article-function
6044 (fboundp gnus-asynchronous-article-function))
6045 (funcall gnus-asynchronous-article-function
6046 gnus-newsgroup-threads)
6047 gnus-newsgroup-threads)))
6048 (gnus-kill-buffer kill-buffer)
6049 (if (not (get-buffer-window gnus-group-buffer))
6050 ()
b94ae5f7 6051 ;; gotta use windows, because recenter does weird stuff if
41487370
LMI
6052 ;; the current buffer ain't the displayed window.
6053 (let ((owin (selected-window)))
6054 (select-window (get-buffer-window gnus-group-buffer))
6055 (and (gnus-group-goto-group group)
6056 (recenter))
6057 (select-window owin))))
6058 t))))
6059
6060(defun gnus-summary-prepare ()
6061 ;; Generate the summary buffer.
6062 (let ((buffer-read-only nil))
6063 (erase-buffer)
6064 (gnus-summary-prepare-threads
6065 (if gnus-show-threads
6066 (gnus-gather-threads
6067 (gnus-sort-threads
6068 (if (and gnus-summary-expunge-below
6069 (not gnus-fetch-old-headers))
6070 (gnus-make-threads-and-expunge)
6071 (gnus-make-threads))))
6072 gnus-newsgroup-headers)
6073 'cull)
6074 (gnus-summary-update-lines)
6075 ;; Create the header hashtb.
6076 (gnus-make-headers-hashtable-by-number)
6077 ;; Call hooks for modifying summary buffer.
6078 ;; Suggested by sven@tde.LTH.Se (Sven Mattisson).
6079 (goto-char (point-min))
6080 (run-hooks 'gnus-summary-prepare-hook)))
6081
6082(defun gnus-gather-threads (threads)
6083 "Gather threads that have lost their roots."
6084 (if (not gnus-summary-make-false-root)
6085 threads
6086 (let ((hashtb (gnus-make-hashtable 1023))
6087 (prev threads)
6088 (result threads)
6089 subject hthread whole-subject)
6090 (while threads
6091 (setq whole-subject
6092 (setq subject (mail-header-subject (car (car threads)))))
6093 (if gnus-summary-gather-subject-limit
6094 (or (and (numberp gnus-summary-gather-subject-limit)
6095 (> (length subject) gnus-summary-gather-subject-limit)
6096 (setq subject
6097 (substring subject 0
6098 gnus-summary-gather-subject-limit)))
6099 (and (eq 'fuzzy gnus-summary-gather-subject-limit)
6100 (setq subject (gnus-simplify-subject-fuzzy subject))))
6101 (setq subject (gnus-simplify-subject-re subject)))
6102 (if (setq hthread
6103 (gnus-gethash subject hashtb))
6104 (progn
6105 (or (stringp (car (car hthread)))
6106 (setcar hthread (list whole-subject (car hthread))))
6107 (setcdr (car hthread) (nconc (cdr (car hthread))
6108 (list (car threads))))
6109 (setcdr prev (cdr threads))
6110 (setq threads prev))
6111 (gnus-sethash subject threads hashtb))
6112 (setq prev threads)
6113 (setq threads (cdr threads)))
6114 result)))
6115
6116(defun gnus-make-threads ()
6117 ;; This function takes the dependencies already made by
6118 ;; `gnus-get-newsgroup-headers' and builds the trees. First we go
b94ae5f7 6119 ;; through the dependencies in the hash table and finds all the
41487370
LMI
6120 ;; roots. Roots do not refer back to any valid articles.
6121 (gnus-message 6 "Threading...")
6122 (let (roots new-roots)
6123 (and gnus-fetch-old-headers
6124 (eq gnus-headers-retrieved-by 'nov)
6125 (gnus-build-old-threads))
6126 (mapatoms
6127 (lambda (refs)
6128 (if (not (car (symbol-value refs)))
6129 (setq roots (append (cdr (symbol-value refs)) roots))
6130 ;; Ok, these refer back to valid articles, but if
6131 ;; `gnus-thread-ignore-subject' is nil, we have to check that
6132 ;; the root has the same subject as its children. The children
6133 ;; that do not are made into roots and removed from the list
6134 ;; of children.
6135 (or gnus-thread-ignore-subject
6136 (let* ((prev (symbol-value refs))
6137 (subject (gnus-simplify-subject-re
6138 (mail-header-subject (car prev))))
6139 (headers (cdr prev)))
6140 (while headers
6141 (if (not (string= subject
6142 (gnus-simplify-subject-re
6143 (mail-header-subject (car headers)))))
6144 (progn
6145 (setq new-roots (cons (car headers) new-roots))
6146 (setcdr prev (cdr headers)))
6147 (setq prev headers))
6148 (setq headers (cdr headers)))))))
6149 gnus-newsgroup-dependencies)
6150
6151 ;; We enter the new roots into the dependencies structure to
6152 ;; ensure that any possible later thread-regeneration will be
6153 ;; possible.
6154 (let ((r new-roots))
6155 (while r
6156 (gnus-sethash (concat (mail-header-id (car r)) ".boo")
6157 (list nil (car r)) gnus-newsgroup-dependencies)
6158 (setq r (cdr r))))
6159
6160 (setq roots (nconc new-roots roots))
6161
6162 (prog1
6163 (mapcar 'gnus-trim-thread
6164 (apply 'append
6165 (mapcar 'gnus-cut-thread
6166 (mapcar 'gnus-make-sub-thread roots))))
6167 (gnus-message 6 "Threading...done"))))
6168
6169
6170(defun gnus-make-threads-and-expunge ()
6171 ;; This function takes the dependencies already made by
6172 ;; `gnus-get-newsgroup-headers' and builds the trees. First we go
b94ae5f7 6173 ;; through the dependencies in the hash table and finds all the
41487370
LMI
6174 ;; roots. Roots do not refer back to any valid articles.
6175 (gnus-message 6 "Threading...")
6176 (let ((default (or gnus-summary-default-score 0))
6177 (below gnus-summary-expunge-below)
6178 roots article new-roots)
6179 (and gnus-fetch-old-headers
6180 (eq gnus-headers-retrieved-by 'nov)
6181 (gnus-build-old-threads))
6182 (mapatoms
6183 (lambda (refs)
6184 (if (not (car (symbol-value refs)))
6185 ;; These articles do not refer back to any other articles -
6186 ;; they are roots.
6187 (let ((headers (cdr (symbol-value refs))))
6188 ;; We weed out the low-scored articles.
6189 (while headers
6190 (if (not (< (or (cdr (assq (mail-header-number (car headers))
6191 gnus-newsgroup-scored)) default)
6192 below))
6193 ;; It is over.
6194 (setq roots (cons (car headers) roots))
6195 ;; It is below, so we mark it as read.
6196 (setq gnus-newsgroup-unreads
6197 (delq (mail-header-number (car headers))
6198 gnus-newsgroup-unreads))
6199 (setq gnus-newsgroup-reads
6200 (cons (cons (mail-header-number (car headers))
6201 gnus-low-score-mark)
6202 gnus-newsgroup-reads)))
6203 (setq headers (cdr headers))))
6204 ;; Ok, these refer back to valid articles, but if
6205 ;; `gnus-thread-ignore-subject' is nil, we have to check that
6206 ;; the root has the same subject as its children. The children
6207 ;; that do not are made into roots and removed from the list
6208 ;; of children.
6209 (or gnus-thread-ignore-subject
6210 (let* ((prev (symbol-value refs))
6211 (subject (gnus-simplify-subject-re
6212 (mail-header-subject (car prev))))
6213 (headers (cdr prev)))
6214 (while headers
6215 (if (not (string= subject
6216 (gnus-simplify-subject-re
6217 (mail-header-subject (car headers)))))
6218 (progn
6219 (if (not (< (or (cdr (assq (mail-header-number
6220 (car headers))
6221 gnus-newsgroup-scored))
6222 default) below))
6223 (setq new-roots (cons (car headers) new-roots))
6224 (setq gnus-newsgroup-unreads
6225 (delq (mail-header-number (car headers))
6226 gnus-newsgroup-unreads))
6227 (setq gnus-newsgroup-reads
6228 (cons (cons (mail-header-number (car headers))
6229 gnus-low-score-mark)
6230 gnus-newsgroup-reads)))
6231 (setcdr prev (cdr headers)))
6232 (setq prev headers))
6233 (setq headers (cdr headers)))))
6234 ;; If this article is expunged, some of the children might be
6235 ;; roots.
6236 (if (< (or (cdr (assq (mail-header-number (car (symbol-value refs)))
6237 gnus-newsgroup-scored)) default)
6238 below)
6239 (let* ((prev (symbol-value refs))
6240 (headers (cdr prev)))
6241 (while headers
6242 (setq article (mail-header-number (car headers)))
6243 (if (not (< (or (cdr (assq article gnus-newsgroup-scored))
6244 default) below))
6245 (progn (setq new-roots (cons (car headers) new-roots))
6246 (setq prev headers))
6247 (setq gnus-newsgroup-unreads
6248 (delq article gnus-newsgroup-unreads))
6249 (setq gnus-newsgroup-reads
6250 (cons (cons article gnus-low-score-mark)
6251 gnus-newsgroup-reads))
6252 (setcdr prev (cdr headers)))
6253 (setq headers (cdr headers))))
6254 ;; It was not expunged, but we look at expunged children.
6255 (let* ((prev (symbol-value refs))
6256 (headers (cdr prev))
6257 article)
6258 (while headers
6259 (setq article (mail-header-number (car headers)))
6260 (if (not (< (or (cdr (assq article gnus-newsgroup-scored))
6261 default) below))
6262 (setq prev headers)
6263 (setq gnus-newsgroup-unreads
6264 (delq article gnus-newsgroup-unreads))
6265 (setq gnus-newsgroup-reads
6266 (cons (cons article gnus-low-score-mark)
6267 gnus-newsgroup-reads))
6268 (setcdr prev (cdr headers)))
6269 (setq headers (cdr headers)))))))
6270 gnus-newsgroup-dependencies)
6271
6272 ;; We enter the new roots into the dependencies structure to
6273 ;; ensure that any possible later thread-regeneration will be
6274 ;; possible.
6275 (let ((r new-roots))
6276 (while r
6277 (gnus-sethash (concat (mail-header-id (car r)) ".boo")
6278 (list nil (car r)) gnus-newsgroup-dependencies)
6279 (setq r (cdr r))))
6280
6281 (setq roots (nconc new-roots roots))
6282
6283 (prog1
6284 (mapcar 'gnus-trim-thread
6285 (apply 'append
6286 (mapcar 'gnus-cut-thread
6287 (mapcar 'gnus-make-sub-thread roots))))
6288 (gnus-message 6 "Threading...done"))))
6289
6290
6291(defun gnus-cut-thread (thread)
6292 ;; Remove leaf dormant or ancient articles from THREAD.
6293 (let ((head (car thread))
6294 (tail (apply 'append (mapcar 'gnus-cut-thread (cdr thread)))))
6295 (if (and (null tail)
6296 (let ((number (mail-header-number head)))
6297 (or (memq number gnus-newsgroup-ancient)
6298 (memq number gnus-newsgroup-dormant)
6299 (and gnus-summary-expunge-below
6300 (eq gnus-fetch-old-headers 'some)
6301 (< (or (cdr (assq number gnus-newsgroup-scored))
6302 gnus-summary-default-score 0)
6303 gnus-summary-expunge-below)
6304 (progn
6305 (setq gnus-newsgroup-unreads
6306 (delq number gnus-newsgroup-unreads))
6307 (setq gnus-newsgroup-reads
6308 (cons (cons number gnus-low-score-mark)
6309 gnus-newsgroup-reads))
6310 t)))))
6311 nil
6312 (list (cons head tail)))))
6313
6314(defun gnus-trim-thread (thread)
6315 ;; Remove root ancient articles with only one child from THREAD.
6316 (if (and (eq gnus-fetch-old-headers 'some)
6317 (memq (mail-header-number (car thread)) gnus-newsgroup-ancient)
6318 (= (length thread) 2))
6319 (gnus-trim-thread (nth 1 thread))
6320 thread))
6321
6322(defun gnus-make-sub-thread (root)
6323 ;; This function makes a sub-tree for a node in the tree.
6324 (let ((children (reverse (cdr (gnus-gethash (downcase (mail-header-id root))
6325 gnus-newsgroup-dependencies)))))
6326 (cons root (mapcar 'gnus-make-sub-thread children))))
6327
6328(defun gnus-build-old-threads ()
6329 ;; Look at all the articles that refer back to old articles, and
6330 ;; fetch the headers for the articles that aren't there. This will
6331 ;; build complete threads - if the roots haven't been expired by the
6332 ;; server, that is.
6333 (let (id heads)
6334 (mapatoms
6335 (lambda (refs)
6336 (if (not (car (symbol-value refs)))
6337 (progn
6338 (setq heads (cdr (symbol-value refs)))
6339 (while heads
6340 (if (not (memq (mail-header-number (car heads))
6341 gnus-newsgroup-dormant))
6342 (progn
6343 (setq id (symbol-name refs))
6344 (while (and (setq id (gnus-build-get-header id))
6345 (not (car (gnus-gethash
6346 id gnus-newsgroup-dependencies)))))
6347 (setq heads nil))
6348 (setq heads (cdr heads)))))))
6349 gnus-newsgroup-dependencies)))
6350
6351(defun gnus-build-get-header (id)
6352 ;; Look through the buffer of NOV lines and find the header to
6353 ;; ID. Enter this line into the dependencies hash table, and return
6354 ;; the id of the parent article (if any).
6355 (let ((deps gnus-newsgroup-dependencies)
6356 found header)
6357 (prog1
6358 (save-excursion
6359 (set-buffer nntp-server-buffer)
6360 (goto-char (point-min))
6361 (while (and (not found) (search-forward id nil t))
6362 (beginning-of-line)
6363 (setq found (looking-at
6364 (format "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t%s"
6365 (regexp-quote id))))
6366 (or found (beginning-of-line 2)))
6367 (if found
6368 (let (ref)
6369 (beginning-of-line)
6370 (and
6371 (setq header (gnus-nov-parse-line
6372 (read (current-buffer)) deps))
6373 (setq ref (mail-header-references header))
6374 (string-match "\\(<[^>]+>\\) *$" ref)
6375 (substring ref (match-beginning 1) (match-end 1))))))
6376 (and header
6377 (setq gnus-newsgroup-headers (cons header gnus-newsgroup-headers)
6378 gnus-newsgroup-ancient (cons (mail-header-number header)
6379 gnus-newsgroup-ancient))))))
6380
6381;; Re-build the thread containing ID.
6382(defun gnus-rebuild-thread (id)
6383 (let ((dep gnus-newsgroup-dependencies)
6384 (buffer-read-only nil)
6385 parent headers refs thread art)
6386 (while (and id (setq headers
6387 (car (setq art (gnus-gethash (downcase id) dep)))))
6388 (setq parent art)
6389 (setq id (and (setq refs (mail-header-references headers))
6390 (string-match "\\(<[^>]+>\\) *$" refs)
6391 (substring refs (match-beginning 1) (match-end 1)))))
6392 (setq thread (gnus-make-sub-thread (car parent)))
6393 (gnus-rebuild-remove-articles thread)
6394 (let ((beg (point)))
6395 (gnus-summary-prepare-threads (list thread))
6396 (gnus-summary-update-lines beg (point)))))
6397
6398;; Delete all lines in the summary buffer that correspond to articles
6399;; in this thread.
6400(defun gnus-rebuild-remove-articles (thread)
6401 (and (gnus-summary-goto-subject (mail-header-number (car thread)))
6402 (gnus-delete-line))
6403 (mapcar (lambda (th) (gnus-rebuild-remove-articles th)) (cdr thread)))
6404
6405(defun gnus-sort-threads (threads)
6406 ;; Sort threads as specified in `gnus-thread-sort-functions'.
6407 (let ((fun gnus-thread-sort-functions))
6408 (while fun
6409 (gnus-message 6 "Sorting with %S..." fun)
6410 (setq threads (sort threads (car fun))
6411 fun (cdr fun))))
6412 (if gnus-thread-sort-functions
6413 (gnus-message 6 "Sorting...done"))
6414 threads)
6415
6416;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
6417(defmacro gnus-thread-header (thread)
6418 ;; Return header of first article in THREAD.
6419 ;; Note that THREAD must never, evr be anything else than a variable -
6420 ;; using some other form will lead to serious barfage.
6421 (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread)))
6422 ;; (8% speedup to gnus-summary-prepare, just for fun :-)
6423 (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ;
6424 (vector thread) 2))
6425
6426(defun gnus-thread-sort-by-number (h1 h2)
6427 "Sort threads by root article number."
6428 (< (mail-header-number (gnus-thread-header h1))
6429 (mail-header-number (gnus-thread-header h2))))
6430
6431(defun gnus-thread-sort-by-author (h1 h2)
6432 "Sort threads by root author."
6433 (string-lessp
6434 (let ((extract (funcall
6435 gnus-extract-address-components
6436 (mail-header-from (gnus-thread-header h1)))))
6437 (or (car extract) (cdr extract)))
6438 (let ((extract (funcall
6439 gnus-extract-address-components
6440 (mail-header-from (gnus-thread-header h2)))))
6441 (or (car extract) (cdr extract)))))
6442
6443(defun gnus-thread-sort-by-subject (h1 h2)
6444 "Sort threads by root subject."
6445 (string-lessp
6446 (downcase (gnus-simplify-subject-re
6447 (mail-header-subject (gnus-thread-header h1))))
6448 (downcase (gnus-simplify-subject-re
6449 (mail-header-subject (gnus-thread-header h2))))))
6450
6451(defun gnus-thread-sort-by-date (h1 h2)
6452 "Sort threads by root article date."
6453 (string-lessp
6454 (gnus-sortable-date (mail-header-date (gnus-thread-header h1)))
6455 (gnus-sortable-date (mail-header-date (gnus-thread-header h2)))))
6456
6457(defun gnus-thread-sort-by-score (h1 h2)
6458 "Sort threads by root article score.
6459Unscored articles will be counted as having a score of zero."
6460 (> (or (cdr (assq (mail-header-number (gnus-thread-header h1))
6461 gnus-newsgroup-scored))
6462 gnus-summary-default-score 0)
6463 (or (cdr (assq (mail-header-number (gnus-thread-header h2))
6464 gnus-newsgroup-scored))
6465 gnus-summary-default-score 0)))
6466
6467(defun gnus-thread-sort-by-total-score (h1 h2)
6468 "Sort threads by the sum of all scores in the thread.
6469Unscored articles will be counted as having a score of zero."
6470 (> (gnus-thread-total-score h1) (gnus-thread-total-score h2)))
6471
6472(defun gnus-thread-total-score (thread)
6473 ;; This function find the total score of THREAD.
6474 (if (consp thread)
6475 (if (stringp (car thread))
6476 (apply gnus-thread-score-function 0
6477 (mapcar 'gnus-thread-total-score-1 (cdr thread)))
6478 (gnus-thread-total-score-1 thread))
6479 (gnus-thread-total-score-1 (list thread))))
6480
6481(defun gnus-thread-total-score-1 (root)
6482 ;; This function find the total score of the thread below ROOT.
6483 (setq root (car root))
6484 (apply gnus-thread-score-function
6485 (or (cdr (assq (mail-header-number root) gnus-newsgroup-scored))
6486 gnus-summary-default-score 0)
6487 (mapcar 'gnus-thread-total-score
6488 (cdr (gnus-gethash (downcase (mail-header-id root))
6489 gnus-newsgroup-dependencies)))))
6490
6491;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
6492(defvar gnus-tmp-prev-subject "")
6493
6494(defun gnus-summary-prepare-threads (threads &optional cull)
6495 "Prepare summary buffer from THREADS and indentation LEVEL.
6496THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])'
6497or a straight list of headers."
6498 (message "Generating summary...")
6499 (let ((level 0)
6500 thread header number subject stack state gnus-tmp-gathered)
6501 (if (vectorp (car threads))
6502 ;; If this is a straight (sic) list of headers, then a
6503 ;; threaded summary display isn't required, so we just create
6504 ;; an unthreaded one.
6505 (gnus-summary-prepare-unthreaded threads cull)
6506
6507 ;; Do the threaded display.
6508
6509 (while (or threads stack)
6510
6511 (if threads
6512 ;; If there are some threads, we do them before the
6513 ;; threads on the stack.
6514 (setq thread threads
6515 header (car (car thread)))
6516 ;; There were no current threads, so we pop something off
6517 ;; the stack.
6518 (setq state (car stack)
6519 level (car state)
6520 thread (cdr state)
6521 stack (cdr stack)
6522 header (car (car thread))))
6523
6524 (if (stringp header)
6525 (progn
6526 ;; The header is a dummy root.
6527 (cond
6528 ((eq gnus-summary-make-false-root 'adopt)
6529 ;; We let the first article adopt the rest.
6530 (let ((th (car (cdr (car thread)))))
6531 (while (cdr th)
6532 (setq th (cdr th)))
6533 (setcdr th (cdr (cdr (car thread))))
6534 (setq gnus-tmp-gathered
6535 (nconc (mapcar
6536 (lambda (h) (mail-header-number (car h)))
6537 (cdr (cdr (car thread))))
6538 gnus-tmp-gathered))
6539 (setcdr (cdr (car thread)) nil))
6540 (setq level -1))
6541 ((eq gnus-summary-make-false-root 'empty)
6542 ;; We print adopted articles with empty subject fields.
6543 (setq gnus-tmp-gathered
6544 (nconc (mapcar
6545 (lambda (h) (mail-header-number (car h)))
6546 (cdr (cdr (car thread))))
6547 gnus-tmp-gathered))
6548 (setq level -1))
6549 ((eq gnus-summary-make-false-root 'dummy)
6550 ;; We output a dummy root.
6551 (gnus-summary-insert-dummy-line
6552 nil header (mail-header-number
6553 (car (car (cdr (car thread)))))))
6554 (t
6555 ;; We do not make a root for the gathered
6556 ;; sub-threads at all.
6557 (setq level -1))))
6558
6559 (setq number (mail-header-number header)
6560 subject (mail-header-subject header))
6561
6562 ;; Do the async thing.
6563 (and gnus-newsgroup-async
6564 (setq gnus-newsgroup-threads
6565 (cons (cons number (mail-header-lines header))
6566 gnus-newsgroup-threads)))
6567
6568 ;; We may have to root out some bad articles...
6569 (and cull
6570 (= level 0)
6571 (cond ((and (memq (setq number (mail-header-number header))
6572 gnus-newsgroup-dormant)
6573 (null thread))
6574 (setq header nil))
6575 ((and gnus-summary-expunge-below
6576 (< (or (cdr (assq number gnus-newsgroup-scored))
6577 gnus-summary-default-score 0)
6578 gnus-summary-expunge-below))
6579 (setq header nil)
6580 (setq gnus-newsgroup-unreads
6581 (delq number gnus-newsgroup-unreads))
6582 (setq gnus-newsgroup-reads
6583 (cons (cons number gnus-low-score-mark)
6584 gnus-newsgroup-reads)))))
6585
6586 (and
6587 header
6588 (progn
6589 (inline
6590 (gnus-summary-insert-line
6591 nil header level nil
6592 (cond
6593 ((memq number gnus-newsgroup-marked) gnus-ticked-mark)
6594 ((memq number gnus-newsgroup-dormant) gnus-dormant-mark)
6595 ((memq number gnus-newsgroup-unreads) gnus-unread-mark)
6596 ((memq number gnus-newsgroup-expirable) gnus-expirable-mark)
6597 (t (or (cdr (assq number gnus-newsgroup-reads))
6598 gnus-ancient-mark)))
6599 (memq number gnus-newsgroup-replied)
6600 (memq number gnus-newsgroup-expirable)
6601 (cond
6602 ((and gnus-thread-ignore-subject
6603 (not (string=
6604 (gnus-simplify-subject-re gnus-tmp-prev-subject)
6605 (gnus-simplify-subject-re subject))))
6606 subject)
6607 ((zerop level)
6608 (if (and (eq gnus-summary-make-false-root 'empty)
6609 (memq number gnus-tmp-gathered))
6610 gnus-summary-same-subject
6611 subject))
6612 (t gnus-summary-same-subject))
6613 (and (eq gnus-summary-make-false-root 'adopt)
6614 (memq number gnus-tmp-gathered))
6615 (cdr (assq number gnus-newsgroup-scored))
6616 (memq number gnus-newsgroup-processable))
6617
6618 (setq gnus-tmp-prev-subject subject)))))
6619
6620 (if (nth 1 thread)
6621 (setq stack (cons (cons (max 0 level) (nthcdr 1 thread)) stack)))
6622 (setq level (1+ level))
6623 (setq threads (cdr (car thread))))))
6624 (message "Generating summary...done"))
6625
6626
6627
6628(defun gnus-summary-prepare-unthreaded (headers &optional cull)
6629 (let (header number)
6630
6631 ;; Do the async thing, if that is required.
6632 (if gnus-newsgroup-async
6633 (setq gnus-newsgroup-threads
6634 (mapcar (lambda (h)
6635 (cons (mail-header-number h) (mail-header-lines h)))
6636 headers)))
6637
6638 (while headers
6639 (setq header (car headers)
6640 headers (cdr headers)
6641 number (mail-header-number header))
6642
6643 ;; We may have to root out some bad articles...
6644 (cond
6645 ((and cull
6646 (memq (setq number (mail-header-number header))
6647 gnus-newsgroup-dormant)))
6648 ((and cull gnus-summary-expunge-below
6649 (< (or (cdr (assq number gnus-newsgroup-scored))
6650 gnus-summary-default-score 0)
6651 gnus-summary-expunge-below))
6652 (setq gnus-newsgroup-unreads
6653 (delq number gnus-newsgroup-unreads))
6654 (setq gnus-newsgroup-reads
6655 (cons (cons number gnus-low-score-mark)
6656 gnus-newsgroup-reads)))
6657 (t
6658 (gnus-summary-insert-line
6659 nil header 0 nil
6660 (cond ((memq number gnus-newsgroup-marked) gnus-ticked-mark)
6661 ((memq number gnus-newsgroup-dormant) gnus-dormant-mark)
6662 ((memq number gnus-newsgroup-unreads) gnus-unread-mark)
6663 ((memq number gnus-newsgroup-expirable) gnus-expirable-mark)
6664 (t (or (cdr (assq number gnus-newsgroup-reads))
6665 gnus-ancient-mark)))
6666 (memq number gnus-newsgroup-replied)
6667 (memq number gnus-newsgroup-expirable)
6668 (mail-header-subject header) nil
6669 (cdr (assq number gnus-newsgroup-scored))
6670 (memq number gnus-newsgroup-processable)))))))
6671
6672(defun gnus-select-newsgroup (group &optional read-all)
6673 "Select newsgroup GROUP.
6674If READ-ALL is non-nil, all articles in the group are selected."
6675 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
6676 (info (nth 2 entry))
6677 articles)
6678
6679 (or (gnus-check-server
6680 (setq gnus-current-select-method (gnus-find-method-for-group group)))
6681 (error "Couldn't open server"))
6682
6683 (or (and entry (not (eq (car entry) t))) ; Either it's active...
6684 (gnus-activate-group group) ; Or we can activate it...
6685 (progn ; Or we bug out.
6686 (kill-buffer (current-buffer))
6687 (error "Couldn't request group %s: %s"
6688 group (gnus-status-message group))))
6689
6690 (setq gnus-newsgroup-name group)
6691 (setq gnus-newsgroup-unselected nil)
6692 (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group))
6693
6694 (and gnus-asynchronous
6695 (gnus-check-backend-function
6696 'request-asynchronous gnus-newsgroup-name)
6697 (setq gnus-newsgroup-async
6698 (gnus-request-asynchronous gnus-newsgroup-name)))
6699
6700 (setq articles (gnus-articles-to-read group read-all))
6701
6702 (cond
6703 ((null articles)
6704 (gnus-message 3 "Couldn't select newsgroup")
6705 'quit)
6706 ((eq articles 0) nil)
6707 (t
6708 ;; Init the dependencies hash table.
6709 (setq gnus-newsgroup-dependencies
6710 (gnus-make-hashtable (length articles)))
6711 ;; Retrieve the headers and read them in.
6712 (gnus-message 5 "Fetching headers...")
6713 (setq gnus-newsgroup-headers
6714 (if (eq 'nov (setq gnus-headers-retrieved-by
6715 ;; This is a naughty hack. To get the
6716 ;; retrieval of old headers to work, we
6717 ;; set `nntp-nov-gap' to nil (locally),
6718 ;; and then just retrieve the headers.
6719 ;; Mucho magic.
6720 (if gnus-fetch-old-headers
6721 (let (nntp-nov-gap)
6722 (gnus-retrieve-headers
6723 (if (not (eq 1 (car articles)))
6724 (cons 1 articles)
6725 articles)
6726 gnus-newsgroup-name))
6727 (gnus-retrieve-headers
6728 articles gnus-newsgroup-name))))
6729 (progn
6730 (gnus-get-newsgroup-headers-xover articles))
6731 ;; If we were to fetch old headers, but the backend didn't
6732 ;; support XOVER, then it is possible we fetched one article
6733 ;; that we shouldn't have. If that's the case, we remove it.
6734 (if (or (not gnus-fetch-old-headers)
6735 (eq 1 (car articles)))
6736 ()
6737 (save-excursion
6738 (set-buffer nntp-server-buffer)
6739 (goto-char (point-min))
6740 (and
6741 (looking-at "[0-9]+[ \t]+1[ \t]") ; This is not a NOV line.
6742 (delete-region ; So we delete this head.
6743 (point)
6744 (search-forward "\n.\n" nil t)))))
6745 (gnus-get-newsgroup-headers)))
6746 (gnus-message 5 "Fetching headers...done")
6747 ;; Remove canceled articles from the list of unread articles.
6748 (setq gnus-newsgroup-unreads
6749 (gnus-set-sorted-intersection
6750 gnus-newsgroup-unreads
6751 (mapcar (lambda (headers) (mail-header-number headers))
6752 gnus-newsgroup-headers)))
6753 ;; Adjust and set lists of article marks.
6754 (and info
6755 (let (marked)
6756 (gnus-adjust-marked-articles info)
6757 (setq gnus-newsgroup-marked
6758 (copy-sequence
6759 (cdr (assq 'tick (setq marked (nth 3 info))))))
6760 (setq gnus-newsgroup-replied
6761 (copy-sequence (cdr (assq 'reply marked))))
6762 (setq gnus-newsgroup-expirable
6763 (copy-sequence (cdr (assq 'expire marked))))
6764 (setq gnus-newsgroup-killed
6765 (copy-sequence (cdr (assq 'killed marked))))
6766 (setq gnus-newsgroup-bookmarks
6767 (copy-sequence (cdr (assq 'bookmark marked))))
6768 (setq gnus-newsgroup-dormant
6769 (copy-sequence (cdr (assq 'dormant marked))))
6770 (setq gnus-newsgroup-scored
6771 (copy-sequence (cdr (assq 'score marked))))
6772 (setq gnus-newsgroup-processable nil)))
6773 ;; Check whether auto-expire is to be done in this group.
6774 (setq gnus-newsgroup-auto-expire
6775 (or (and (stringp gnus-auto-expirable-newsgroups)
6776 (string-match gnus-auto-expirable-newsgroups group))
6777 (memq 'auto-expire (nth 5 info))))
6778 ;; First and last article in this newsgroup.
6779 (and gnus-newsgroup-headers
6780 (setq gnus-newsgroup-begin
6781 (mail-header-number (car gnus-newsgroup-headers)))
6782 (setq gnus-newsgroup-end
6783 (mail-header-number
6784 (gnus-last-element gnus-newsgroup-headers))))
6785 (setq gnus-reffed-article-number -1)
6786 ;; GROUP is successfully selected.
6787 (or gnus-newsgroup-headers t)))))
6788
6789(defun gnus-articles-to-read (group read-all)
6790 ;; Find out what articles the user wants to read.
6791 (let* ((articles
6792 ;; Select all articles if `read-all' is non-nil, or if all the
6793 ;; unread articles are dormant articles.
6794 (if (or read-all
6795 (= (length gnus-newsgroup-unreads)
6796 (length gnus-newsgroup-dormant)))
6797 (gnus-uncompress-range
6798 (gnus-gethash group gnus-active-hashtb))
6799 gnus-newsgroup-unreads))
6800 (scored-list (gnus-killed-articles gnus-newsgroup-killed articles))
6801 (scored (length scored-list))
6802 (number (length articles))
6803 (marked (+ (length gnus-newsgroup-marked)
6804 (length gnus-newsgroup-dormant)))
6805 (select
6806 (cond
6807 ((numberp read-all)
6808 read-all)
6809 (t
6810 (condition-case ()
6811 (cond ((and (or (<= scored marked)
6812 (= scored number))
6813 (numberp gnus-large-newsgroup)
6814 (> number gnus-large-newsgroup))
6815 (let ((input
6816 (read-string
6817 (format
6818 "How many articles from %s (default %d): "
6819 gnus-newsgroup-name number))))
6820 (if (string-match "^[ \t]*$" input)
6821 number input)))
6822 ((and (> scored marked) (< scored number))
6823 (let ((input
6824 (read-string
6825 (format
6826 "%s %s (%d scored, %d total): "
6827 "How many articles from"
6828 group scored number))))
6829 (if (string-match "^[ \t]*$" input)
6830 number input)))
6831 (t number))
6832 (quit nil))))))
6833 (setq select (if (stringp select) (string-to-number select) select))
6834 (if (or (null select) (zerop select))
6835 select
6836 (if (and (not (zerop scored)) (<= (abs select) scored))
6837 (progn
6838 (setq articles (sort scored-list '<))
6839 (setq number (length articles)))
6840 (setq articles (copy-sequence articles)))
6841
6842 (if (< (abs select) number)
6843 (if (< select 0)
6844 ;; Select the N oldest articles.
6845 (setcdr (nthcdr (1- (abs select)) articles) nil)
6846 ;; Select the N most recent articles.
6847 (setq articles (nthcdr (- number select) articles))))
6848 (setq gnus-newsgroup-unselected
6849 (gnus-sorted-intersection
6850 gnus-newsgroup-unreads
6851 (gnus-sorted-complement gnus-newsgroup-unreads articles)))
6852 articles)))
6853
6854(defun gnus-killed-articles (killed articles)
6855 (let (out)
6856 (while articles
6857 (if (inline (gnus-member-of-range (car articles) killed))
6858 (setq out (cons (car articles) out)))
6859 (setq articles (cdr articles)))
6860 out))
6861
6862(defun gnus-adjust-marked-articles (info &optional active)
6863 "Remove all marked articles that are no longer legal."
6864 (let ((marked-lists (nth 3 info))
6865 (active (or active (gnus-gethash (car info) gnus-active-hashtb)))
6866 m prev)
6867 ;; There are many types of marked articles.
6868 (while marked-lists
6869 (setq m (cdr (setq prev (car marked-lists))))
6870 (cond ((or (eq 'tick (car prev)) (eq 'dormant (car prev)))
6871 ;; Make sure that all ticked articles are a subset of the
6872 ;; unread/unselected articles.
6873 (while m
6874 (if (or (memq (car m) gnus-newsgroup-unreads)
6875 (memq (car m) gnus-newsgroup-unselected))
6876 (setq prev m)
6877 (setcdr prev (cdr m)))
6878 (setq m (cdr m))))
6879 ((eq 'score (car prev))
6880 ;; Scored articles should be a subset of
6881 ;; unread/unselected articles.
6882 (while m
6883 (if (or (memq (car (car m)) gnus-newsgroup-unreads)
6884 (memq (car (car m)) gnus-newsgroup-unreads))
6885 (setq prev m)
6886 (setcdr prev (cdr m)))
6887 (setq m (cdr m))))
6888 ((eq 'bookmark (car prev))
6889 ;; Bookmarks should be a subset of active articles.
6890 (while m
6891 (if (< (car (car m)) (car active))
6892 (setcdr prev (cdr m))
6893 (setq prev m))
6894 (setq m (cdr m))))
6895 ((eq 'killed (car prev))
6896 ;; Articles that have been through the kill process are
6897 ;; to be a subset of active articles.
6898 (while (and m (< (or (and (numberp (car m)) (car m))
6899 (cdr (car m)))
6900 (car active)))
6901 (setcdr prev (cdr m))
6902 (setq m (cdr m)))
6903 (if (and m (< (or (and (numberp (car m)) (car m))
6904 (car (car m)))
6905 (car active)))
6906 (setcar (if (numberp (car m)) m (car m)) (car active))))
6907 ((or (eq 'reply (car prev)) (eq 'expire (car prev)))
6908 ;; The replied and expirable articles have to be articles
6909 ;; that are active.
6910 (while m
6911 (if (< (car m) (car active))
6912 (setcdr prev (cdr m))
6913 (setq prev m))
6914 (setq m (cdr m)))))
6915 (setq marked-lists (cdr marked-lists)))
6916 ;; Remove all lists that are empty.
6917 (setq marked-lists (nth 3 info))
6918 (if marked-lists
6919 (progn
6920 (while (= 1 (length (car marked-lists)))
6921 (setq marked-lists (cdr marked-lists)))
6922 (setq m (cdr (setq prev marked-lists)))
6923 (while m
6924 (if (= 1 (length (car m)))
6925 (setcdr prev (cdr m))
6926 (setq prev m))
6927 (setq m (cdr m)))
6928 (setcar (nthcdr 3 info) marked-lists)))
6929 ;; Finally, if there are no marked lists at all left, and if there
6930 ;; are no elements after the lists in the info list, we just chop
6931 ;; the info list off before the marked lists.
6932 (and (null marked-lists)
6933 (not (nthcdr 4 info))
6934 (setcdr (nthcdr 2 info) nil)))
6935 info)
6936
6937(defun gnus-set-marked-articles
6938 (info ticked replied expirable killed dormant bookmark score)
6939 "Enter the various lists of marked articles into the newsgroup info list."
6940 (let (newmarked)
6941 (and ticked (setq newmarked (cons (cons 'tick ticked) nil)))
6942 (and replied (setq newmarked (cons (cons 'reply replied) newmarked)))
6943 (and expirable (setq newmarked (cons (cons 'expire expirable)
6944 newmarked)))
6945 (and killed (setq newmarked (cons (cons 'killed killed) newmarked)))
6946 (and dormant (setq newmarked (cons (cons 'dormant dormant) newmarked)))
6947 (and bookmark (setq newmarked (cons (cons 'bookmark bookmark)
6948 newmarked)))
6949 (and score (setq newmarked (cons (cons 'score score) newmarked)))
6950 (if (nthcdr 3 info)
6951 (progn
6952 (setcar (nthcdr 3 info) newmarked)
6953 (and (not newmarked)
6954 (not (nthcdr 4 info))
6955 (setcdr (nthcdr 2 info) nil)))
6956 (if newmarked
6957 (setcdr (nthcdr 2 info) (list newmarked))))))
6958
6959(defun gnus-add-marked-articles (group type articles &optional info force)
6960 ;; Add ARTICLES of TYPE to the info of GROUP.
6961 ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
6962 ;; add, but replace marked articles of TYPE with ARTICLES.
6963 (let ((info (or info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))))
6964 marked m)
6965 (or (not info)
6966 (and (not (setq marked (nthcdr 3 info)))
6967 (setcdr (nthcdr 2 info) (list (list (cons type articles)))))
6968 (and (not (setq m (assq type (car marked))))
6969 (setcar marked (cons (cons type articles) (car marked))))
6970 (if force
6971 (setcdr m articles)
6972 (nconc m articles)))))
6973
6974(defun gnus-set-mode-line (where)
6975 "This function sets the mode line of the article or summary buffers.
6976If WHERE is `summary', the summary mode line format will be used."
6977 (if (memq where gnus-updated-mode-lines)
6978 (let (mode-string)
6979 (save-excursion
6980 (set-buffer gnus-summary-buffer)
6981 (let* ((mformat (if (eq where 'article)
6982 gnus-article-mode-line-format-spec
6983 gnus-summary-mode-line-format-spec))
6346a6e6
LMI
6984 (buffer-name (if (eq where 'article)
6985 (buffer-name
6986 (get-buffer gnus-article-buffer))
6987 (buffer-name)))
41487370
LMI
6988 (group-name gnus-newsgroup-name)
6989 (article-number (or gnus-current-article 0))
6990 (unread (- (length gnus-newsgroup-unreads)
6991 (length gnus-newsgroup-dormant)))
6992 (unread-and-unticked
6993 (- unread (length gnus-newsgroup-marked)))
6994 (unselected (length gnus-newsgroup-unselected))
6995 (unread-and-unselected
6996 (cond ((and (zerop unread-and-unticked)
6997 (zerop unselected)) "")
6998 ((zerop unselected)
6999 (format "{%d more}" unread-and-unticked))
7000 (t (format "{%d(+%d) more}"
7001 unread-and-unticked unselected))))
7002 (subject
7003 (if gnus-current-headers
7004 (mail-header-subject gnus-current-headers) ""))
7005 (max-len (and gnus-mode-non-string-length
7006 (- (frame-width) gnus-mode-non-string-length)))
7007 header);; passed as argument to any user-format-funcs
7008 (setq mode-string (eval mformat))
7009 (or (numberp max-len)
7010 (setq max-len (length mode-string)))
7011 (if (< max-len 4) (setq max-len 4))
7012 (if (> (length mode-string) max-len)
7013 ;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
7014 ;; function `substring' might cut on a middle
7015 ;; of multi-octet character.
7016 (setq mode-string
7017 (concat (gnus-truncate-string mode-string (- max-len 3))
7018 "...")))
7019 (setq mode-string (format (format "%%-%ds" max-len)
7020 mode-string))))
7021 (setq mode-line-buffer-identification mode-string)
7022 (set-buffer-modified-p t))))
7023
7024(defun gnus-create-xref-hashtb (from-newsgroup headers unreads)
7025 "Go through the HEADERS list and add all Xrefs to a hash table.
7026The resulting hash table is returned, or nil if no Xrefs were found."
7027 (let* ((from-method (gnus-find-method-for-group from-newsgroup))
7028 (prefix (if (and
7029 (gnus-group-foreign-p from-newsgroup)
7030 (not (memq 'virtual
7031 (assoc (symbol-name (car from-method))
7032 gnus-valid-select-methods))))
7033 (gnus-group-real-prefix from-newsgroup)))
7034 (xref-hashtb (make-vector 63 0))
7035 start group entry number xrefs header)
7036 (while headers
7037 (setq header (car headers))
7038 (if (and (setq xrefs (mail-header-xref header))
7039 (not (memq (mail-header-number header) unreads)))
7040 (progn
7041 (setq start 0)
7042 (while (string-match "\\([^ ]+\\):\\([0-9]+\\)" xrefs start)
7043 (setq start (match-end 0))
7044 (setq group (concat prefix (substring xrefs (match-beginning 1)
7045 (match-end 1))))
7046 (setq number
7047 (string-to-int (substring xrefs (match-beginning 2)
7048 (match-end 2))))
7049 (if (setq entry (gnus-gethash group xref-hashtb))
7050 (setcdr entry (cons number (cdr entry)))
7051 (gnus-sethash group (cons number nil) xref-hashtb)))))
7052 (setq headers (cdr headers)))
7053 (if start xref-hashtb nil)))
7054
7055(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads expirable)
7056 "Look through all the headers and mark the Xrefs as read."
7057 (let ((virtual (memq 'virtual
7058 (assoc (symbol-name (car (gnus-find-method-for-group
7059 from-newsgroup)))
7060 gnus-valid-select-methods)))
7061 name entry info xref-hashtb idlist method
7062 nth4)
7063 (save-excursion
7064 (set-buffer gnus-group-buffer)
7065 (if (setq xref-hashtb
7066 (gnus-create-xref-hashtb from-newsgroup headers unreads))
7067 (mapatoms
7068 (lambda (group)
7069 (if (string= from-newsgroup (setq name (symbol-name group)))
7070 ()
7071 (setq idlist (symbol-value group))
7072 ;; Dead groups are not updated.
7073 (if (and (prog1
7074 (setq entry (gnus-gethash name gnus-newsrc-hashtb)
7075 info (nth 2 entry))
7076 (if (stringp (setq nth4 (nth 4 info)))
7077 (setq nth4 (gnus-server-to-method nth4))))
7078 ;; Only do the xrefs if the group has the same
7079 ;; select method as the group we have just read.
7080 (or (gnus-methods-equal-p
7081 nth4 (gnus-find-method-for-group from-newsgroup))
7082 virtual
7083 (equal nth4
7084 (setq method (gnus-find-method-for-group
7085 from-newsgroup)))
7086 (and (equal (car nth4) (car method))
7087 (equal (nth 1 nth4) (nth 1 method))))
7088 gnus-use-cross-reference
7089 (or (not (eq gnus-use-cross-reference t))
7090 virtual
7091 ;; Only do cross-references on subscribed
7092 ;; groups, if that is what is wanted.
7093 (<= (nth 1 info) gnus-level-subscribed)))
7094 (gnus-group-make-articles-read name idlist expirable))))
7095 xref-hashtb)))))
7096
7097(defun gnus-group-make-articles-read (group articles expirable)
7098 (let* ((num 0)
7099 (entry (gnus-gethash group gnus-newsrc-hashtb))
7100 (info (nth 2 entry))
7101 (active (gnus-gethash group gnus-active-hashtb))
7102 exps expirable range)
7103 ;; First peel off all illegal article numbers.
7104 (if active
7105 (let ((ids articles)
7106 (ticked (cdr (assq 'tick (nth 3 info))))
7107 (dormant (cdr (assq 'dormant (nth 3 info))))
7108 id first)
7109 (setq exps nil)
7110 (while ids
7111 (setq id (car ids))
7112 (if (and first (> id (cdr active)))
7113 (progn
7114 ;; We'll end up in this situation in one particular
7115 ;; obscure situation. If you re-scan a group and get
7116 ;; a new article that is cross-posted to a different
7117 ;; group that has not been re-scanned, you might get
7118 ;; crossposted article that has a higher number than
7119 ;; Gnus believes possible. So we re-activate this
7120 ;; group as well. This might mean doing the
b94ae5f7 7121 ;; crossposting thingy will *increase* the number
41487370
LMI
7122 ;; of articles in some groups. Tsk, tsk.
7123 (setq active (or (gnus-activate-group group) active))))
7124 (if (or (> id (cdr active))
7125 (< id (car active))
7126 (memq id ticked)
7127 (memq id dormant))
7128 (setq articles (delq id articles)))
7129 (and (memq id expirable)
7130 (setq exps (cons id exps)))
7131 (setq ids (cdr ids)))))
7132 ;; Update expirable articles.
7133 (gnus-add-marked-articles nil 'expirable exps info)
7134 (and active
7135 (null (nth 2 info))
7136 (> (car active) 1)
7137 (setcar (nthcdr 2 info) (cons 1 (1- (car active)))))
7138 (setcar (nthcdr 2 info)
7139 (setq range
7140 (gnus-add-to-range
7141 (nth 2 info)
7142 (setq articles (sort articles '<)))))
7143 ;; Then we have to re-compute how many unread
7144 ;; articles there are in this group.
7145 (if active
7146 (progn
7147 (cond
7148 ((not range)
7149 (setq num (- (1+ (cdr active)) (car active))))
7150 ((not (listp (cdr range)))
7151 (setq num (- (cdr active) (- (1+ (cdr range))
7152 (car range)))))
7153 (t
7154 (while range
7155 (if (numberp (car range))
7156 (setq num (1+ num))
7157 (setq num (+ num (- (1+ (cdr (car range)))
7158 (car (car range))))))
7159 (setq range (cdr range)))
7160 (setq num (- (cdr active) num))))
7161 ;; Update the number of unread articles.
7162 (setcar
7163 entry
7164 (max 0 (- num
7165 (length (cdr (assq 'tick (nth 3 info))))
7166 (length
7167 (cdr (assq 'dormant (nth 3 info)))))))
7168 ;; Update the group buffer.
7169 (gnus-group-update-group group t)))))
7170
7171(defun gnus-methods-equal-p (m1 m2)
7172 (let ((m1 (or m1 gnus-select-method))
7173 (m2 (or m2 gnus-select-method)))
7174 (or (equal m1 m2)
7175 (and (eq (car m1) (car m2))
7176 (or (not (memq 'address (assoc (symbol-name (car m1))
7177 gnus-valid-select-methods)))
7178 (equal (nth 1 m1) (nth 1 m2)))))))
7179
7180(defsubst gnus-header-value ()
7181 (buffer-substring (match-end 0) (gnus-point-at-eol)))
7182
7183(defvar gnus-newsgroup-none-id 0)
7184
7185(defun gnus-get-newsgroup-headers ()
7186 (setq gnus-article-internal-prepare-hook nil)
7187 (let ((cur nntp-server-buffer)
7188 (dependencies gnus-newsgroup-dependencies)
7189 headers id dep end ref)
7190 (save-excursion
7191 (set-buffer nntp-server-buffer)
7e988fb6
LMI
7192 ;; Allow the user to mangle the headers before parsing them.
7193 (run-hooks 'gnus-parse-headers-hook)
41487370
LMI
7194 (goto-char (point-min))
7195 ;; Search to the beginning of the next header. Error messages
7196 ;; do not begin with 2 or 3.
7197 (while (re-search-forward "^[23][0-9]+ " nil t)
7198 (let ((header (make-vector 9 nil))
7199 (case-fold-search t)
7200 (p (point))
7201 in-reply-to)
7202 (setq id nil
7203 ref nil)
7204 (mail-header-set-number header (read cur))
7205 ;; This implementation of this function, with nine
7206 ;; search-forwards instead of the one re-search-forward and
7207 ;; a case (which basically was the old function) is actually
7208 ;; about twice as fast, even though it looks messier. You
7209 ;; can't have everything, I guess. Speed and elegance
7210 ;; doesn't always come hand in hand.
7211 (save-restriction
7212 (narrow-to-region (point) (or (save-excursion
7213 (search-forward "\n.\n" nil t))
7214 (point)))
7215 (if (search-forward "\nfrom: " nil t)
7216 (mail-header-set-from header (gnus-header-value))
7217 (mail-header-set-from header "(nobody)"))
7218 (goto-char p)
7219 (if (search-forward "\nsubject: " nil t)
7220 (mail-header-set-subject header (gnus-header-value))
7221 (mail-header-set-subject header "(none)"))
7222 (goto-char p)
7223 (and (search-forward "\nxref: " nil t)
7224 (mail-header-set-xref header (gnus-header-value)))
7225 (goto-char p)
7226 (or (numberp (and (search-forward "\nlines: " nil t)
7227 (mail-header-set-lines header (read cur))))
7228 (mail-header-set-lines header 0))
7229 (goto-char p)
7230 (and (search-forward "\ndate: " nil t)
7231 (mail-header-set-date header (gnus-header-value)))
7232 (goto-char p)
7233 (if (search-forward "\nmessage-id: " nil t)
7234 (mail-header-set-id header (setq id (gnus-header-value)))
7235 ;; If there was no message-id, we just fake one to make
7236 ;; subsequent routines simpler.
7237 (mail-header-set-id
7238 header
7239 (setq id (concat "none+"
7240 (int-to-string
7241 (setq gnus-newsgroup-none-id
7242 (1+ gnus-newsgroup-none-id)))))))
7243 (goto-char p)
7244 (if (search-forward "\nreferences: " nil t)
7245 (progn
7246 (mail-header-set-references header (gnus-header-value))
7247 (setq end (match-end 0))
7248 (save-excursion
7249 (setq ref
7250 (downcase
7251 (buffer-substring
7252 (progn
7253 (end-of-line)
7254 (search-backward ">" end t)
7255 (1+ (point)))
7256 (progn
7257 (search-backward "<" end t)
7258 (point)))))))
7259 ;; Get the references from the in-reply-to header if there
7260 ;; ware no references and the in-reply-to header looks
7261 ;; promising.
7262 (if (and (search-forward "\nin-reply-to: " nil t)
7263 (setq in-reply-to (gnus-header-value))
7264 (string-match "<[^>]+>" in-reply-to))
7265 (progn
7266 (mail-header-set-references
7267 header
7268 (setq ref (substring in-reply-to (match-beginning 0)
7269 (match-end 0))))
7270 (setq ref (downcase ref)))
7271 (setq ref "none")))
7272 ;; We do some threading while we read the headers. The
7273 ;; message-id and the last reference are both entered into
7274 ;; the same hash table. Some tippy-toeing around has to be
7275 ;; done in case an article has arrived before the article
7276 ;; which it refers to.
7277 (if (boundp (setq dep (intern (downcase id) dependencies)))
7278 (if (car (symbol-value dep))
7279 ;; An article with this Message-ID has already
7280 ;; been seen, so we ignore this one, except we add
7281 ;; any additional Xrefs (in case the two articles
7282 ;; came from different servers.
7283 (progn
7284 (mail-header-set-xref
7285 (car (symbol-value dep))
7286 (concat (or (mail-header-xref
7287 (car (symbol-value dep))) "")
7288 (or (mail-header-xref header) "")))
7289 (setq header nil))
7290 (setcar (symbol-value dep) header))
7291 (set dep (list header)))
7292 (if header
7293 (progn
7294 (if (boundp (setq dep (intern ref dependencies)))
7295 (setcdr (symbol-value dep)
7296 (cons header (cdr (symbol-value dep))))
7297 (set dep (list nil header)))
7298 (setq headers (cons header headers))))
7299 (goto-char (point-max))))))
7300 (nreverse headers)))
7301
7302;; The following macros and functions were written by Felix Lee
7303;; <flee@cse.psu.edu>.
7304
7305(defmacro gnus-nov-read-integer ()
7306 '(prog1
7307 (if (= (following-char) ?\t)
7308 0
7309 (let ((num (condition-case nil (read buffer) (error nil))))
7310 (if (numberp num) num 0)))
7311 (or (eobp) (forward-char 1))))
7312
7313(defmacro gnus-nov-skip-field ()
7314 '(search-forward "\t" eol 'move))
7315
7316(defmacro gnus-nov-field ()
7317 '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol)))
7318
7319;; Goes through the xover lines and returns a list of vectors
7320(defun gnus-get-newsgroup-headers-xover (sequence)
7321 "Parse the news overview data in the server buffer, and return a
7322list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
7323 ;; Get the Xref when the users reads the articles since most/some
7324 ;; NNTP servers do not include Xrefs when using XOVER.
7325 (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs))
7326 (let ((cur nntp-server-buffer)
7327 (dependencies gnus-newsgroup-dependencies)
7328 number headers header)
7329 (save-excursion
7330 (set-buffer nntp-server-buffer)
7e988fb6
LMI
7331 ;; Allow the user to mangle the headers before parsing them.
7332 (run-hooks 'gnus-parse-headers-hook)
41487370
LMI
7333 (goto-char (point-min))
7334 (while (and sequence (not (eobp)))
7335 (setq number (read cur))
7336 (while (and sequence (< (car sequence) number))
7337 (setq sequence (cdr sequence)))
7338 (and sequence
7339 (eq number (car sequence))
7340 (progn
7341 (setq sequence (cdr sequence))
7342 (if (setq header
7343 (inline (gnus-nov-parse-line number dependencies)))
7344 (setq headers (cons header headers)))))
7345 (forward-line 1))
7346 (setq headers (nreverse headers)))
7347 headers))
7348
7349;; This function has to be called with point after the article number
7350;; on the beginning of the line.
7351(defun gnus-nov-parse-line (number dependencies)
7352 (let ((none 0)
7353 (eol (gnus-point-at-eol))
7354 (buffer (current-buffer))
7355 header ref id dep)
7356
7357 ;; overview: [num subject from date id refs chars lines misc]
7358 (narrow-to-region (point) eol)
7359 (or (eobp) (forward-char))
7360
7361 (condition-case nil
7362 (setq header
7363 (vector
7364 number ; number
7365 (gnus-nov-field) ; subject
7366 (gnus-nov-field) ; from
7367 (gnus-nov-field) ; date
7368 (setq id (or (gnus-nov-field)
7369 (concat "none+"
7370 (int-to-string
7371 (setq none (1+ none)))))) ; id
7372 (progn
7373 (save-excursion
7374 (let ((beg (point)))
7375 (search-forward "\t" eol)
7376 (if (search-backward ">" beg t)
7377 (setq ref
7378 (downcase
7379 (buffer-substring
7380 (1+ (point))
7381 (progn
7382 (search-backward "<" beg t)
7383 (point)))))
7384 (setq ref nil))))
7385 (gnus-nov-field)) ; refs
7386 (gnus-nov-read-integer) ; chars
7387 (gnus-nov-read-integer) ; lines
7388 (if (= (following-char) ?\n)
7389 nil
7390 (gnus-nov-field)) ; misc
7391 ))
7392 (error (progn
7393 (ding)
7394 (message "Strange nov line.")
7395 (setq header nil)
7396 (goto-char eol))))
7397
7398 (widen)
7399
7400 ;; We build the thread tree.
7401 (and header
7402 (if (boundp (setq dep (intern (downcase id) dependencies)))
7403 (if (car (symbol-value dep))
7404 ;; An article with this Message-ID has already been seen,
7405 ;; so we ignore this one, except we add any additional
7406 ;; Xrefs (in case the two articles came from different
7407 ;; servers.
7408 (progn
7409 (mail-header-set-xref
7410 (car (symbol-value dep))
7411 (concat (or (mail-header-xref (car (symbol-value dep))) "")
7412 (or (mail-header-xref header) "")))
7413 (setq header nil))
7414 (setcar (symbol-value dep) header))
7415 (set dep (list header))))
7416 (if header
7417 (progn
7418 (if (boundp (setq dep (intern (or ref "none")
7419 dependencies)))
7420 (setcdr (symbol-value dep)
7421 (cons header (cdr (symbol-value dep))))
7422 (set dep (list nil header)))))
7423 header))
7424
7425(defun gnus-article-get-xrefs ()
7426 "Fill in the Xref value in `gnus-current-headers', if necessary.
7427This is meant to be called in `gnus-article-internal-prepare-hook'."
7428 (let ((headers (save-excursion (set-buffer gnus-summary-buffer)
7429 gnus-current-headers)))
7430 (or (not gnus-use-cross-reference)
7431 (not headers)
7432 (and (mail-header-xref headers)
7433 (not (string= (mail-header-xref headers) "")))
7434 (let ((case-fold-search t)
7435 xref)
7436 (save-restriction
7437 (gnus-narrow-to-headers)
7438 (goto-char (point-min))
7439 (if (or (and (eq (downcase (following-char)) ?x)
7440 (looking-at "Xref:"))
7441 (search-forward "\nXref:" nil t))
7442 (progn
7443 (goto-char (1+ (match-end 0)))
7444 (setq xref (buffer-substring (point)
7445 (progn (end-of-line) (point))))
7446 (mail-header-set-xref headers xref))))))))
7447
7448(defalias 'gnus-find-header-by-number 'gnus-get-header-by-number)
7449(make-obsolete 'gnus-find-header-by-number 'gnus-get-header-by-number)
7450
7451(defun gnus-make-headers-hashtable-by-number ()
7452 "Make hashtable for the variable gnus-newsgroup-headers by number."
7453 (save-excursion
7454 (set-buffer gnus-summary-buffer)
7455 (let ((headers gnus-newsgroup-headers)
7456 header)
7457 (setq gnus-newsgroup-headers-hashtb-by-number
7458 (gnus-make-hashtable (length headers)))
7459 (while headers
7460 (setq header (car headers))
7461 (gnus-sethash (int-to-string (mail-header-number header))
7462 header gnus-newsgroup-headers-hashtb-by-number)
7463 (setq headers (cdr headers))))))
7464
7465(defun gnus-more-header-backward ()
7466 "Find new header backward."
7467 (let ((first (car (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))
7468 (artnum gnus-newsgroup-begin)
7469 (header nil))
7470 (while (and (not header)
7471 (> artnum first))
7472 (setq artnum (1- artnum))
7473 (setq header (gnus-read-header artnum)))
7474 header))
7475
7476(defun gnus-more-header-forward (&optional backward)
7477 "Find new header forward.
7478If BACKWARD, find new header backward instead."
7479 (if backward
7480 (gnus-more-header-backward)
7481 (let ((last (cdr (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))
7482 (artnum gnus-newsgroup-end)
7483 (header nil))
7484 (while (and (not header)
7485 (< artnum last))
7486 (setq artnum (1+ artnum))
7487 (setq header (gnus-read-header artnum)))
7488 header)))
7489
7490(defun gnus-extend-newsgroup (header &optional backward)
7491 "Extend newsgroup selection with HEADER.
7492Optional argument BACKWARD means extend toward backward."
7493 (if header
7494 (let ((artnum (mail-header-number header)))
7495 (setq gnus-newsgroup-headers
7496 (if backward
7497 (cons header gnus-newsgroup-headers)
7498 (nconc gnus-newsgroup-headers (list header))))
7499 (setq gnus-newsgroup-unselected
7500 (delq artnum gnus-newsgroup-unselected))
7501 (setq gnus-newsgroup-begin (min gnus-newsgroup-begin artnum))
7502 (setq gnus-newsgroup-end (max gnus-newsgroup-end artnum)))))
7503
7504(defun gnus-summary-work-articles (n)
7505 "Return a list of articles to be worked upon. The prefix argument,
7506the list of process marked articles, and the current article will be
7507taken into consideration."
7508 (let (articles)
7509 (if (and n (numberp n))
7510 (let ((backward (< n 0))
7511 (n (abs n)))
7512 (save-excursion
7513 (while (and (> n 0)
7514 (setq articles (cons (gnus-summary-article-number)
7515 articles))
7516 (gnus-summary-search-forward nil nil backward))
7517 (setq n (1- n))))
7518 (sort articles (function <)))
7519 (or (reverse gnus-newsgroup-processable)
7520 (list (gnus-summary-article-number))))))
7521
7522(defun gnus-summary-search-group (&optional backward use-level)
7523 "Search for next unread newsgroup.
7524If optional argument BACKWARD is non-nil, search backward instead."
7525 (save-excursion
7526 (set-buffer gnus-group-buffer)
7527 (if (gnus-group-search-forward
7528 backward nil (if use-level (gnus-group-group-level) nil))
7529 (gnus-group-group-name))))
7530
7531(defun gnus-summary-best-group (&optional exclude-group)
7532 "Find the name of the best unread group.
7533If EXCLUDE-GROUP, do not go to this group."
7534 (save-excursion
7535 (set-buffer gnus-group-buffer)
7536 (save-excursion
7537 (gnus-group-best-unread-group exclude-group))))
7538
7539(defun gnus-subject-equal (s1 s2)
7540 (cond
7541 ((null gnus-summary-gather-subject-limit)
7542 (equal (gnus-simplify-subject-re s1)
7543 (gnus-simplify-subject-re s2)))
7544 ((eq gnus-summary-gather-subject-limit 'fuzzy)
7545 (equal (gnus-simplify-subject-fuzzy s1)
7546 (gnus-simplify-subject-fuzzy s2)))
7547 ((numberp gnus-summary-gather-subject-limit)
7548 (equal (gnus-limit-string s1 gnus-summary-gather-subject-limit)
7549 (gnus-limit-string s2 gnus-summary-gather-subject-limit)))
7550 (t
7551 (equal s1 s2))))
7552
7553(defun gnus-summary-search-subject (&optional backward unread subject)
7554 "Search for article forward.
7555If BACKWARD is non-nil, search backward.
7556If UNREAD is non-nil, only unread articles are selected.
7557If SUBJECT is non-nil, the article which has the same subject will be
7558searched for."
7559 (let ((func (if backward 'previous-single-property-change
7560 'next-single-property-change))
7561 (beg (point))
7562 (did t)
7563 pos psubject)
7564 (beginning-of-line)
7565 (and gnus-summary-check-current unread
7566 (eq (get-text-property (point) 'gnus-mark) gnus-unread-mark)
7567 (setq did nil))
7568 (if (not did)
7569 ()
7570 (forward-char (if backward (if (bobp) 0 -1) (if (eobp) 0 1)))
7571 (while
7572 (and
7573 (setq pos (funcall func (point) 'gnus-number))
7574 (goto-char (if backward (1- pos) pos))
7575 (setq did
7576 (not (and
7577 (or (not unread)
7578 (eq (get-text-property (point) 'gnus-mark)
7579 gnus-unread-mark))
7580 (or (not subject)
7581 (and (setq psubject
7582 (inline (gnus-summary-subject-string)))
7583 (inline
7584 (gnus-subject-equal subject psubject)))))))
7585 (if backward (if (bobp) nil (forward-char -1) t)
7586 (if (eobp) nil (forward-char 1) t)))))
7587 (if did
7588 (progn (goto-char beg) nil)
7589 (prog1
7590 (get-text-property (point) 'gnus-number)
7591 (gnus-summary-show-thread)
7592 (gnus-summary-position-cursor)))))
7593
7594(defun gnus-summary-pseudo-article ()
7595 "The thread level of the article on the current line."
7596 (get-text-property (gnus-point-at-bol) 'gnus-pseudo))
7597
7598(defalias 'gnus-summary-score 'gnus-summary-article-score)
7599(make-obsolete 'gnus-summary-score 'gnus-summary-article-score)
7600(defun gnus-summary-article-score ()
7601 "Return current article score."
7602 (or (cdr (assq (gnus-summary-article-number) gnus-newsgroup-scored))
7603 gnus-summary-default-score 0))
7604
7605(defun gnus-summary-recenter ()
7606 "Center point in the summary window.
7607If `gnus-auto-center-summary' is nil, or the article buffer isn't
7608displayed, no centering will be performed."
7609 ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
7610 ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
7611 (let* ((top (cond ((< (window-height) 4) 0)
7612 ((< (window-height) 7) 1)
7613 (t 2)))
7614 (height (1- (window-height)))
7615 (bottom (save-excursion (goto-char (point-max))
7616 (forward-line (- height))
7617 (point)))
7618 (window (get-buffer-window (current-buffer))))
7619 (and
7620 ;; The user has to want it,
7621 gnus-auto-center-summary
7622 ;; the article buffer must be displayed,
7623 (get-buffer-window gnus-article-buffer)
7624 ;; Set the window start to either `bottom', which is the biggest
7625 ;; possible valid number, or the second line from the top,
7626 ;; whichever is the least.
7627 (set-window-start
7628 window (min bottom (save-excursion (forward-line (- top)) (point)))))))
7629
7630;; Function written by Stainless Steel Rat <ratinox@ccs.neu.edu>.
7631(defun gnus-short-group-name (group &optional levels)
7632 "Collapse GROUP name LEVELS."
7633 (let* ((name "") (foreign "") (depth -1) (skip 1)
7634 (levels (or levels
7635 (progn
7636 (while (string-match "\\." group skip)
7637 (setq skip (match-end 0)
7638 depth (+ depth 1)))
7639 depth))))
7640 (if (string-match ":" group)
7641 (setq foreign (substring group 0 (match-end 0))
7642 group (substring group (match-end 0))))
7643 (while group
7644 (if (and (string-match "\\." group) (> levels 0))
7645 (setq name (concat name (substring group 0 1))
7646 group (substring group (match-end 0))
7647 levels (- levels 1)
7648 name (concat name "."))
7649 (setq name (concat foreign name group)
7650 group nil)))
7651 name))
7652
7653(defun gnus-summary-jump-to-group (newsgroup)
7654 "Move point to NEWSGROUP in group mode buffer."
7655 ;; Keep update point of group mode buffer if visible.
7656 (if (eq (current-buffer) (get-buffer gnus-group-buffer))
7657 (save-window-excursion
7658 ;; Take care of tree window mode.
7659 (if (get-buffer-window gnus-group-buffer)
7660 (pop-to-buffer gnus-group-buffer))
7661 (gnus-group-jump-to-group newsgroup))
7662 (save-excursion
7663 ;; Take care of tree window mode.
7664 (if (get-buffer-window gnus-group-buffer)
7665 (pop-to-buffer gnus-group-buffer)
7666 (set-buffer gnus-group-buffer))
7667 (gnus-group-jump-to-group newsgroup))))
7668
7669;; This function returns a list of article numbers based on the
7670;; difference between the ranges of read articles in this group and
7671;; the range of active articles.
7672(defun gnus-list-of-unread-articles (group)
7673 (let* ((read (nth 2 (nth 2 (gnus-gethash group gnus-newsrc-hashtb))))
7674 (active (gnus-gethash group gnus-active-hashtb))
7675 (last (cdr active))
7676 first nlast unread)
7677 ;; If none are read, then all are unread.
7678 (if (not read)
7679 (setq first (car active))
7680 ;; If the range of read articles is a single range, then the
7681 ;; first unread article is the article after the last read
7682 ;; article. Sounds logical, doesn't it?
7683 (if (not (listp (cdr read)))
7684 (setq first (1+ (cdr read)))
7685 ;; `read' is a list of ranges.
7686 (if (/= (setq nlast (or (and (numberp (car read)) (car read))
7687 (car (car read)))) 1)
7688 (setq first 1))
7689 (while read
7690 (if first
7691 (while (< first nlast)
7692 (setq unread (cons first unread))
7693 (setq first (1+ first))))
7694 (setq first (1+ (if (atom (car read)) (car read) (cdr (car read)))))
7695 (setq nlast (if (atom (car (cdr read)))
7696 (car (cdr read))
7697 (car (car (cdr read)))))
7698 (setq read (cdr read)))))
7699 ;; And add the last unread articles.
7700 (while (<= first last)
7701 (setq unread (cons first unread))
7702 (setq first (1+ first)))
7703 ;; Return the list of unread articles.
7704 (nreverse unread)))
7705
7706(defun gnus-list-of-read-articles (group)
7707 (let ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
7708 (active (gnus-gethash group gnus-active-hashtb)))
7709 (and info active
7710 (gnus-sorted-complement
7711 (gnus-uncompress-range active)
7712 (gnus-list-of-unread-articles group)))))
7713
7714;; Various summary commands
7715
7716(defun gnus-summary-universal-argument ()
7717 "Perform any operation on all articles marked with the process mark."
7718 (interactive)
7719 (gnus-set-global-variables)
7720 (let ((articles (reverse gnus-newsgroup-processable))
7721 func)
7722 (or articles (error "No articles marked"))
7723 (or (setq func (key-binding (read-key-sequence "C-c C-u")))
7724 (error "Undefined key"))
7725 (while articles
7726 (gnus-summary-goto-subject (car articles))
7727 (command-execute func)
7728 (gnus-summary-remove-process-mark (car articles))
7729 (setq articles (cdr articles)))))
7730
7731(defun gnus-summary-toggle-truncation (&optional arg)
7732 "Toggle truncation of summary lines.
7733With arg, turn line truncation on iff arg is positive."
7734 (interactive "P")
7735 (setq truncate-lines
7736 (if (null arg) (not truncate-lines)
7737 (> (prefix-numeric-value arg) 0)))
7738 (redraw-display))
7739
7740(defun gnus-summary-reselect-current-group (&optional all)
7741 "Once exit and then reselect the current newsgroup.
7742The prefix argument ALL means to select all articles."
7743 (interactive "P")
7744 (gnus-set-global-variables)
7745 (let ((current-subject (gnus-summary-article-number))
7746 (group gnus-newsgroup-name))
7747 (setq gnus-newsgroup-begin nil)
7748 (gnus-summary-exit t)
7749 ;; We have to adjust the point of group mode buffer because the
7750 ;; current point was moved to the next unread newsgroup by
7751 ;; exiting.
7752 (gnus-summary-jump-to-group group)
7753 (gnus-group-read-group all t)
7754 (gnus-summary-goto-subject current-subject)))
7755
7756(defun gnus-summary-rescan-group (&optional all)
7757 "Exit the newsgroup, ask for new articles, and select the newsgroup."
7758 (interactive "P")
7759 (gnus-set-global-variables)
7760 ;; Fix by Ilja Weis <kult@uni-paderborn.de>.
7761 (let ((group gnus-newsgroup-name))
7762 (gnus-summary-exit)
7763 (gnus-summary-jump-to-group group)
7764 (save-excursion
7765 (set-buffer gnus-group-buffer)
7766 (gnus-group-get-new-news-this-group 1))
7767 (gnus-summary-jump-to-group group)
7768 (gnus-group-read-group all)))
7769
7770(defun gnus-summary-update-info ()
7771 (let* ((group gnus-newsgroup-name))
7772 (if gnus-newsgroup-kill-headers
7773 (setq gnus-newsgroup-killed
7774 (gnus-compress-sequence
7775 (nconc
7776 (gnus-set-sorted-intersection
7777 (gnus-uncompress-range gnus-newsgroup-killed)
7778 (setq gnus-newsgroup-unselected
7779 (sort gnus-newsgroup-unselected '<)))
7780 (setq gnus-newsgroup-unreads
7781 (sort gnus-newsgroup-unreads '<))) t)))
7782 (or (listp (cdr gnus-newsgroup-killed))
7783 (setq gnus-newsgroup-killed (list gnus-newsgroup-killed)))
7784 (let ((headers gnus-newsgroup-headers))
7785 (gnus-close-group group)
7786 (run-hooks 'gnus-exit-group-hook)
7787 (gnus-update-read-articles
7788 group gnus-newsgroup-unreads gnus-newsgroup-unselected
7789 gnus-newsgroup-marked
7790 t gnus-newsgroup-replied gnus-newsgroup-expirable
7791 gnus-newsgroup-killed gnus-newsgroup-dormant
7792 gnus-newsgroup-bookmarks
7793 (and gnus-save-score gnus-newsgroup-scored))
7794 (and gnus-use-cross-reference
7795 (gnus-mark-xrefs-as-read
7796 group headers gnus-newsgroup-unreads gnus-newsgroup-expirable))
7797 ;; Do adaptive scoring, and possibly save score files.
7798 (and gnus-newsgroup-adaptive
7799 (gnus-score-adaptive))
7800 (and gnus-use-scoring
7801 (fboundp 'gnus-score-save)
7802 (funcall 'gnus-score-save))
7803 ;; Do not switch windows but change the buffer to work.
7804 (set-buffer gnus-group-buffer)
7805 (or (gnus-ephemeral-group-p gnus-newsgroup-name)
7806 (gnus-group-update-group group)))))
7807
7808(defun gnus-summary-exit (&optional temporary)
7809 "Exit reading current newsgroup, and then return to group selection mode.
7810gnus-exit-group-hook is called with no arguments if that value is non-nil."
7811 (interactive)
7812 (gnus-set-global-variables)
7813 (gnus-kill-save-kill-buffer)
7814 (let* ((group gnus-newsgroup-name)
7815 (quit-config (gnus-group-quit-config gnus-newsgroup-name))
7816 (mode major-mode)
7817 (buf (current-buffer)))
7818 (run-hooks 'gnus-summary-prepare-exit-hook)
7819 ;; Make all changes in this group permanent.
7820 (gnus-summary-update-info)
7821 (set-buffer buf)
7822 (and gnus-use-cache (gnus-cache-possibly-remove-articles))
7823 ;; Make sure where I was, and go to next newsgroup.
7824 (set-buffer gnus-group-buffer)
7825 (or quit-config
7826 (progn
7827 (gnus-group-jump-to-group group)
7828 (gnus-group-next-unread-group 1)))
7829 (if temporary
7830 nil ;Nothing to do.
7831 ;; We set all buffer-local variables to nil. It is unclear why
7832 ;; this is needed, but if we don't, buffer-local variables are
7833 ;; not garbage-collected, it seems. This would the lead to en
7834 ;; ever-growing Emacs.
7835 (set-buffer buf)
7836 (gnus-summary-clear-local-variables)
7837 ;; We clear the global counterparts of the buffer-local
7838 ;; variables as well, just to be on the safe side.
7839 (gnus-configure-windows 'group 'force)
7840 (gnus-summary-clear-local-variables)
7841 ;; Return to group mode buffer.
7842 (if (eq mode 'gnus-summary-mode)
7843 (gnus-kill-buffer buf))
7844 (if (get-buffer gnus-article-buffer)
7845 (bury-buffer gnus-article-buffer))
7846 (setq gnus-current-select-method gnus-select-method)
7847 (pop-to-buffer gnus-group-buffer)
7848 (if (not quit-config)
7849 (progn
7850 (gnus-group-jump-to-group group)
7851 (gnus-group-next-unread-group 1))
7852 (if (not (buffer-name (car quit-config)))
7853 (gnus-configure-windows 'group 'force)
7854 (set-buffer (car quit-config))
7855 (and (eq major-mode 'gnus-summary-mode)
7856 (gnus-set-global-variables))
7857 (gnus-configure-windows (cdr quit-config))))
7858 (run-hooks 'gnus-summary-exit-hook))))
7859
7860(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update)
7861(defun gnus-summary-exit-no-update (&optional no-questions)
7862 "Quit reading current newsgroup without updating read article info."
7863 (interactive)
7864 (gnus-set-global-variables)
7865 (let* ((group gnus-newsgroup-name)
7866 (quit-config (gnus-group-quit-config group)))
7867 (if (or no-questions
7868 gnus-expert-user
7869 (gnus-y-or-n-p "Do you really wanna quit reading this group? "))
7870 (progn
7871 (gnus-close-group group)
7872 (gnus-summary-clear-local-variables)
7873 (set-buffer gnus-group-buffer)
7874 (gnus-summary-clear-local-variables)
7875 ;; Return to group selection mode.
7876 (gnus-configure-windows 'group 'force)
7877 (if (get-buffer gnus-summary-buffer)
7878 (kill-buffer gnus-summary-buffer))
7879 (if (get-buffer gnus-article-buffer)
7880 (bury-buffer gnus-article-buffer))
7881 (if (equal (gnus-group-group-name) group)
7882 (gnus-group-next-unread-group 1))
7883 (if quit-config
7884 (progn
7885 (if (not (buffer-name (car quit-config)))
7886 (gnus-configure-windows 'group 'force)
7887 (set-buffer (car quit-config))
7888 (and (eq major-mode 'gnus-summary-mode)
7889 (gnus-set-global-variables))
7890 (gnus-configure-windows (cdr quit-config)))))))))
7891
7892;; Suggested by Andrew Eskilsson <pi92ae@pt.hk-r.se>.
7893(defun gnus-summary-fetch-faq (group)
7894 "Fetch the FAQ for the current group."
7895 (interactive (list gnus-newsgroup-name))
7896 (let (gnus-faq-buffer)
7897 (and (setq gnus-faq-buffer (gnus-group-fetch-faq group))
7898 (gnus-configure-windows 'summary-faq))))
7899
7900;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
7901(defun gnus-summary-describe-group (&optional force)
7902 "Describe the current newsgroup."
7903 (interactive "P")
7904 (gnus-group-describe-group force gnus-newsgroup-name))
7905
7906(defun gnus-summary-describe-briefly ()
7907 "Describe summary mode commands briefly."
7908 (interactive)
7909 (gnus-message 6
7910 (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
7911
7912;; Walking around group mode buffer from summary mode.
7913
7914(defun gnus-summary-next-group (&optional no-article target-group backward)
7915 "Exit current newsgroup and then select next unread newsgroup.
7916If prefix argument NO-ARTICLE is non-nil, no article is selected
7917initially. If NEXT-GROUP, go to this group. If BACKWARD, go to
7918previous group instead."
7919 (interactive "P")
7920 (gnus-set-global-variables)
7921 (let ((current-group gnus-newsgroup-name)
7922 (current-buffer (current-buffer))
7923 entered)
7924 ;; First we semi-exit this group to update Xrefs and all variables.
7925 ;; We can't do a real exit, because the window conf must remain
7926 ;; the same in case the user is prompted for info, and we don't
7927 ;; want the window conf to change before that...
7928 (gnus-summary-exit t)
7929 (while (not entered)
7930 ;; Then we find what group we are supposed to enter.
7931 (set-buffer gnus-group-buffer)
7932 (gnus-group-jump-to-group current-group)
7933 (setq target-group
7934 (or target-group
7935 (if (eq gnus-keep-same-level 'best)
7936 (gnus-summary-best-group gnus-newsgroup-name)
7937 (gnus-summary-search-group backward gnus-keep-same-level))))
7938 (if (not target-group)
7939 ;; There are no further groups, so we return to the group
7940 ;; buffer.
7941 (progn
7942 (gnus-message 5 "Returning to the group buffer")
7943 (setq entered t)
7944 (set-buffer current-buffer)
7945 (gnus-summary-exit))
7946 ;; We try to enter the target group.
7947 (gnus-group-jump-to-group target-group)
7948 (let ((unreads (gnus-group-group-unread)))
7949 (if (and (or (eq t unreads)
7950 (and unreads (not (zerop unreads))))
7951 (gnus-summary-read-group
7952 target-group nil no-article current-buffer))
7953 (setq entered t)
7954 (setq current-group target-group
7955 target-group nil)))))))
7956
7957(defun gnus-summary-next-group-old (&optional no-article group backward)
7958 "Exit current newsgroup and then select next unread newsgroup.
7959If prefix argument NO-ARTICLE is non-nil, no article is selected initially.
7960If BACKWARD, go to previous group instead."
7961 (interactive "P")
7962 (gnus-set-global-variables)
7963 (let ((ingroup gnus-newsgroup-name)
7964 (sumbuf (current-buffer))
7965 num)
7966 (set-buffer gnus-group-buffer)
7967 (if (and group
7968 (or (and (numberp (setq num (car (gnus-gethash
7969 group gnus-newsrc-hashtb))))
7970 (< num 1))
7971 (null num)))
7972 (progn
7973 (gnus-group-jump-to-group group)
7974 (setq group nil))
7975 (gnus-group-jump-to-group ingroup))
7976 (gnus-summary-search-group backward)
7977 (let ((group (or group (gnus-summary-search-group backward))))
7978 (set-buffer sumbuf)
7979 (gnus-summary-exit t) ;Update all information.
7980 (if (null group)
7981 (gnus-summary-exit-no-update t)
7982 (gnus-group-jump-to-group ingroup)
7983 (setq group (gnus-summary-search-group backward))
7984 (gnus-message 5 "Selecting %s..." group)
7985 (set-buffer gnus-group-buffer)
7986 ;; We are now in group mode buffer.
7987 ;; Make sure group mode buffer point is on GROUP.
7988 (gnus-group-jump-to-group group)
7989 (if (not (eq gnus-auto-select-next 'quietly))
7990 (progn
7991 (gnus-summary-read-group group nil no-article sumbuf)
7992 (and (string= gnus-newsgroup-name ingroup)
7993 (bufferp sumbuf) (buffer-name sumbuf)
7994 (progn
7995 (set-buffer (setq gnus-summary-buffer sumbuf))
7996 (gnus-summary-exit-no-update t))))
7997 (let ((prevgroup group))
7998 (gnus-group-jump-to-group ingroup)
7999 (setq group (gnus-summary-search-group backward))
8000 (gnus-summary-read-group group nil no-article sumbuf)
8001 (while (and (string= gnus-newsgroup-name ingroup)
8002 (bufferp sumbuf)
8003 (buffer-name sumbuf)
8004 (not (string= prevgroup (gnus-group-group-name))))
8005 (set-buffer gnus-group-buffer)
8006 (gnus-summary-read-group
8007 (setq prevgroup (gnus-group-group-name))
8008 nil no-article sumbuf))
8009 (and (string= prevgroup (gnus-group-group-name))
8010 ;; We have reached the final group in the group
8011 ;; buffer.
8012 (progn
8013 (if (buffer-name sumbuf)
8014 (progn
8015 (set-buffer sumbuf)
8016 (gnus-summary-exit)))))))))))
8017
8018(defun gnus-summary-prev-group (&optional no-article)
8019 "Exit current newsgroup and then select previous unread newsgroup.
8020If prefix argument NO-ARTICLE is non-nil, no article is selected initially."
8021 (interactive "P")
8022 (gnus-summary-next-group no-article nil t))
8023
8024;; Walking around summary lines.
8025
8026(defun gnus-summary-first-subject (&optional unread)
8027 "Go to the first unread subject.
8028If UNREAD is non-nil, go to the first unread article.
8029Returns nil if there are no unread articles."
8030 (interactive "P")
8031 (prog1
8032 (cond ((not unread)
8033 (goto-char (point-min)))
8034 ((gnus-goto-char
8035 (text-property-any
8036 (point-min) (point-max) 'gnus-mark gnus-unread-mark))
8037 t)
8038 (t
8039 ;; There are no unread articles.
8040 (gnus-message 3 "No more unread articles")
8041 nil))
8042 (gnus-summary-position-cursor)))
8043
8044(defun gnus-summary-next-subject (n &optional unread dont-display)
8045 "Go to next N'th summary line.
8046If N is negative, go to the previous N'th subject line.
8047If UNREAD is non-nil, only unread articles are selected.
8048The difference between N and the actual number of steps taken is
8049returned."
745bc783 8050 (interactive "p")
41487370
LMI
8051 (let ((backward (< n 0))
8052 (n (abs n)))
8053 (while (and (> n 0)
8054 (gnus-summary-search-forward unread nil backward))
8055 (setq n (1- n)))
8056 (if (/= 0 n) (gnus-message 7 "No more%s articles"
8057 (if unread " unread" "")))
8058 (or dont-display
8059 (progn
8060 (gnus-summary-recenter)
8061 (gnus-summary-position-cursor)))
8062 n))
745bc783 8063
b027f415 8064(defun gnus-summary-next-unread-subject (n)
41487370 8065 "Go to next N'th unread summary line."
745bc783 8066 (interactive "p")
b027f415 8067 (gnus-summary-next-subject n t))
745bc783 8068
b027f415 8069(defun gnus-summary-prev-subject (n &optional unread)
41487370 8070 "Go to previous N'th summary line.
745bc783
JB
8071If optional argument UNREAD is non-nil, only unread article is selected."
8072 (interactive "p")
41487370 8073 (gnus-summary-next-subject (- n) unread))
745bc783 8074
b027f415 8075(defun gnus-summary-prev-unread-subject (n)
41487370 8076 "Go to previous N'th unread summary line."
745bc783 8077 (interactive "p")
41487370
LMI
8078 (gnus-summary-next-subject (- n) t))
8079
8080(defun gnus-summary-goto-subject (article)
8081 "Go the subject line of ARTICLE."
8082 (interactive
8083 (list
8084 (string-to-int
8085 (completing-read "Article number: "
8086 (mapcar
8087 (lambda (headers)
8088 (list
8089 (int-to-string (mail-header-number headers))))
8090 gnus-newsgroup-headers)
8091 nil 'require-match))))
8092 (or article (error "No article number"))
8093 (let ((b (point)))
8094 (if (not (gnus-goto-char (text-property-any (point-min) (point-max)
8095 'gnus-number article)))
8096 ()
8097 (gnus-summary-show-thread)
8098 ;; Skip dummy articles.
8099 (if (eq (gnus-summary-article-mark) gnus-dummy-mark)
8100 (forward-line 1))
8101 (prog1
8102 (if (not (eobp))
8103 article
8104 (goto-char b)
8105 nil)
8106 (gnus-summary-position-cursor)))))
745bc783 8107
b027f415 8108;; Walking around summary lines with displaying articles.
745bc783 8109
41487370
LMI
8110(defun gnus-summary-expand-window (&optional arg)
8111 "Make the summary buffer take up the entire Emacs frame.
8112Given a prefix, will force an `article' buffer configuration."
8113 (interactive "P")
8114 (gnus-set-global-variables)
8115 (if arg
8116 (gnus-configure-windows 'article 'force)
8117 (gnus-configure-windows 'summary 'force)))
745bc783 8118
b027f415 8119(defun gnus-summary-display-article (article &optional all-header)
41487370
LMI
8120 "Display ARTICLE in article buffer."
8121 (gnus-set-global-variables)
745bc783
JB
8122 (if (null article)
8123 nil
41487370
LMI
8124 (prog1
8125 (gnus-article-prepare article all-header)
8126 (gnus-summary-show-thread)
8127 (if (eq (gnus-summary-article-mark) gnus-dummy-mark)
8128 (progn
8129 (forward-line 1)
8130 (gnus-summary-position-cursor)))
8131 (run-hooks 'gnus-select-article-hook)
8132 (gnus-summary-recenter)
8133 (gnus-summary-goto-subject article)
8134 ;; Successfully display article.
8135 (gnus-summary-update-line)
8136 (gnus-article-set-window-start
8137 (cdr (assq article gnus-newsgroup-bookmarks)))
8138 t)))
8139
8140(defun gnus-summary-select-article (&optional all-headers force pseudo article)
745bc783 8141 "Select the current article.
41487370
LMI
8142If ALL-HEADERS is non-nil, show all header fields. If FORCE is
8143non-nil, the article will be re-fetched even if it already present in
8144the article buffer. If PSEUDO is non-nil, pseudo-articles will also
8145be displayed."
8146 (and (not pseudo) (gnus-summary-pseudo-article)
8147 (error "This is a pseudo-article."))
8148 (let ((article (or article (gnus-summary-article-number)))
8149 (all-headers (not (not all-headers))) ;Must be T or NIL.
8150 did)
8151 (prog1
8152 (save-excursion
8153 (set-buffer gnus-summary-buffer)
8154 (if (or (null gnus-current-article)
8155 (null gnus-article-current)
8156 (null (get-buffer gnus-article-buffer))
8157 (not (eq article (cdr gnus-article-current)))
8158 (not (equal (car gnus-article-current) gnus-newsgroup-name))
8159 force)
8160 ;; The requested article is different from the current article.
8161 (progn
8162 (gnus-summary-display-article article all-headers)
8163 (setq did article))
8164 (if (or all-headers gnus-show-all-headers)
8165 (gnus-article-show-all-headers))
8166 nil))
8167 (if did
8168 (gnus-article-set-window-start
8169 (cdr (assq article gnus-newsgroup-bookmarks)))))))
745bc783 8170
b027f415 8171(defun gnus-summary-set-current-mark (&optional current-mark)
41487370
LMI
8172 "Obsolete function."
8173 nil)
8174
8175(defun gnus-summary-next-article (&optional unread subject backward)
8176 "Select the next article.
8177If UNREAD, only unread articles are selected.
8178If SUBJECT, only articles with SUBJECT are selected.
8179If BACKWARD, the previous article is selected instead of the next."
745bc783 8180 (interactive "P")
41487370
LMI
8181 (gnus-set-global-variables)
8182 (let (header)
8183 (cond
8184 ;; Is there such an article?
8185 ((and (gnus-summary-search-forward unread subject backward)
8186 (or (gnus-summary-display-article (gnus-summary-article-number))
8187 (eq (gnus-summary-article-mark) gnus-canceled-mark)))
8188 (gnus-summary-position-cursor))
8189 ;; If not, we try the first unread, if that is wanted.
8190 ((and subject
8191 gnus-auto-select-same
8192 (or (gnus-summary-first-unread-article)
8193 (eq (gnus-summary-article-mark) gnus-canceled-mark)))
8194 (gnus-summary-position-cursor)
8195 (gnus-message 6 "Wrapped"))
8196 ;; Try to get next/previous article not displayed in this group.
8197 ((and gnus-auto-extend-newsgroup
8198 (not unread) (not subject)
8199 (setq header (gnus-more-header-forward backward)))
8200 (gnus-extend-newsgroup header backward)
8201 (let ((buffer-read-only nil))
8202 (goto-char (if backward (point-min) (point-max)))
8203 (gnus-summary-prepare-threads (list header)))
8204 (gnus-summary-goto-article (if backward gnus-newsgroup-begin
8205 gnus-newsgroup-end)))
8206 ;; Go to next/previous group.
8207 (t
8208 (or (gnus-ephemeral-group-p gnus-newsgroup-name)
8209 (gnus-summary-jump-to-group gnus-newsgroup-name))
8210 (let ((cmd last-command-char)
8211 (group
8212 (if (eq gnus-keep-same-level 'best)
8213 (gnus-summary-best-group gnus-newsgroup-name)
8214 (gnus-summary-search-group backward gnus-keep-same-level))))
8215 ;; For some reason, the group window gets selected. We change
8216 ;; it back.
8217 (select-window (get-buffer-window (current-buffer)))
8218 ;; Keep just the event type of CMD.
8219 ;(and (listp cmd) (setq cmd (car cmd)))
8220 ;; Select next unread newsgroup automagically.
8221 (cond
8222 ((not gnus-auto-select-next)
8223 (gnus-message 7 "No more%s articles" (if unread " unread" "")))
8224 ((eq gnus-auto-select-next 'quietly)
8225 ;; Select quietly.
8226 (if (gnus-ephemeral-group-p gnus-newsgroup-name)
8227 (gnus-summary-exit)
8228 (gnus-message 7 "No more%s articles (%s)..."
8229 (if unread " unread" "")
8230 (if group (concat "selecting " group)
8231 "exiting"))
8232 (gnus-summary-next-group nil group backward)))
8233 (t
8234 (let ((keystrokes '(?\C-n ?\C-p))
8235 key)
8236 (while (or (null key) (memq key keystrokes))
8237 (gnus-message
8238 7 "No more%s articles%s" (if unread " unread" "")
8239 (if (and group
8240 (not (gnus-ephemeral-group-p gnus-newsgroup-name)))
8241 (format " (Type %s for %s [%s])"
8242 (single-key-description cmd) group
8243 (car (gnus-gethash group gnus-newsrc-hashtb)))
8244 (format " (Type %s to exit %s)"
8245 (single-key-description cmd)
8246 gnus-newsgroup-name)))
8247 ;; Confirm auto selection.
8248 (let* ((event (read-char)))
8249 (setq key (if (listp event) (car event) event))
8250 (if (memq key keystrokes)
8251 (let ((obuf (current-buffer)))
8252 (switch-to-buffer gnus-group-buffer)
8253 (and group
8254 (gnus-group-jump-to-group group))
8255 (condition-case ()
8256 (execute-kbd-macro (char-to-string key))
8257 (error (ding) nil))
8258 (setq group (gnus-group-group-name))
8259 (switch-to-buffer obuf)))))
8260 (if (equal key cmd)
8261 (if (or (not group)
8262 (gnus-ephemeral-group-p gnus-newsgroup-name))
8263 (gnus-summary-exit)
8264 (gnus-summary-next-group nil group backward))
8265 (execute-kbd-macro (char-to-string key)))))))))))
745bc783 8266
b027f415 8267(defun gnus-summary-next-unread-article ()
745bc783
JB
8268 "Select unread article after current one."
8269 (interactive)
b027f415
RS
8270 (gnus-summary-next-article t (and gnus-auto-select-same
8271 (gnus-summary-subject-string))))
745bc783 8272
41487370
LMI
8273(defun gnus-summary-prev-article (&optional unread subject)
8274 "Select the article after the current one.
8275If UNREAD is non-nil, only unread articles are selected."
745bc783 8276 (interactive "P")
41487370 8277 (gnus-summary-next-article unread subject t))
745bc783 8278
b027f415 8279(defun gnus-summary-prev-unread-article ()
41487370 8280 "Select unred article before current one."
745bc783 8281 (interactive)
b027f415
RS
8282 (gnus-summary-prev-article t (and gnus-auto-select-same
8283 (gnus-summary-subject-string))))
745bc783 8284
41487370 8285(defun gnus-summary-next-page (&optional lines circular)
745bc783 8286 "Show next page of selected article.
eb8c3be9 8287If end of article, select next article.
41487370
LMI
8288Argument LINES specifies lines to be scrolled up.
8289If CIRCULAR is non-nil, go to the start of the article instead of
8290instead of selecting the next article when reaching the end of the
8291current article."
745bc783 8292 (interactive "P")
41487370
LMI
8293 (setq gnus-summary-buffer (current-buffer))
8294 (gnus-set-global-variables)
b027f415 8295 (let ((article (gnus-summary-article-number))
745bc783 8296 (endp nil))
41487370 8297 (gnus-configure-windows 'article)
745bc783 8298 (if (or (null gnus-current-article)
41487370
LMI
8299 (null gnus-article-current)
8300 (/= article (cdr gnus-article-current))
8301 (not (equal (car gnus-article-current) gnus-newsgroup-name)))
745bc783 8302 ;; Selected subject is different from current article's.
b027f415 8303 (gnus-summary-display-article article)
41487370
LMI
8304 (gnus-eval-in-buffer-window
8305 gnus-article-buffer
8306 (setq endp (gnus-article-next-page lines)))
8307 (if endp
8308 (cond (circular
8309 (gnus-summary-beginning-of-article))
8310 (lines
8311 (gnus-message 3 "End of message"))
8312 ((null lines)
8313 (gnus-summary-next-unread-article)))))
8314 (gnus-summary-recenter)
8315 (gnus-summary-position-cursor)))
8316
8317(defun gnus-summary-prev-page (&optional lines)
745bc783
JB
8318 "Show previous page of selected article.
8319Argument LINES specifies lines to be scrolled down."
8320 (interactive "P")
41487370 8321 (gnus-set-global-variables)
b027f415 8322 (let ((article (gnus-summary-article-number)))
41487370 8323 (gnus-configure-windows 'article)
745bc783 8324 (if (or (null gnus-current-article)
41487370
LMI
8325 (null gnus-article-current)
8326 (/= article (cdr gnus-article-current))
8327 (not (equal (car gnus-article-current) gnus-newsgroup-name)))
745bc783 8328 ;; Selected subject is different from current article's.
b027f415 8329 (gnus-summary-display-article article)
41487370 8330 (gnus-summary-recenter)
b027f415 8331 (gnus-eval-in-buffer-window gnus-article-buffer
41487370
LMI
8332 (gnus-article-prev-page lines))))
8333 (gnus-summary-position-cursor))
745bc783 8334
b027f415 8335(defun gnus-summary-scroll-up (lines)
745bc783
JB
8336 "Scroll up (or down) one line current article.
8337Argument LINES specifies lines to be scrolled up (or down if negative)."
8338 (interactive "p")
41487370
LMI
8339 (gnus-set-global-variables)
8340 (gnus-configure-windows 'article)
8341 (or (gnus-summary-select-article nil nil 'pseudo)
8342 (gnus-eval-in-buffer-window
8343 gnus-article-buffer
8344 (cond ((> lines 0)
8345 (if (gnus-article-next-page lines)
8346 (gnus-message 3 "End of message")))
8347 ((< lines 0)
8348 (gnus-article-prev-page (- lines))))))
8349 (gnus-summary-recenter)
8350 (gnus-summary-position-cursor))
745bc783 8351
b027f415 8352(defun gnus-summary-next-same-subject ()
745bc783
JB
8353 "Select next article which has the same subject as current one."
8354 (interactive)
41487370 8355 (gnus-set-global-variables)
b027f415 8356 (gnus-summary-next-article nil (gnus-summary-subject-string)))
745bc783 8357
b027f415 8358(defun gnus-summary-prev-same-subject ()
745bc783
JB
8359 "Select previous article which has the same subject as current one."
8360 (interactive)
41487370 8361 (gnus-set-global-variables)
b027f415 8362 (gnus-summary-prev-article nil (gnus-summary-subject-string)))
745bc783 8363
b027f415 8364(defun gnus-summary-next-unread-same-subject ()
745bc783
JB
8365 "Select next unread article which has the same subject as current one."
8366 (interactive)
41487370 8367 (gnus-set-global-variables)
b027f415 8368 (gnus-summary-next-article t (gnus-summary-subject-string)))
745bc783 8369
b027f415 8370(defun gnus-summary-prev-unread-same-subject ()
745bc783
JB
8371 "Select previous unread article which has the same subject as current one."
8372 (interactive)
41487370 8373 (gnus-set-global-variables)
b027f415 8374 (gnus-summary-prev-article t (gnus-summary-subject-string)))
745bc783 8375
41487370
LMI
8376(defun gnus-summary-first-unread-article ()
8377 "Select the first unread article.
8378Return nil if there are no unread articles."
8379 (interactive)
8380 (gnus-set-global-variables)
8381 (prog1
8382 (if (gnus-summary-first-subject t)
8383 (progn
8384 (gnus-summary-show-thread)
8385 (gnus-summary-first-subject t)
8386 (gnus-summary-display-article (gnus-summary-article-number))))
8387 (gnus-summary-position-cursor)))
745bc783 8388
41487370
LMI
8389(defun gnus-summary-best-unread-article ()
8390 "Select the unread article with the highest score."
8391 (interactive)
8392 (gnus-set-global-variables)
8393 (let ((best -1000000)
8394 article score)
8395 (save-excursion
8396 (or (gnus-summary-first-subject t)
8397 (error "No unread articles"))
8398 (while
8399 (and
8400 (progn
8401 (and (> (setq score (gnus-summary-article-score)) best)
8402 (setq best score
8403 article (gnus-summary-article-number)))
8404 t)
8405 (gnus-summary-search-subject nil t))))
8406 (if (not article)
8407 (error "No unread articles")
8408 (gnus-summary-goto-article article))
8409 (gnus-summary-position-cursor)))
745bc783 8410
41487370
LMI
8411(defun gnus-summary-goto-article (article &optional all-headers)
8412 "Fetch ARTICLE and display it if it exists.
8413If ALL-HEADERS is non-nil, no header lines are hidden."
8414 (interactive
8415 (list
8416 (string-to-int
8417 (completing-read
8418 "Article number: "
8419 (mapcar (lambda (headers)
8420 (list (int-to-string (mail-header-number headers))))
8421 gnus-newsgroup-headers)
8422 nil 'require-match))))
8423 (prog1
8424 (and (gnus-summary-goto-subject article)
8425 (gnus-summary-display-article article all-headers))
8426 (gnus-summary-position-cursor)))
745bc783 8427
41487370
LMI
8428(defun gnus-summary-goto-last-article ()
8429 "Go to the previously read article."
8430 (interactive)
8431 (prog1
8432 (and gnus-last-article
8433 (gnus-summary-goto-article gnus-last-article))
8434 (gnus-summary-position-cursor)))
8435
8436(defun gnus-summary-pop-article (number)
8437 "Pop one article off the history and go to the previous.
8438NUMBER articles will be popped off."
745bc783 8439 (interactive "p")
41487370
LMI
8440 (let (to)
8441 (setq gnus-newsgroup-history
8442 (cdr (setq to (nthcdr number gnus-newsgroup-history))))
8443 (if to
8444 (gnus-summary-goto-article (car to))
8445 (error "Article history empty")))
8446 (gnus-summary-position-cursor))
8447
8448;; Summary article oriented commands
8449
8450(defun gnus-summary-refer-parent-article (n)
8451 "Refer parent article N times.
8452The difference between N and the number of articles fetched is returned."
8453 (interactive "p")
8454 (gnus-set-global-variables)
8455 (while
8456 (and
8457 (> n 0)
8458 (let ((ref (mail-header-references (gnus-get-header-by-num
8459 (gnus-summary-article-number)))))
8460 (if (and ref (not (equal ref ""))
8461 (string-match "<[^<>]*>[ \t]*$" ref))
8462 (gnus-summary-refer-article
8463 (substring ref (match-beginning 0) (match-end 0)))
8464 (gnus-message 1 "No references in article %d"
8465 (gnus-summary-article-number))
8466 nil)))
8467 (setq n (1- n)))
8468 (gnus-summary-position-cursor)
8469 n)
8470
8471(defun gnus-summary-refer-article (message-id)
8472 "Refer article specified by MESSAGE-ID.
8473NOTE: This command only works with newsgroups that use real or simulated NNTP."
8474 (interactive "sMessage-ID: ")
8475 (if (or (not (stringp message-id))
8476 (zerop (length message-id)))
8477 ()
8478 ;; Construct the correct Message-ID if necessary.
8479 ;; Suggested by tale@pawl.rpi.edu.
8480 (or (string-match "^<" message-id)
8481 (setq message-id (concat "<" message-id)))
8482 (or (string-match ">$" message-id)
8483 (setq message-id (concat message-id ">")))
8484 (let ((header (car (gnus-gethash (downcase message-id)
8485 gnus-newsgroup-dependencies))))
8486 (if header
8487 (or (gnus-summary-goto-article (mail-header-number header))
8488 ;; The header has been read, but the article had been
8489 ;; expunged, so we insert it again.
8490 (progn
8491 (gnus-summary-insert-line
8492 nil header 0 nil gnus-read-mark nil nil
8493 (mail-header-subject header))
8494 (forward-line -1)
8495 (mail-header-number header)))
8496 (let ((gnus-override-method gnus-refer-article-method)
8497 (gnus-ancient-mark gnus-read-mark)
8498 (tmp-point (window-start
8499 (get-buffer-window gnus-article-buffer)))
8500 number tmp-buf)
8501 (and gnus-refer-article-method
8502 (gnus-check-server gnus-refer-article-method))
8503 ;; Save the old article buffer.
8504 (save-excursion
8505 (set-buffer (gnus-article-setup-buffer))
8506 (gnus-kill-buffer " *temp Article*")
8507 (setq tmp-buf (rename-buffer " *temp Article*")))
8508 (prog1
8509 (if (gnus-article-prepare
8510 message-id nil (gnus-read-header message-id))
8511 (progn
8512 (setq number (mail-header-number gnus-current-headers))
8513 (gnus-rebuild-thread message-id)
8514 (gnus-summary-goto-subject number)
8515 (if (null gnus-use-full-window)
8516 (progn
8517 (delete-windows-on tmp-buf)
8518 (gnus-configure-windows 'article 'force)))
8519 (gnus-summary-recenter)
8520 (gnus-article-set-window-start
8521 (cdr (assq number gnus-newsgroup-bookmarks)))
8522 (and gnus-visual
8523 (run-hooks 'gnus-visual-mark-article-hook))
8524 message-id)
8525 ;; We restore the old article buffer.
8526 (save-excursion
8527 (kill-buffer gnus-article-buffer)
8528 (set-buffer tmp-buf)
8529 (rename-buffer gnus-article-buffer)
8530 (let ((buffer-read-only nil))
8531 (and tmp-point
8532 (set-window-start (get-buffer-window (current-buffer))
8533 tmp-point)))))))))))
8534
8535(defun gnus-summary-enter-digest-group ()
8536 "Enter a digest group based on the current article."
745bc783 8537 (interactive)
41487370
LMI
8538 (gnus-set-global-variables)
8539 (gnus-summary-select-article)
8540 ;; We do not want a narrowed article.
8541 (gnus-summary-stop-page-breaking)
8542 (let ((name (format "%s-%d"
8543 (gnus-group-prefixed-name
8544 gnus-newsgroup-name (list 'nndoc ""))
8545 gnus-current-article))
8546 (ogroup gnus-newsgroup-name)
8547 (buf (current-buffer)))
8548 (if (gnus-group-read-ephemeral-group
8549 name (list 'nndoc name
8550 (list 'nndoc-address (get-buffer gnus-article-buffer))
8551 '(nndoc-article-type digest))
8552 t)
8553 (setcdr (nthcdr 4 (nth 2 (gnus-gethash name gnus-newsrc-hashtb)))
8554 (list (list (cons 'to-group ogroup))))
8555 (switch-to-buffer buf)
8556 (gnus-set-global-variables)
8557 (gnus-configure-windows 'summary)
8558 (gnus-message 3 "Article not a digest?"))))
745bc783 8559
b027f415 8560(defun gnus-summary-isearch-article ()
745bc783
JB
8561 "Do incremental search forward on current article."
8562 (interactive)
41487370 8563 (gnus-set-global-variables)
b027f415 8564 (gnus-summary-select-article)
41487370
LMI
8565 (gnus-eval-in-buffer-window
8566 gnus-article-buffer (isearch-forward)))
745bc783 8567
41487370 8568(defun gnus-summary-search-article-forward (regexp &optional backward)
745bc783 8569 "Search for an article containing REGEXP forward.
41487370 8570If BACKWARD, search backward instead."
745bc783
JB
8571 (interactive
8572 (list (read-string
41487370
LMI
8573 (format "Search article %s (regexp%s): "
8574 (if current-prefix-arg "backward" "forward")
745bc783 8575 (if gnus-last-search-regexp
41487370
LMI
8576 (concat ", default " gnus-last-search-regexp)
8577 "")))
8578 current-prefix-arg))
8579 (gnus-set-global-variables)
745bc783
JB
8580 (if (string-equal regexp "")
8581 (setq regexp (or gnus-last-search-regexp ""))
8582 (setq gnus-last-search-regexp regexp))
41487370
LMI
8583 (if (gnus-summary-search-article regexp backward)
8584 (gnus-article-set-window-start
8585 (cdr (assq (gnus-summary-article-number) gnus-newsgroup-bookmarks)))
8586 (error "Search failed: \"%s\"" regexp)))
745bc783 8587
b027f415 8588(defun gnus-summary-search-article-backward (regexp)
41487370 8589 "Search for an article containing REGEXP backward."
745bc783
JB
8590 (interactive
8591 (list (read-string
41487370 8592 (format "Search article backward (regexp%s): "
745bc783 8593 (if gnus-last-search-regexp
41487370
LMI
8594 (concat ", default " gnus-last-search-regexp)
8595 "")))))
8596 (gnus-summary-search-article-forward regexp 'backward))
745bc783 8597
b027f415 8598(defun gnus-summary-search-article (regexp &optional backward)
745bc783
JB
8599 "Search for an article containing REGEXP.
8600Optional argument BACKWARD means do search for backward.
41487370 8601gnus-select-article-hook is not called during the search."
b027f415
RS
8602 (let ((gnus-select-article-hook nil) ;Disable hook.
8603 (gnus-mark-article-hook nil) ;Inhibit marking as read.
745bc783
JB
8604 (re-search
8605 (if backward
8606 (function re-search-backward) (function re-search-forward)))
8607 (found nil)
8608 (last nil))
8609 ;; Hidden thread subtrees must be searched for ,too.
b027f415 8610 (gnus-summary-show-all-threads)
41487370 8611 (if (eobp) (forward-line -1))
745bc783
JB
8612 ;; First of all, search current article.
8613 ;; We don't want to read article again from NNTP server nor reset
8614 ;; current point.
b027f415 8615 (gnus-summary-select-article)
41487370 8616 (gnus-message 9 "Searching article: %d..." gnus-current-article)
745bc783 8617 (setq last gnus-current-article)
41487370
LMI
8618 (gnus-eval-in-buffer-window
8619 gnus-article-buffer
8620 (save-restriction
8621 (widen)
8622 ;; Begin search from current point.
8623 (setq found (funcall re-search regexp nil t))))
745bc783
JB
8624 ;; Then search next articles.
8625 (while (and (not found)
b027f415
RS
8626 (gnus-summary-display-article
8627 (gnus-summary-search-subject backward nil nil)))
41487370
LMI
8628 (gnus-message 9 "Searching article: %d..." gnus-current-article)
8629 (gnus-eval-in-buffer-window
8630 gnus-article-buffer
8631 (save-restriction
8632 (widen)
8633 (goto-char (if backward (point-max) (point-min)))
8634 (setq found (funcall re-search regexp nil t)))))
745bc783
JB
8635 (message "")
8636 ;; Adjust article pointer.
8637 (or (eq last gnus-current-article)
8638 (setq gnus-last-article last))
8639 ;; Return T if found such article.
41487370 8640 found))
745bc783 8641
41487370
LMI
8642(defun gnus-summary-execute-command (header regexp command &optional backward)
8643 "Search forward for an article whose HEADER matches REGEXP and execute COMMAND.
8644If HEADER is an empty string (or nil), the match is done on the entire
8645article. If BACKWARD (the prefix) is non-nil, search backward instead."
745bc783
JB
8646 (interactive
8647 (list (let ((completion-ignore-case t))
41487370
LMI
8648 (completing-read
8649 "Header name: "
8650 (mapcar (lambda (string) (list string))
8651 '("Number" "Subject" "From" "Lines" "Date"
8652 "Message-ID" "Xref" "References"))
8653 nil 'require-match))
745bc783
JB
8654 (read-string "Regexp: ")
8655 (read-key-sequence "Command: ")
8656 current-prefix-arg))
41487370
LMI
8657 (gnus-set-global-variables)
8658 ;; Hidden thread subtrees must be searched as well.
b027f415 8659 (gnus-summary-show-all-threads)
745bc783
JB
8660 ;; We don't want to change current point nor window configuration.
8661 (save-excursion
8662 (save-window-excursion
41487370 8663 (gnus-message 6 "Executing %s..." (key-description command))
745bc783 8664 ;; We'd like to execute COMMAND interactively so as to give arguments.
41487370 8665 (gnus-execute header regexp
745bc783
JB
8666 (` (lambda ()
8667 (call-interactively '(, (key-binding command)))))
8668 backward)
41487370 8669 (gnus-message 6 "Executing %s...done" (key-description command)))))
745bc783 8670
b027f415 8671(defun gnus-summary-beginning-of-article ()
41487370 8672 "Scroll the article back to the beginning."
745bc783 8673 (interactive)
41487370 8674 (gnus-set-global-variables)
b027f415 8675 (gnus-summary-select-article)
41487370
LMI
8676 (gnus-configure-windows 'article)
8677 (gnus-eval-in-buffer-window
8678 gnus-article-buffer
8679 (widen)
8680 (goto-char (point-min))
8681 (and gnus-break-pages (gnus-narrow-to-page))))
745bc783 8682
b027f415 8683(defun gnus-summary-end-of-article ()
41487370 8684 "Scroll to the end of the article."
745bc783 8685 (interactive)
41487370 8686 (gnus-set-global-variables)
b027f415 8687 (gnus-summary-select-article)
41487370
LMI
8688 (gnus-configure-windows 'article)
8689 (gnus-eval-in-buffer-window
8690 gnus-article-buffer
8691 (widen)
8692 (goto-char (point-max))
8693 (recenter -3)
8694 (and gnus-break-pages (gnus-narrow-to-page))))
745bc783 8695
b027f415 8696(defun gnus-summary-show-article ()
41487370 8697 "Force re-fetching of the current article."
745bc783 8698 (interactive)
41487370
LMI
8699 (gnus-set-global-variables)
8700 (gnus-summary-select-article nil 'force)
8701 (gnus-configure-windows 'article)
8702 (gnus-summary-position-cursor))
745bc783 8703
41487370
LMI
8704(defun gnus-summary-verbose-headers (&optional arg)
8705 "Toggle permanent full header display.
8706If ARG is a positive number, turn header display on.
8707If ARG is a negative number, turn header display off."
8708 (interactive "P")
8709 (gnus-set-global-variables)
8710 (gnus-summary-toggle-header arg)
8711 (setq gnus-show-all-headers
8712 (cond ((or (not (numberp arg))
8713 (zerop arg))
8714 (not gnus-show-all-headers))
8715 ((natnump arg)
8716 t))))
8717
8718(defun gnus-summary-toggle-header (&optional arg)
8719 "Show the headers if they are hidden, or hide them if they are shown.
8720If ARG is a positive number, show the entire header.
8721If ARG is a negative number, hide the unwanted header lines."
745bc783 8722 (interactive "P")
41487370
LMI
8723 (gnus-set-global-variables)
8724 (save-excursion
8725 (set-buffer gnus-article-buffer)
8726 (let ((buffer-read-only nil))
8727 (if (numberp arg)
8728 (if (> arg 0) (remove-text-properties (point-min) (point-max)
8729 gnus-hidden-properties)
8730 (if (< arg 0) (run-hooks 'gnus-article-display-hook)))
8731 (if (text-property-any (point-min) (point-max) 'invisible t)
8732 (remove-text-properties
8733 (point-min) (point-max) gnus-hidden-properties)
8734 ;; We hide the headers. This song and dance act below is
8735 ;; done because `gnus-have-all-headers' is buffer-local to
8736 ;; the summary buffer, and we only want to temporarily
8737 ;; change it in that buffer. Ugh.
8738 (let ((have gnus-have-all-headers))
8739 (save-excursion
8740 (set-buffer gnus-summary-buffer)
8741 (setq gnus-have-all-headers nil)
8742 (save-excursion
8743 (set-buffer gnus-article-buffer)
8744 (run-hooks 'gnus-article-display-hook))
8745 (setq gnus-have-all-headers have)))))
8746 (set-window-point (get-buffer-window (current-buffer)) (point-min)))))
745bc783 8747
b027f415 8748(defun gnus-summary-show-all-headers ()
41487370 8749 "Make all header lines visible."
745bc783 8750 (interactive)
41487370
LMI
8751 (gnus-set-global-variables)
8752 (gnus-article-show-all-headers))
b027f415 8753
41487370 8754(defun gnus-summary-toggle-mime (&optional arg)
b027f415 8755 "Toggle MIME processing.
41487370 8756If ARG is a positive number, turn MIME processing on."
b027f415 8757 (interactive "P")
41487370 8758 (gnus-set-global-variables)
b027f415
RS
8759 (setq gnus-show-mime
8760 (if (null arg) (not gnus-show-mime)
8761 (> (prefix-numeric-value arg) 0)))
41487370
LMI
8762 (gnus-summary-select-article t 'force))
8763
8764(defun gnus-summary-caesar-message (&optional arg)
8765 "Caesar rotate the current article by 13.
8766The numerical prefix specifies how manu places to rotate each letter
8767forward."
8768 (interactive "P")
8769 (gnus-set-global-variables)
8770 (gnus-summary-select-article)
8771 (let ((mail-header-separator ""))
8772 (gnus-eval-in-buffer-window
8773 gnus-article-buffer
8774 (save-restriction
8775 (widen)
8776 (let ((start (window-start)))
8777 (news-caesar-buffer-body arg)
8778 (set-window-start (get-buffer-window (current-buffer)) start))))))
745bc783 8779
b027f415 8780(defun gnus-summary-stop-page-breaking ()
41487370 8781 "Stop page breaking in the current article."
745bc783 8782 (interactive)
41487370 8783 (gnus-set-global-variables)
b027f415 8784 (gnus-summary-select-article)
41487370
LMI
8785 (gnus-eval-in-buffer-window gnus-article-buffer (widen)))
8786
8787;; Suggested by Brian Edmonds <bedmonds@prodigy.bc.ca>.
8788
8789(defun gnus-summary-move-article (&optional n to-newsgroup select-method)
8790 "Move the current article to a different newsgroup.
8791If N is a positive number, move the N next articles.
8792If N is a negative number, move the N previous articles.
8793If N is nil and any articles have been marked with the process mark,
8794move those articles instead.
8795If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
8796If SELECT-METHOD is symbol, do not move to a specific newsgroup, but
8797re-spool using this method.
8798For this function to work, both the current newsgroup and the
8799newsgroup that you want to move to have to support the `request-move'
8800and `request-accept' functions. (Ie. mail newsgroups at present.)"
8801 (interactive "P")
8802 (gnus-set-global-variables)
8803 (or (gnus-check-backend-function 'request-move-article gnus-newsgroup-name)
8804 (error "The current newsgroup does not support article moving"))
8805 (let ((articles (gnus-summary-work-articles n))
8806 (prefix (gnus-group-real-prefix gnus-newsgroup-name))
8807 art-group to-method sel-met)
8808 (if (and (not to-newsgroup) (not select-method))
8809 (setq to-newsgroup
8810 (completing-read
8811 (format "Where do you want to move %s? %s"
8812 (if (> (length articles) 1)
8813 (format "these %d articles" (length articles))
8814 "this article")
8815 (if gnus-current-move-group
8816 (format "(%s default) " gnus-current-move-group)
8817 ""))
8818 gnus-active-hashtb nil nil prefix)))
8819 (if to-newsgroup
8820 (progn
8821 (if (or (string= to-newsgroup "") (string= to-newsgroup prefix))
8822 (setq to-newsgroup (or gnus-current-move-group "")))
8823 (or (gnus-gethash to-newsgroup gnus-active-hashtb)
8824 (gnus-activate-group to-newsgroup)
8825 (error "No such group: %s" to-newsgroup))
8826 (setq gnus-current-move-group to-newsgroup)))
8827 (setq to-method (if select-method (list select-method "")
8828 (gnus-find-method-for-group to-newsgroup)))
8829 (or (gnus-check-backend-function 'request-accept-article (car to-method))
8830 (error "%s does not support article copying" (car to-method)))
8831 (or (gnus-check-server to-method)
8832 (error "Can't open server %s" (car to-method)))
8833 (gnus-message 6 "Moving to %s: %s..."
8834 (or select-method to-newsgroup) articles)
8835 (while articles
8836 (if (setq art-group
8837 (gnus-request-move-article
8838 (car articles) ; Article to move
b94ae5f7 8839 gnus-newsgroup-name ; From newsgroup
41487370
LMI
8840 (nth 1 (gnus-find-method-for-group
8841 gnus-newsgroup-name)) ; Server
8842 (list 'gnus-request-accept-article
8843 (if select-method
8844 (list 'quote select-method)
8845 to-newsgroup)
8846 (not (cdr articles))) ; Accept form
8847 (not (cdr articles)))) ; Only save nov last time
8848 (let* ((buffer-read-only nil)
8849 (entry
8850 (or
8851 (gnus-gethash (car art-group) gnus-newsrc-hashtb)
8852 (gnus-gethash
8853 (gnus-group-prefixed-name
8854 (car art-group)
8855 (if select-method (list select-method "")
8856 (gnus-find-method-for-group to-newsgroup)))
8857 gnus-newsrc-hashtb)))
8858 (info (nth 2 entry))
8859 (article (car articles)))
8860 (gnus-summary-goto-subject article)
8861 (beginning-of-line)
8862 (delete-region (point) (progn (forward-line 1) (point)))
8863 ;; Update the group that has been moved to.
8864 (if (not info)
8865 () ; This group does not exist yet.
8866 (if (not (memq article gnus-newsgroup-unreads))
8867 (setcar (cdr (cdr info))
8868 (gnus-add-to-range (nth 2 info)
8869 (list (cdr art-group)))))
8870 ;; Copy any marks over to the new group.
8871 (let ((marks '((tick . gnus-newsgroup-marked)
8872 (dormant . gnus-newsgroup-dormant)
8873 (expire . gnus-newsgroup-expirable)
8874 (bookmark . gnus-newsgroup-bookmarks)
8875 (reply . gnus-newsgroup-replied)))
8876 (to-article (cdr art-group)))
8877 (while marks
8878 (if (memq article (symbol-value (cdr (car marks))))
8879 (gnus-add-marked-articles
8880 (car info) (car (car marks)) (list to-article) info))
8881 (setq marks (cdr marks)))))
8882 ;; Update marks.
8883 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
8884 (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
8885 (setq gnus-newsgroup-dormant
8886 (delq article gnus-newsgroup-dormant))
8887 (setq gnus-newsgroup-reads
8888 (cons (cons article gnus-canceled-mark)
8889 gnus-newsgroup-reads)))
8890 (gnus-message 1 "Couldn't move article %s" (car articles)))
8891 (gnus-summary-remove-process-mark (car articles))
8892 (setq articles (cdr articles)))
8893 (gnus-set-mode-line 'summary)))
8894
8895(defun gnus-summary-respool-article (&optional n respool-method)
8896 "Respool the current article.
8897The article will be squeezed through the mail spooling process again,
8898which means that it will be put in some mail newsgroup or other
8899depending on `nnmail-split-methods'.
8900If N is a positive number, respool the N next articles.
8901If N is a negative number, respool the N previous articles.
8902If N is nil and any articles have been marked with the process mark,
8903respool those articles instead.
8904
8905Respooling can be done both from mail groups and \"real\" newsgroups.
8906In the former case, the articles in question will be moved from the
8907current group into whatever groups they are destined to. In the
8908latter case, they will be copied into the relevant groups."
8909 (interactive "P")
8910 (gnus-set-global-variables)
8911 (let ((respool-methods (gnus-methods-using 'respool))
8912 (methname
8913 (symbol-name (car (gnus-find-method-for-group gnus-newsgroup-name)))))
8914 (or respool-method
8915 (setq respool-method
8916 (completing-read
8917 "What method do you want to use when respooling? "
8918 respool-methods nil t methname)))
8919 (or (string= respool-method "")
8920 (if (assoc (symbol-name
8921 (car (gnus-find-method-for-group gnus-newsgroup-name)))
8922 respool-methods)
8923 (gnus-summary-move-article n nil (intern respool-method))
8924 (gnus-summary-copy-article n nil (intern respool-method))))))
8925
8926;; Suggested by gregj@unidata.com (Gregory J. Grubbs).
8927(defun gnus-summary-copy-article (&optional n to-newsgroup select-method)
8928 "Move the current article to a different newsgroup.
8929If N is a positive number, move the N next articles.
8930If N is a negative number, move the N previous articles.
8931If N is nil and any articles have been marked with the process mark,
8932move those articles instead.
8933If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
8934If SELECT-METHOD is symbol, do not move to a specific newsgroup, but
8935re-spool using this method.
8936For this function to work, the newsgroup that you want to move to have
8937to support the `request-move' and `request-accept'
8938functions. (Ie. mail newsgroups at present.)"
8939 (interactive "P")
8940 (gnus-set-global-variables)
8941 (let ((articles (gnus-summary-work-articles n))
8942 (copy-buf (get-buffer-create "*copy work*"))
8943 (prefix (gnus-group-real-prefix gnus-newsgroup-name))
8944 art-group to-method)
8945 (buffer-disable-undo copy-buf)
8946 (if (and (not to-newsgroup) (not select-method))
8947 (setq to-newsgroup
8948 (completing-read
8949 (format "Where do you want to copy %s? %s"
8950 (if (> (length articles) 1)
8951 (format "these %d articles" (length articles))
8952 "this article")
8953 (if gnus-current-move-group
8954 (format "(%s default) " gnus-current-move-group)
8955 ""))
8956 gnus-active-hashtb nil nil prefix)))
8957 (if to-newsgroup
8958 (progn
8959 (if (or (string= to-newsgroup "") (string= to-newsgroup prefix))
8960 (setq to-newsgroup (or gnus-current-move-group "")))
8961 (or (gnus-gethash to-newsgroup gnus-active-hashtb)
8962 (gnus-activate-group to-newsgroup)
8963 (error "No such group: %s" to-newsgroup))
8964 (setq gnus-current-move-group to-newsgroup)))
8965 (setq to-method (if select-method (list select-method "")
8966 (gnus-find-method-for-group to-newsgroup)))
8967 (or (gnus-check-backend-function 'request-accept-article (car to-method))
8968 (error "%s does not support article copying" (car to-method)))
8969 (or (gnus-check-server to-method)
8970 (error "Can't open server %s" (car to-method)))
8971 (while articles
8972 (gnus-message 6 "Copying to %s: %s..."
8973 (or select-method to-newsgroup) articles)
8974 (if (setq art-group
8975 (save-excursion
8976 (set-buffer copy-buf)
8977 (gnus-request-article-this-buffer
8978 (car articles) gnus-newsgroup-name)
8979 (gnus-request-accept-article
7e988fb6 8980 (if select-method (list 'quote select-method) to-newsgroup)
41487370
LMI
8981 (not (cdr articles)))))
8982 (let* ((entry
8983 (or
8984 (gnus-gethash (car art-group) gnus-newsrc-hashtb)
8985 (gnus-gethash
8986 (gnus-group-prefixed-name
8987 (car art-group)
8988 (if select-method (list select-method "")
8989 (gnus-find-method-for-group to-newsgroup)))
8990 gnus-newsrc-hashtb)))
8991 (info (nth 2 entry))
8992 (article (car articles)))
8993 ;; We copy the info over to the new group.
8994 (if (not info)
8995 () ; This group does not exist (yet).
8996 (if (not (memq article gnus-newsgroup-unreads))
8997 (setcar (cdr (cdr info))
8998 (gnus-add-to-range (nth 2 info)
8999 (list (cdr art-group)))))
9000 ;; Copy any marks over to the new group.
9001 (let ((marks '((tick . gnus-newsgroup-marked)
9002 (dormant . gnus-newsgroup-dormant)
9003 (expire . gnus-newsgroup-expirable)
9004 (bookmark . gnus-newsgroup-bookmarks)
9005 (reply . gnus-newsgroup-replied)))
9006 (to-article (cdr art-group)))
9007 (while marks
9008 (if (memq article (symbol-value (cdr (car marks))))
9009 (gnus-add-marked-articles
9010 (car info) (car (car marks)) (list to-article) info))
9011 (setq marks (cdr marks))))))
9012 (gnus-message 1 "Couldn't copy article %s" (car articles)))
9013 (gnus-summary-remove-process-mark (car articles))
9014 (setq articles (cdr articles)))
9015 (kill-buffer copy-buf)))
9016
9017(defun gnus-summary-import-article (file)
9018 "Import a random file into a mail newsgroup."
9019 (interactive "fImport file: ")
9020 (let ((group gnus-newsgroup-name)
9021 atts)
9022 (or (gnus-check-backend-function 'request-accept-article group)
9023 (error "%s does not support article importing" group))
9024 (or (file-readable-p file)
9025 (not (file-regular-p file))
9026 (error "Can't read %s" file))
9027 (save-excursion
9028 (set-buffer (get-buffer-create " *import file*"))
9029 (buffer-disable-undo (current-buffer))
9030 (erase-buffer)
9031 (insert-file-contents file)
9032 (goto-char (point-min))
9033 (if (nnheader-article-p)
9034 ()
9035 (setq atts (file-attributes file))
9036 (insert "From: " (read-string "From: ") "\n"
9037 "Subject: " (read-string "Subject: ") "\n"
9038 "Date: " (current-time-string (nth 5 atts)) "\n"
9039 "Chars: " (int-to-string (nth 7 atts)) "\n\n"))
9040 (gnus-request-accept-article group t)
9041 (kill-buffer (current-buffer)))))
9042
9043(defun gnus-summary-expire-articles ()
9044 "Expire all articles that are marked as expirable in the current group."
9045 (interactive)
9046 (if (not (gnus-check-backend-function
9047 'request-expire-articles gnus-newsgroup-name))
9048 ()
9049 (let* ((info (nth 2 (gnus-gethash gnus-newsgroup-name
9050 gnus-newsrc-hashtb)))
9051 (total (memq 'total-expire (nth 5 info)))
9052 (expirable (if total
9053 (gnus-list-of-read-articles gnus-newsgroup-name)
9054 (setq gnus-newsgroup-expirable
9055 (sort gnus-newsgroup-expirable '<))))
9056 es)
9057 (if (not expirable)
9058 ()
9059 (gnus-message 6 "Expiring articles...")
9060 ;; The list of articles that weren't expired is returned.
9061 (setq es (gnus-request-expire-articles expirable gnus-newsgroup-name))
9062 (or total (setq gnus-newsgroup-expirable es))
9063 ;; We go through the old list of expirable, and mark all
b94ae5f7 9064 ;; really expired articles as nonexistent.
41487370
LMI
9065 (or (eq es expirable) ;If nothing was expired, we don't mark.
9066 (let ((gnus-use-cache nil))
9067 (while expirable
9068 (or (memq (car expirable) es)
9069 (gnus-summary-mark-article
9070 (car expirable) gnus-canceled-mark))
9071 (setq expirable (cdr expirable)))))
9072 (gnus-message 6 "Expiring articles...done")))))
9073
9074(defun gnus-summary-expire-articles-now ()
9075 "Expunge all expirable articles in the current group.
9076This means that *all* articles that are marked as expirable will be
9077deleted forever, right now."
9078 (interactive)
9079 (or gnus-expert-user
9080 (gnus-y-or-n-p
9081 "Are you really, really, really sure you want to expunge? ")
9082 (error "Phew!"))
9083 (let ((nnmail-expiry-wait -1)
9084 (nnmail-expiry-wait-function nil))
9085 (gnus-summary-expire-articles)))
9086
9087;; Suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.
9088(defun gnus-summary-delete-article (&optional n)
9089 "Delete the N next (mail) articles.
9090This command actually deletes articles. This is not a marking
9091command. The article will disappear forever from you life, never to
9092return.
9093If N is negative, delete backwards.
9094If N is nil and articles have been marked with the process mark,
9095delete these instead."
9096 (interactive "P")
9097 (or (gnus-check-backend-function 'request-expire-articles
9098 gnus-newsgroup-name)
9099 (error "The current newsgroup does not support article deletion."))
9100 ;; Compute the list of articles to delete.
9101 (let ((articles (gnus-summary-work-articles n))
9102 not-deleted)
9103 (if (and gnus-novice-user
9104 (not (gnus-y-or-n-p
9105 (format "Do you really want to delete %s forever? "
9106 (if (> (length articles) 1) "these articles"
9107 "this article")))))
9108 ()
9109 ;; Delete the articles.
9110 (setq not-deleted (gnus-request-expire-articles
9111 articles gnus-newsgroup-name 'force))
9112 (while articles
9113 (gnus-summary-remove-process-mark (car articles))
9114 ;; The backend might not have been able to delete the article
9115 ;; after all.
9116 (or (memq (car articles) not-deleted)
9117 (gnus-summary-mark-article (car articles) gnus-canceled-mark))
9118 (setq articles (cdr articles))))
9119 (gnus-summary-position-cursor)
9120 (gnus-set-mode-line 'summary)
9121 not-deleted))
9122
9123(defun gnus-summary-edit-article (&optional force)
9124 "Enter into a buffer and edit the current article.
9125This will have permanent effect only in mail groups.
9126If FORCE is non-nil, allow editing of articles even in read-only
9127groups."
9128 (interactive "P")
9129 (or force
9130 (not (gnus-group-read-only-p))
9131 (error "The current newsgroup does not support article editing."))
9132 (gnus-summary-select-article t)
9133 (gnus-configure-windows 'article)
9134 (select-window (get-buffer-window gnus-article-buffer))
9135 (gnus-message 6 "C-c C-c to end edits")
9136 (setq buffer-read-only nil)
9137 (text-mode)
9138 (use-local-map (copy-keymap (current-local-map)))
9139 (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
9140 (buffer-enable-undo)
9141 (widen)
9142 (goto-char (point-min))
9143 (search-forward "\n\n" nil t))
9144
9145(defun gnus-summary-edit-article-done ()
9146 "Make edits to the current article permanent."
9147 (interactive)
9148 (if (gnus-group-read-only-p)
9149 (progn
9150 (gnus-summary-edit-article-postpone)
9151 (message "The current newsgroup does not support article editing.")
9152 (ding))
9153 (let ((buf (buffer-substring-no-properties (point-min) (point-max))))
9154 (erase-buffer)
9155 (insert buf)
9156 (if (not (gnus-request-replace-article
9157 (cdr gnus-article-current) (car gnus-article-current)
9158 (current-buffer)))
9159 (error "Couldn't replace article.")
9160 (gnus-article-mode)
9161 (use-local-map gnus-article-mode-map)
9162 (setq buffer-read-only t)
9163 (buffer-disable-undo (current-buffer))
9164 (gnus-configure-windows 'summary))
9165 (and gnus-visual (run-hooks 'gnus-visual-mark-article-hook)))))
9166
9167(defun gnus-summary-edit-article-postpone ()
9168 "Postpone changes to the current article."
9169 (interactive)
9170 (gnus-article-mode)
9171 (use-local-map gnus-article-mode-map)
9172 (setq buffer-read-only t)
9173 (buffer-disable-undo (current-buffer))
9174 (gnus-configure-windows 'summary)
9175 (and gnus-visual (run-hooks 'gnus-visual-mark-article-hook)))
9176
9177(defun gnus-summary-fancy-query ()
9178 "Query where the fancy respool algorithm would put this article."
9179 (interactive)
9180 (gnus-summary-select-article)
9181 (save-excursion
9182 (set-buffer gnus-article-buffer)
9183 (save-restriction
9184 (goto-char (point-min))
9185 (search-forward "\n\n")
9186 (narrow-to-region (point-min) (point))
9187 (pp-eval-expression (list 'quote (nnmail-split-fancy))))))
9188
9189;; Summary score commands.
9190
9191;; Suggested by boubaker@cenatls.cena.dgac.fr.
745bc783 9192
41487370
LMI
9193(defun gnus-summary-raise-score (n)
9194 "Raise the score of the current article by N."
9195 (interactive "p")
9196 (gnus-summary-set-score (+ (gnus-summary-article-score) n)))
9197
9198(defun gnus-summary-set-score (n)
9199 "Set the score of the current article to N."
9200 (interactive "p")
9201 ;; Skip dummy header line.
9202 (save-excursion
9203 (gnus-summary-show-thread)
9204 (if (eq (gnus-summary-article-mark) gnus-dummy-mark)
9205 (forward-line 1))
9206 (let ((buffer-read-only nil))
9207 ;; Set score.
9208 (gnus-summary-update-mark
9209 (if (= n (or gnus-summary-default-score 0)) ?
9210 (if (< n (or gnus-summary-default-score 0))
9211 gnus-score-below-mark gnus-score-over-mark)) 'score))
9212 (let* ((article (gnus-summary-article-number))
9213 (score (assq article gnus-newsgroup-scored)))
9214 (if score (setcdr score n)
9215 (setq gnus-newsgroup-scored
9216 (cons (cons article n) gnus-newsgroup-scored))))
9217 (gnus-summary-update-line)))
9218
9219(defun gnus-summary-current-score ()
9220 "Return the score of the current article."
9221 (interactive)
9222 (message "%s" (gnus-summary-article-score)))
9223
9224;; Summary marking commands.
9225
9226(defun gnus-summary-raise-same-subject-and-select (score)
9227 "Raise articles which has the same subject with SCORE and select the next."
9228 (interactive "p")
9229 (let ((subject (gnus-summary-subject-string)))
9230 (gnus-summary-raise-score score)
9231 (while (gnus-summary-search-subject nil nil subject)
9232 (gnus-summary-raise-score score))
9233 (gnus-summary-next-article t)))
9234
9235(defun gnus-summary-raise-same-subject (score)
9236 "Raise articles which has the same subject with SCORE."
9237 (interactive "p")
9238 (let ((subject (gnus-summary-subject-string)))
9239 (gnus-summary-raise-score score)
9240 (while (gnus-summary-search-subject nil nil subject)
9241 (gnus-summary-raise-score score))
9242 (gnus-summary-next-subject 1 t)))
9243
9244(defun gnus-score-default (level)
9245 (if level (prefix-numeric-value level)
9246 gnus-score-interactive-default-score))
9247
9248(defun gnus-summary-raise-thread (&optional score)
9249 "Raise the score of the articles in the current thread with SCORE."
9250 (interactive "P")
9251 (setq score (gnus-score-default score))
9252 (let (e)
9253 (save-excursion
9254 (let ((level (gnus-summary-thread-level)))
9255 (gnus-summary-raise-score score)
9256 (while (and (zerop (gnus-summary-next-subject 1 nil t))
9257 (> (gnus-summary-thread-level) level))
9258 (gnus-summary-raise-score score))
9259 (setq e (point))))
9260 (let ((gnus-summary-check-current t))
9261 (or (zerop (gnus-summary-next-subject 1 t))
9262 (goto-char e))))
9263 (gnus-summary-recenter)
9264 (gnus-summary-position-cursor)
9265 (gnus-set-mode-line 'summary))
9266
9267(defun gnus-summary-lower-same-subject-and-select (score)
9268 "Raise articles which has the same subject with SCORE and select the next."
9269 (interactive "p")
9270 (gnus-summary-raise-same-subject-and-select (- score)))
9271
9272(defun gnus-summary-lower-same-subject (score)
9273 "Raise articles which has the same subject with SCORE."
9274 (interactive "p")
9275 (gnus-summary-raise-same-subject (- score)))
9276
9277(defun gnus-summary-lower-thread (&optional score)
9278 "Lower score of articles in the current thread with SCORE."
9279 (interactive "P")
9280 (gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
9281
9282(defun gnus-summary-kill-same-subject-and-select (&optional unmark)
9283 "Mark articles which has the same subject as read, and then select the next.
9284If UNMARK is positive, remove any kind of mark.
9285If UNMARK is negative, tick articles."
745bc783
JB
9286 (interactive "P")
9287 (if unmark
9288 (setq unmark (prefix-numeric-value unmark)))
9289 (let ((count
b027f415
RS
9290 (gnus-summary-mark-same-subject
9291 (gnus-summary-subject-string) unmark)))
41487370 9292 ;; Select next unread article. If auto-select-same mode, should
745bc783 9293 ;; select the first unread article.
b027f415
RS
9294 (gnus-summary-next-article t (and gnus-auto-select-same
9295 (gnus-summary-subject-string)))
41487370
LMI
9296 (gnus-message 7 "%d article%s marked as %s"
9297 count (if (= count 1) " is" "s are")
9298 (if unmark "unread" "read"))))
745bc783 9299
41487370 9300(defun gnus-summary-kill-same-subject (&optional unmark)
745bc783 9301 "Mark articles which has the same subject as read.
41487370
LMI
9302If UNMARK is positive, remove any kind of mark.
9303If UNMARK is negative, tick articles."
745bc783
JB
9304 (interactive "P")
9305 (if unmark
9306 (setq unmark (prefix-numeric-value unmark)))
9307 (let ((count
b027f415
RS
9308 (gnus-summary-mark-same-subject
9309 (gnus-summary-subject-string) unmark)))
745bc783
JB
9310 ;; If marked as read, go to next unread subject.
9311 (if (null unmark)
9312 ;; Go to next unread subject.
b027f415 9313 (gnus-summary-next-subject 1 t))
41487370
LMI
9314 (gnus-message 7 "%d articles are marked as %s"
9315 count (if unmark "unread" "read"))))
745bc783 9316
b027f415 9317(defun gnus-summary-mark-same-subject (subject &optional unmark)
745bc783
JB
9318 "Mark articles with same SUBJECT as read, and return marked number.
9319If optional argument UNMARK is positive, remove any kinds of marks.
9320If optional argument UNMARK is negative, mark articles as unread instead."
9321 (let ((count 1))
9322 (save-excursion
41487370
LMI
9323 (cond
9324 ((null unmark) ; Mark as read.
9325 (while (and
9326 (progn
9327 (gnus-summary-mark-article-as-read gnus-killed-mark)
9328 (gnus-summary-show-thread) t)
9329 (gnus-summary-search-forward nil subject))
9330 (setq count (1+ count))))
9331 ((> unmark 0) ; Tick.
9332 (while (and
9333 (progn
9334 (gnus-summary-mark-article-as-unread gnus-ticked-mark)
9335 (gnus-summary-show-thread) t)
9336 (gnus-summary-search-forward nil subject))
9337 (setq count (1+ count))))
9338 (t ; Mark as unread.
9339 (while (and
9340 (progn
9341 (gnus-summary-mark-article-as-unread gnus-unread-mark)
9342 (gnus-summary-show-thread) t)
9343 (gnus-summary-search-forward nil subject))
9344 (setq count (1+ count)))))
9345 (gnus-set-mode-line 'summary)
9346 ;; Return the number of marked articles.
9347 count)))
9348
9349(defun gnus-summary-mark-as-processable (n &optional unmark)
9350 "Set the process mark on the next N articles.
9351If N is negative, mark backward instead. If UNMARK is non-nil, remove
9352the process mark instead. The difference between N and the actual
9353number of articles marked is returned."
9354 (interactive "p")
9355 (let ((backward (< n 0))
9356 (n (abs n)))
9357 (while (and
9358 (> n 0)
9359 (if unmark
9360 (gnus-summary-remove-process-mark
9361 (gnus-summary-article-number))
9362 (gnus-summary-set-process-mark (gnus-summary-article-number)))
9363 (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))
9364 (setq n (1- n)))
9365 (if (/= 0 n) (gnus-message 7 "No more articles"))
9366 (gnus-summary-recenter)
9367 (gnus-summary-position-cursor)
9368 n))
9369
9370(defun gnus-summary-unmark-as-processable (n)
9371 "Remove the process mark from the next N articles.
9372If N is negative, mark backward instead. The difference between N and
9373the actual number of articles marked is returned."
9374 (interactive "p")
9375 (gnus-summary-mark-as-processable n t))
9376
9377(defun gnus-summary-unmark-all-processable ()
9378 "Remove the process mark from all articles."
9379 (interactive)
9380 (save-excursion
9381 (while gnus-newsgroup-processable
9382 (gnus-summary-remove-process-mark (car gnus-newsgroup-processable))))
9383 (gnus-summary-position-cursor))
9384
9385(defun gnus-summary-mark-as-expirable (n)
9386 "Mark N articles forward as expirable.
9387If N is negative, mark backward instead. The difference between N and
9388the actual number of articles marked is returned."
745bc783 9389 (interactive "p")
41487370
LMI
9390 (gnus-summary-mark-forward n gnus-expirable-mark))
9391
9392(defun gnus-summary-mark-article-as-replied (article)
9393 "Mark ARTICLE replied and update the summary line."
9394 (setq gnus-newsgroup-replied (cons article gnus-newsgroup-replied))
9395 (let ((buffer-read-only nil))
9396 (if (gnus-summary-goto-subject article)
9397 (progn
9398 (gnus-summary-update-mark gnus-replied-mark 'replied)
9399 t))))
9400
9401(defun gnus-summary-set-bookmark (article)
9402 "Set a bookmark in current article."
9403 (interactive (list (gnus-summary-article-number)))
9404 (if (or (not (get-buffer gnus-article-buffer))
9405 (not gnus-current-article)
9406 (not gnus-article-current)
9407 (not (equal gnus-newsgroup-name (car gnus-article-current))))
9408 (error "No current article selected"))
9409 ;; Remove old bookmark, if one exists.
9410 (let ((old (assq article gnus-newsgroup-bookmarks)))
9411 (if old (setq gnus-newsgroup-bookmarks
9412 (delq old gnus-newsgroup-bookmarks))))
9413 ;; Set the new bookmark, which is on the form
9414 ;; (article-number . line-number-in-body).
9415 (setq gnus-newsgroup-bookmarks
9416 (cons
9417 (cons article
9418 (save-excursion
9419 (set-buffer gnus-article-buffer)
9420 (count-lines
9421 (min (point)
9422 (save-excursion
9423 (goto-char (point-min))
9424 (search-forward "\n\n" nil t)
9425 (point)))
9426 (point))))
9427 gnus-newsgroup-bookmarks))
9428 (gnus-message 6 "A bookmark has been added to the current article."))
9429
9430(defun gnus-summary-remove-bookmark (article)
9431 "Remove the bookmark from the current article."
9432 (interactive (list (gnus-summary-article-number)))
9433 ;; Remove old bookmark, if one exists.
9434 (let ((old (assq article gnus-newsgroup-bookmarks)))
9435 (if old
9436 (progn
9437 (setq gnus-newsgroup-bookmarks
9438 (delq old gnus-newsgroup-bookmarks))
9439 (gnus-message 6 "Removed bookmark."))
9440 (gnus-message 6 "No bookmark in current article."))))
9441
9442;; Suggested by Daniel Quinlan <quinlan@best.com>.
9443(defun gnus-summary-mark-as-dormant (n)
9444 "Mark N articles forward as dormant.
9445If N is negative, mark backward instead. The difference between N and
9446the actual number of articles marked is returned."
9447 (interactive "p")
9448 (gnus-summary-mark-forward n gnus-dormant-mark))
9449
9450(defun gnus-summary-set-process-mark (article)
9451 "Set the process mark on ARTICLE and update the summary line."
7e988fb6
LMI
9452 (setq gnus-newsgroup-processable
9453 (cons article
9454 (delq article gnus-newsgroup-processable)))
41487370
LMI
9455 (let ((buffer-read-only nil))
9456 (if (gnus-summary-goto-subject article)
9457 (progn
9458 (gnus-summary-show-thread)
9459 (and (eq (gnus-summary-article-mark) gnus-dummy-mark)
9460 (forward-line 1))
9461 (gnus-summary-update-mark gnus-process-mark 'replied)
9462 t))))
9463
9464(defun gnus-summary-remove-process-mark (article)
9465 "Remove the process mark from ARTICLE and update the summary line."
9466 (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable))
9467 (let ((buffer-read-only nil))
9468 (if (gnus-summary-goto-subject article)
9469 (progn
9470 (gnus-summary-show-thread)
9471 (and (eq (gnus-summary-article-mark) gnus-dummy-mark)
9472 (forward-line 1))
9473 (gnus-summary-update-mark ? 'replied)
9474 (if (memq article gnus-newsgroup-replied)
9475 (gnus-summary-update-mark gnus-replied-mark 'replied))
9476 t))))
9477
9478(defun gnus-summary-mark-forward (n &optional mark no-expire)
9479 "Mark N articles as read forwards.
9480If N is negative, mark backwards instead.
9481Mark with MARK. If MARK is ? , ?! or ??, articles will be
9482marked as unread.
9483The difference between N and the actual number of articles marked is
9484returned."
9485 (interactive "p")
9486 (gnus-set-global-variables)
9487 (let ((backward (< n 0))
9488 (gnus-summary-goto-unread
9489 (and gnus-summary-goto-unread
9490 (not (memq mark (list gnus-unread-mark
9491 gnus-ticked-mark gnus-dormant-mark)))))
9492 (n (abs n))
9493 (mark (or mark gnus-del-mark)))
9494 (while (and (> n 0)
9495 (gnus-summary-mark-article nil mark no-expire)
9496 (zerop (gnus-summary-next-subject
9497 (if backward -1 1) gnus-summary-goto-unread t)))
9498 (setq n (1- n)))
9499 (if (/= 0 n) (gnus-message 7 "No more %sarticles" (if mark "" "unread ")))
9500 (gnus-summary-recenter)
9501 (gnus-summary-position-cursor)
9502 (gnus-set-mode-line 'summary)
9503 n))
9504
9505(defun gnus-summary-mark-article-as-read (mark)
9506 "Mark the current article quickly as read with MARK."
9507 (let ((article (gnus-summary-article-number)))
9508 (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
9509 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
9510 (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
9511 (setq gnus-newsgroup-reads
9512 (cons (cons article mark) gnus-newsgroup-reads))
9513 ;; Possibly remove from cache, if that is used.
9514 (and gnus-use-cache (gnus-cache-enter-remove-article article))
9515 (and gnus-newsgroup-auto-expire
9516 (or (= mark gnus-killed-mark) (= mark gnus-del-mark)
9517 (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
9518 (= mark gnus-read-mark))
9519 (progn
9520 (setq mark gnus-expirable-mark)
9521 (setq gnus-newsgroup-expirable
9522 (cons article gnus-newsgroup-expirable))))
9523 (while (eq (gnus-summary-article-mark) gnus-dummy-mark)
9524 (forward-line 1))
9525 ;; Fix the mark.
9526 (gnus-summary-update-mark mark 'unread)
9527 t))
9528
9529(defun gnus-summary-mark-article-as-unread (mark)
9530 "Mark the current article quickly as unread with MARK."
9531 (let ((article (gnus-summary-article-number)))
9532 (or (memq article gnus-newsgroup-unreads)
9533 (setq gnus-newsgroup-unreads (cons article gnus-newsgroup-unreads)))
9534 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
9535 (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
9536 (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
9537 (setq gnus-newsgroup-reads
9538 (delq (assq article gnus-newsgroup-reads)
9539 gnus-newsgroup-reads))
9540 (if (= mark gnus-ticked-mark)
9541 (setq gnus-newsgroup-marked (cons article gnus-newsgroup-marked)))
9542 (if (= mark gnus-dormant-mark)
9543 (setq gnus-newsgroup-dormant (cons article gnus-newsgroup-dormant)))
9544
9545 ;; See whether the article is to be put in the cache.
9546 (and gnus-use-cache
9547 (vectorp (gnus-get-header-by-num article))
9548 (save-excursion
9549 (gnus-cache-possibly-enter-article
9550 gnus-newsgroup-name article
9551 (gnus-get-header-by-num article)
9552 (= mark gnus-ticked-mark)
9553 (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
9554
9555 (while (eq (gnus-summary-article-mark) gnus-dummy-mark)
9556 (forward-line 1))
9557 ;; Fix the mark.
9558 (gnus-summary-update-mark mark 'unread)
9559 t))
9560
9561(defun gnus-summary-mark-article (&optional article mark no-expire)
9562 "Mark ARTICLE with MARK. MARK can be any character.
9563Four MARK strings are reserved: `? ' (unread), `?!' (ticked), `??'
9564(dormant) and `?E' (expirable).
9565If MARK is nil, then the default character `?D' is used.
9566If ARTICLE is nil, then the article on the current line will be
9567marked."
9568 (and (stringp mark)
9569 (setq mark (aref mark 0)))
9570 ;; If no mark is given, then we check auto-expiring.
9571 (and (not no-expire)
9572 gnus-newsgroup-auto-expire
9573 (or (not mark)
9574 (and (numberp mark)
9575 (or (= mark gnus-killed-mark) (= mark gnus-del-mark)
9576 (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
9577 (= mark gnus-read-mark))))
9578 (setq mark gnus-expirable-mark))
9579 (let* ((mark (or mark gnus-del-mark))
9580 (article (or article (gnus-summary-article-number))))
9581 (or article (error "No article on current line"))
9582 (if (or (= mark gnus-unread-mark)
9583 (= mark gnus-ticked-mark)
9584 (= mark gnus-dormant-mark))
9585 (gnus-mark-article-as-unread article mark)
9586 (gnus-mark-article-as-read article mark))
9587
9588 ;; See whether the article is to be put in the cache.
9589 (and gnus-use-cache
9590 (not (= mark gnus-canceled-mark))
9591 (vectorp (gnus-get-header-by-num article))
9592 (save-excursion
9593 (gnus-cache-possibly-enter-article
9594 gnus-newsgroup-name article
9595 (gnus-get-header-by-num article)
9596 (= mark gnus-ticked-mark)
9597 (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
9598
9599 (if (gnus-summary-goto-subject article)
9600 (let ((buffer-read-only nil))
9601 (gnus-summary-show-thread)
9602 (and (eq (gnus-summary-article-mark) gnus-dummy-mark)
9603 (forward-line 1))
9604 ;; Fix the mark.
9605 (gnus-summary-update-mark mark 'unread)
9606 t))))
9607
9608(defun gnus-summary-update-mark (mark type)
9609 (beginning-of-line)
9610 (let ((forward (cdr (assq type gnus-summary-mark-positions)))
9611 (buffer-read-only nil)
9612 plist)
9613 (if (not forward)
9614 ()
9615 (forward-char forward)
9616 (setq plist (text-properties-at (point)))
9617 (delete-char 1)
9618 (insert mark)
9619 (and plist (add-text-properties (1- (point)) (point) plist))
9620 (and (eq type 'unread)
9621 (progn
9622 (add-text-properties (1- (point)) (point) (list 'gnus-mark mark))
9623 (gnus-summary-update-line (eq mark gnus-unread-mark)))))))
9624
9625(defun gnus-mark-article-as-read (article &optional mark)
9626 "Enter ARTICLE in the pertinent lists and remove it from others."
9627 ;; Make the article expirable.
9628 (let ((mark (or mark gnus-del-mark)))
9629 (if (= mark gnus-expirable-mark)
9630 (setq gnus-newsgroup-expirable (cons article gnus-newsgroup-expirable))
9631 (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)))
9632 ;; Remove from unread and marked lists.
9633 (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
9634 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
9635 (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
9636 (setq gnus-newsgroup-reads
9637 (cons (cons article mark) gnus-newsgroup-reads))
9638 ;; Possibly remove from cache, if that is used.
9639 (and gnus-use-cache (gnus-cache-enter-remove-article article))))
9640
9641(defun gnus-mark-article-as-unread (article &optional mark)
9642 "Enter ARTICLE in the pertinent lists and remove it from others."
9643 (let ((mark (or mark gnus-ticked-mark)))
9644 ;; Add to unread list.
9645 (or (memq article gnus-newsgroup-unreads)
9646 (setq gnus-newsgroup-unreads (cons article gnus-newsgroup-unreads)))
9647 (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
9648 (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
9649 (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
9650 (setq gnus-newsgroup-reads
9651 (delq (assq article gnus-newsgroup-reads)
9652 gnus-newsgroup-reads))
9653 (if (= mark gnus-ticked-mark)
9654 (setq gnus-newsgroup-marked (cons article gnus-newsgroup-marked)))
9655 (if (= mark gnus-dormant-mark)
9656 (setq gnus-newsgroup-dormant (cons article gnus-newsgroup-dormant)))))
9657
9658(defalias 'gnus-summary-mark-as-unread-forward
9659 'gnus-summary-tick-article-forward)
9660(make-obsolete 'gnus-summary-mark-as-unread-forward
9661 'gnus-summary-tick-article-forward)
9662(defun gnus-summary-tick-article-forward (n)
9663 "Tick N articles forwards.
9664If N is negative, tick backwards instead.
9665The difference between N and the number of articles ticked is returned."
745bc783 9666 (interactive "p")
41487370
LMI
9667 (gnus-summary-mark-forward n gnus-ticked-mark))
9668
9669(defalias 'gnus-summary-mark-as-unread-backward
9670 'gnus-summary-tick-article-backward)
9671(make-obsolete 'gnus-summary-mark-as-unread-backward
9672 'gnus-summary-tick-article-backward)
9673(defun gnus-summary-tick-article-backward (n)
9674 "Tick N articles backwards.
9675The difference between N and the number of articles ticked is returned."
9676 (interactive "p")
9677 (gnus-summary-mark-forward (- n) gnus-ticked-mark))
745bc783 9678
41487370
LMI
9679(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
9680(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
9681(defun gnus-summary-tick-article (&optional article clear-mark)
745bc783 9682 "Mark current article as unread.
b027f415
RS
9683Optional 1st argument ARTICLE specifies article number to be marked as unread.
9684Optional 2nd argument CLEAR-MARK remove any kinds of mark."
41487370
LMI
9685 (gnus-summary-mark-article article (if clear-mark gnus-unread-mark
9686 gnus-ticked-mark)))
9687
9688(defun gnus-summary-mark-as-read-forward (n)
9689 "Mark N articles as read forwards.
9690If N is negative, mark backwards instead.
9691The difference between N and the actual number of articles marked is
9692returned."
745bc783 9693 (interactive "p")
41487370
LMI
9694 (gnus-summary-mark-forward n gnus-del-mark t))
9695
9696(defun gnus-summary-mark-as-read-backward (n)
9697 "Mark the N articles as read backwards.
9698The difference between N and the actual number of articles marked is
9699returned."
745bc783 9700 (interactive "p")
41487370 9701 (gnus-summary-mark-forward (- n) gnus-del-mark t))
745bc783 9702
b027f415 9703(defun gnus-summary-mark-as-read (&optional article mark)
745bc783 9704 "Mark current article as read.
41487370
LMI
9705ARTICLE specifies the article to be marked as read.
9706MARK specifies a string to be inserted at the beginning of the line."
9707 (gnus-summary-mark-article article mark))
9708
9709(defun gnus-summary-clear-mark-forward (n)
9710 "Clear marks from N articles forward.
9711If N is negative, clear backward instead.
9712The difference between N and the number of marks cleared is returned."
745bc783 9713 (interactive "p")
41487370 9714 (gnus-summary-mark-forward n gnus-unread-mark))
745bc783 9715
41487370
LMI
9716(defun gnus-summary-clear-mark-backward (n)
9717 "Clear marks from N articles backward.
9718The difference between N and the number of marks cleared is returned."
9719 (interactive "p")
9720 (gnus-summary-mark-forward (- n) gnus-unread-mark))
9721
9722(defun gnus-summary-mark-unread-as-read ()
9723 "Intended to be used by `gnus-summary-mark-article-hook'."
9724 (or (memq gnus-current-article gnus-newsgroup-marked)
9725 (memq gnus-current-article gnus-newsgroup-dormant)
9726 (memq gnus-current-article gnus-newsgroup-expirable)
9727 (gnus-summary-mark-article gnus-current-article gnus-read-mark)))
9728
9729(defun gnus-summary-mark-region-as-read (point mark all)
9730 "Mark all unread articles between point and mark as read.
9731If given a prefix, mark all articles between point and mark as read,
9732even ticked and dormant ones."
9733 (interactive "r\nP")
9734 (save-excursion
9735 (goto-char point)
9736 (beginning-of-line)
9737 (while (and
9738 (< (point) mark)
9739 (progn
9740 (and
9741 (or all
9742 (and
9743 (not (memq (gnus-summary-article-number)
9744 gnus-newsgroup-marked))
9745 (not (memq (gnus-summary-article-number)
9746 gnus-newsgroup-dormant))))
9747 (gnus-summary-mark-article
9748 (gnus-summary-article-number) gnus-del-mark))
9749 t)
9750 (zerop (forward-line 1))))))
9751
9752;; Fix by Per Abrahamsen <amanda@iesd.auc.dk>.
9753(defalias 'gnus-summary-delete-marked-as-read
9754 'gnus-summary-remove-lines-marked-as-read)
9755(make-obsolete 'gnus-summary-delete-marked-as-read
9756 'gnus-summary-remove-lines-marked-as-read)
9757(defun gnus-summary-remove-lines-marked-as-read ()
9758 "Remove lines that are marked as read."
745bc783 9759 (interactive)
41487370
LMI
9760 (gnus-summary-remove-lines-marked-with
9761 (concat (mapconcat
9762 (lambda (char) (char-to-string (symbol-value char)))
9763 '(gnus-del-mark gnus-read-mark gnus-ancient-mark
9764 gnus-killed-mark gnus-kill-file-mark
9765 gnus-low-score-mark gnus-expirable-mark
9766 gnus-canceled-mark gnus-catchup-mark)
9767 ""))))
9768
9769(defalias 'gnus-summary-delete-marked-with
9770 'gnus-summary-remove-lines-marked-with)
9771(make-obsolete 'gnus-summary-delete-marked-with
9772 'gnus-summary-remove-lines-marked-with)
9773;; Rewrite by Daniel Quinlan <quinlan@best.com>.
9774(defun gnus-summary-remove-lines-marked-with (marks)
9775 "Remove lines that are marked with MARKS (e.g. \"DK\")."
745bc783 9776 (interactive "sMarks: ")
41487370
LMI
9777 ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
9778 (gnus-set-global-variables)
9779 (let ((buffer-read-only nil)
7e988fb6 9780 (orig-article
6346a6e6 9781 (let ((gnus-summary-check-current t))
7e988fb6
LMI
9782 (gnus-summary-search-forward t)
9783 (gnus-summary-article-number)))
41487370
LMI
9784 (marks (concat "^[" marks "]")))
9785 (goto-char (point-min))
9786 (if gnus-newsgroup-adaptive
9787 (gnus-score-remove-lines-adaptive marks)
9788 (while (re-search-forward marks nil t)
9789 (gnus-delete-line)))
9790 ;; If we use dummy roots, we have to do an additional sweep over
9791 ;; the buffer.
9792 (if (not (eq gnus-summary-make-false-root 'dummy))
9793 ()
745bc783 9794 (goto-char (point-min))
41487370
LMI
9795 (setq marks (concat "^[" (char-to-string gnus-dummy-mark) "]"))
9796 (while (re-search-forward marks nil t)
9797 (if (gnus-subject-equal
9798 (gnus-summary-subject-string)
9799 (progn
9800 (forward-line 1)
9801 (gnus-summary-subject-string)))
9802 ()
9803 (forward-line -1)
9804 (gnus-delete-line))))
745bc783 9805 (or (zerop (buffer-size))
41487370 9806 (gnus-summary-goto-subject orig-article)
745bc783 9807 (if (eobp)
b027f415 9808 (gnus-summary-prev-subject 1)
41487370
LMI
9809 (gnus-summary-position-cursor)))))
9810
9811(defun gnus-summary-expunge-below (&optional score)
9812 "Remove articles with score less than SCORE."
9813 (interactive "P")
9814 (gnus-set-global-variables)
9815 (setq score (if score
9816 (prefix-numeric-value score)
9817 (or gnus-summary-default-score 0)))
9818 (save-excursion
9819 (set-buffer gnus-summary-buffer)
9820 (goto-char (point-min))
9821 (let ((buffer-read-only nil)
9822 beg)
9823 (while (not (eobp))
9824 (if (< (gnus-summary-article-score) score)
9825 (progn
9826 (setq beg (point))
9827 (forward-line 1)
9828 (delete-region beg (point)))
9829 (forward-line 1)))
9830 ;; Adjust point.
9831 (or (zerop (buffer-size))
9832 (if (eobp)
9833 (gnus-summary-prev-subject 1)
9834 (gnus-summary-position-cursor))))))
9835
9836(defun gnus-summary-mark-below (score mark)
9837 "Mark articles with score less than SCORE with MARK."
9838 (interactive "P\ncMark: ")
9839 (gnus-set-global-variables)
9840 (setq score (if score
9841 (prefix-numeric-value score)
9842 (or gnus-summary-default-score 0)))
9843 (save-excursion
9844 (set-buffer gnus-summary-buffer)
9845 (goto-char (point-min))
9846 (while (not (eobp))
9847 (and (< (gnus-summary-article-score) score)
9848 (gnus-summary-mark-article nil mark))
9849 (forward-line 1))))
9850
9851(defun gnus-summary-kill-below (&optional score)
9852 "Mark articles with score below SCORE as read."
9853 (interactive "P")
9854 (gnus-set-global-variables)
9855 (gnus-summary-mark-below score gnus-killed-mark))
9856
9857(defun gnus-summary-clear-above (&optional score)
9858 "Clear all marks from articles with score above SCORE."
9859 (interactive "P")
9860 (gnus-set-global-variables)
9861 (gnus-summary-mark-above score gnus-unread-mark))
9862
9863(defun gnus-summary-tick-above (&optional score)
9864 "Tick all articles with score above SCORE."
9865 (interactive "P")
9866 (gnus-set-global-variables)
9867 (gnus-summary-mark-above score gnus-ticked-mark))
9868
9869(defun gnus-summary-mark-above (score mark)
9870 "Mark articles with score over SCORE with MARK."
9871 (interactive "P\ncMark: ")
9872 (gnus-set-global-variables)
9873 (setq score (if score
9874 (prefix-numeric-value score)
9875 (or gnus-summary-default-score 0)))
9876 (save-excursion
9877 (set-buffer gnus-summary-buffer)
9878 (goto-char (point-min))
9879 (while (not (eobp))
9880 (if (> (gnus-summary-article-score) score)
9881 (progn
9882 (gnus-summary-mark-article nil mark)
9883 (forward-line 1))
9884 (forward-line 1)))))
9885
9886;; Suggested by Daniel Quinlan <quinlan@best.com>.
9887(defun gnus-summary-show-all-expunged ()
9888 "Display all the hidden articles that were expunged for low scores."
9889 (interactive)
9890 (gnus-set-global-variables)
9891 (let ((buffer-read-only nil))
9892 (let ((scored gnus-newsgroup-scored)
9893 headers h)
9894 (while scored
9895 (or (gnus-summary-goto-subject (car (car scored)))
9896 (and (setq h (gnus-get-header-by-num (car (car scored))))
9897 (< (cdr (car scored)) gnus-summary-expunge-below)
9898 (setq headers (cons h headers))))
9899 (setq scored (cdr scored)))
9900 (or headers (error "No expunged articles hidden."))
9901 (goto-char (point-min))
9902 (save-excursion
9903 (gnus-summary-update-lines
9904 (point)
9905 (progn
9906 (gnus-summary-prepare-unthreaded (nreverse headers))
9907 (point)))))
9908 (goto-char (point-min))
9909 (gnus-summary-position-cursor)))
9910
9911(defun gnus-summary-show-all-dormant ()
9912 "Display all the hidden articles that are marked as dormant."
9913 (interactive)
9914 (gnus-set-global-variables)
9915 (let ((buffer-read-only nil))
9916 (let ((dormant gnus-newsgroup-dormant)
9917 headers h)
9918 (while dormant
9919 (or (gnus-summary-goto-subject (car dormant))
9920 (and (setq h (gnus-get-header-by-num (car dormant)))
9921 (setq headers (cons h headers))))
9922 (setq dormant (cdr dormant)))
9923 (or headers (error "No dormant articles hidden."))
9924 (goto-char (point-min))
9925 (save-excursion
9926 (gnus-summary-update-lines
9927 (point)
9928 (progn
9929 (gnus-summary-prepare-unthreaded (nreverse headers))
9930 (point)))))
9931 (goto-char (point-min))
9932 (gnus-summary-position-cursor)))
9933
9934(defun gnus-summary-hide-all-dormant ()
9935 "Hide all dormant articles."
9936 (interactive)
9937 (gnus-set-global-variables)
9938 (gnus-summary-remove-lines-marked-with (char-to-string gnus-dormant-mark))
9939 (gnus-summary-position-cursor))
9940
9941(defun gnus-summary-catchup (&optional all quietly to-here not-mark)
9942 "Mark all articles not marked as unread in this newsgroup as read.
9943If prefix argument ALL is non-nil, all articles are marked as read.
9944If QUIETLY is non-nil, no questions will be asked.
9945If TO-HERE is non-nil, it should be a point in the buffer. All
9946articles before this point will be marked as read.
9947The number of articles marked as read is returned."
9948 (interactive "P")
9949 (gnus-set-global-variables)
9950 (prog1
9951 (if (or quietly
9952 (not gnus-interactive-catchup) ;Without confirmation?
9953 gnus-expert-user
9954 (gnus-y-or-n-p
9955 (if all
9956 "Mark absolutely all articles as read? "
9957 "Mark all unread articles as read? ")))
9958 (if (and not-mark
9959 (not gnus-newsgroup-adaptive)
9960 (not gnus-newsgroup-auto-expire))
9961 (progn
9962 (and all (setq gnus-newsgroup-marked nil
9963 gnus-newsgroup-dormant nil))
9964 (setq gnus-newsgroup-unreads
9965 (append gnus-newsgroup-marked gnus-newsgroup-dormant)))
9966 ;; We actually mark all articles as canceled, which we
9967 ;; have to do when using auto-expiry or adaptive scoring.
9968 (gnus-summary-show-all-threads)
9969 (if (gnus-summary-first-subject (not all))
9970 (while (and
9971 (if to-here (< (point) to-here) t)
9972 (gnus-summary-mark-article-as-read gnus-catchup-mark)
9973 (gnus-summary-search-subject nil (not all)))))
9974 (or to-here
9975 (setq gnus-newsgroup-unreads
9976 (append gnus-newsgroup-marked
9977 gnus-newsgroup-dormant)))))
9978 (let ((method (gnus-find-method-for-group gnus-newsgroup-name)))
9979 (if (and (not to-here) (eq 'nnvirtual (car method)))
9980 (nnvirtual-catchup-group
9981 (gnus-group-real-name gnus-newsgroup-name) (nth 1 method) all)))
9982 (gnus-summary-position-cursor)))
9983
9984(defun gnus-summary-catchup-to-here (&optional all)
9985 "Mark all unticked articles before the current one as read.
9986If ALL is non-nil, also mark ticked and dormant articles as read."
9987 (interactive "P")
9988 (gnus-set-global-variables)
9989 (save-excursion
9990 (and (zerop (forward-line -1))
9991 (progn
9992 (end-of-line)
9993 (gnus-summary-catchup all t (point))
9994 (gnus-set-mode-line 'summary))))
9995 (gnus-summary-position-cursor))
9996
9997(defun gnus-summary-catchup-all (&optional quietly)
9998 "Mark all articles in this newsgroup as read."
9999 (interactive "P")
10000 (gnus-set-global-variables)
10001 (gnus-summary-catchup t quietly))
10002
10003(defun gnus-summary-catchup-and-exit (&optional all quietly)
10004 "Mark all articles not marked as unread in this newsgroup as read, then exit.
10005If prefix argument ALL is non-nil, all articles are marked as read."
10006 (interactive "P")
10007 (gnus-set-global-variables)
10008 (gnus-summary-catchup all quietly nil 'fast)
10009 ;; Select next newsgroup or exit.
10010 (if (and (eq gnus-auto-select-next 'quietly)
10011 (not (gnus-ephemeral-group-p gnus-newsgroup-name)))
10012 (gnus-summary-next-group nil)
10013 (gnus-summary-exit)))
10014
10015(defun gnus-summary-catchup-all-and-exit (&optional quietly)
10016 "Mark all articles in this newsgroup as read, and then exit."
10017 (interactive "P")
10018 (gnus-set-global-variables)
10019 (gnus-summary-catchup-and-exit t quietly))
10020
10021;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>.
10022(defun gnus-summary-catchup-and-goto-next-group (&optional all)
10023 "Mark all articles in this group as read and select the next group.
10024If given a prefix, mark all articles, unread as well as ticked, as
10025read."
10026 (interactive "P")
10027 (gnus-set-global-variables)
10028 (gnus-summary-catchup all)
10029 (gnus-summary-next-group))
745bc783
JB
10030
10031;; Thread-based commands.
10032
41487370 10033(defun gnus-summary-toggle-threads (&optional arg)
745bc783 10034 "Toggle showing conversation threads.
41487370 10035If ARG is positive number, turn showing conversation threads on."
745bc783 10036 (interactive "P")
41487370
LMI
10037 (gnus-set-global-variables)
10038 (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end)))
745bc783
JB
10039 (setq gnus-show-threads
10040 (if (null arg) (not gnus-show-threads)
10041 (> (prefix-numeric-value arg) 0)))
b027f415
RS
10042 (gnus-summary-prepare)
10043 (gnus-summary-goto-subject current)
41487370 10044 (gnus-summary-position-cursor)))
745bc783 10045
b027f415 10046(defun gnus-summary-show-all-threads ()
41487370 10047 "Show all threads."
745bc783 10048 (interactive)
41487370
LMI
10049 (gnus-set-global-variables)
10050 (save-excursion
10051 (let ((buffer-read-only nil))
10052 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)))
10053 (gnus-summary-position-cursor))
745bc783 10054
b027f415 10055(defun gnus-summary-show-thread ()
41487370
LMI
10056 "Show thread subtrees.
10057Returns nil if no thread was there to be shown."
745bc783 10058 (interactive)
41487370
LMI
10059 (gnus-set-global-variables)
10060 (let ((buffer-read-only nil)
10061 (orig (prog1 (point) (gnus-summary-hide-thread)))
10062 ;; first goto end then to beg, to have point at beg after let
10063 (end (progn (end-of-line) (point)))
10064 (beg (progn (beginning-of-line) (point))))
10065 (prog1
10066 ;; Any hidden lines here?
10067 (search-forward "\r" end t)
10068 (subst-char-in-region beg end ?\^M ?\n t)
10069 (goto-char orig)
10070 (gnus-summary-position-cursor))))
745bc783 10071
b027f415 10072(defun gnus-summary-hide-all-threads ()
745bc783
JB
10073 "Hide all thread subtrees."
10074 (interactive)
41487370
LMI
10075 (gnus-set-global-variables)
10076 (save-excursion
10077 (goto-char (point-min))
10078 (gnus-summary-hide-thread)
10079 (while (and (not (eobp)) (zerop (forward-line 1)))
10080 (gnus-summary-hide-thread)))
10081 (gnus-summary-position-cursor))
745bc783 10082
b027f415 10083(defun gnus-summary-hide-thread ()
41487370
LMI
10084 "Hide thread subtrees.
10085Returns nil if no threads were there to be hidden."
745bc783 10086 (interactive)
41487370
LMI
10087 (gnus-set-global-variables)
10088 (let ((buffer-read-only nil)
10089 (start (point))
10090 (level (gnus-summary-thread-level))
10091 (end (point)))
10092 ;; Go forward until either the buffer ends or the subthread
10093 ;; ends.
10094 (if (eobp)
10095 ()
10096 (while (and (zerop (forward-line 1))
10097 (> (gnus-summary-thread-level) level))
10098 (setq end (point)))
10099 (prog1
10100 (save-excursion
10101 (goto-char end)
10102 (search-backward "\n" start t))
10103 (subst-char-in-region start end ?\n ?\^M t)
10104 (forward-line -1)
10105 (gnus-summary-position-cursor)))))
10106
10107(defun gnus-summary-go-to-next-thread (&optional previous)
10108 "Go to the same level (or less) next thread.
10109If PREVIOUS is non-nil, go to previous thread instead.
10110Return the article number moved to, or nil if moving was impossible."
10111 (let ((level (gnus-summary-thread-level))
10112 (article (gnus-summary-article-number)))
10113 (if previous
10114 (while (and (zerop (forward-line -1))
10115 (> (gnus-summary-thread-level) level)))
10116 (while (and (save-excursion
10117 (forward-line 1)
10118 (not (eobp)))
10119 (zerop (forward-line 1))
10120 (> (gnus-summary-thread-level) level))))
10121 (gnus-summary-recenter)
10122 (gnus-summary-position-cursor)
10123 (let ((oart (gnus-summary-article-number)))
10124 (and (/= oart article) oart))))
745bc783 10125
b027f415 10126(defun gnus-summary-next-thread (n)
41487370
LMI
10127 "Go to the same level next N'th thread.
10128If N is negative, search backward instead.
10129Returns the difference between N and the number of skips actually
10130done."
745bc783 10131 (interactive "p")
41487370
LMI
10132 (gnus-set-global-variables)
10133 (let ((backward (< n 0))
10134 (n (abs n)))
745bc783 10135 (while (and (> n 0)
41487370
LMI
10136 (gnus-summary-go-to-next-thread backward))
10137 (setq n (1- n)))
10138 (gnus-summary-position-cursor)
10139 (if (/= 0 n) (gnus-message 7 "No more threads"))
10140 n))
745bc783 10141
b027f415 10142(defun gnus-summary-prev-thread (n)
41487370
LMI
10143 "Go to the same level previous N'th thread.
10144Returns the difference between N and the number of skips actually
10145done."
745bc783 10146 (interactive "p")
41487370
LMI
10147 (gnus-set-global-variables)
10148 (gnus-summary-next-thread (- n)))
10149
10150(defun gnus-summary-go-down-thread (&optional same)
10151 "Go down one level in the current thread.
10152If SAME is non-nil, also move to articles of the same level."
10153 (let ((level (gnus-summary-thread-level))
10154 (start (point)))
10155 (if (and (zerop (forward-line 1))
10156 (> (gnus-summary-thread-level) level))
10157 t
10158 (goto-char start)
10159 nil)))
10160
10161(defun gnus-summary-go-up-thread ()
10162 "Go up one level in the current thread."
10163 (let ((level (gnus-summary-thread-level))
10164 (start (point)))
10165 (while (and (zerop (forward-line -1))
10166 (>= (gnus-summary-thread-level) level)))
10167 (if (>= (gnus-summary-thread-level) level)
10168 (progn
10169 (goto-char start)
10170 nil)
10171 t)))
10172
10173(defun gnus-summary-down-thread (n)
10174 "Go down thread N steps.
10175If N is negative, go up instead.
10176Returns the difference between N and how many steps down that were
10177taken."
745bc783 10178 (interactive "p")
41487370
LMI
10179 (gnus-set-global-variables)
10180 (let ((up (< n 0))
10181 (n (abs n)))
10182 (while (and (> n 0)
10183 (if up (gnus-summary-go-up-thread)
10184 (gnus-summary-go-down-thread)))
10185 (setq n (1- n)))
10186 (gnus-summary-position-cursor)
10187 (if (/= 0 n) (gnus-message 7 "Can't go further"))
10188 n))
10189
10190(defun gnus-summary-up-thread (n)
10191 "Go up thread N steps.
10192If N is negative, go up instead.
10193Returns the difference between N and how many steps down that were
10194taken."
745bc783 10195 (interactive "p")
41487370
LMI
10196 (gnus-set-global-variables)
10197 (gnus-summary-down-thread (- n)))
10198
10199(defun gnus-summary-kill-thread (&optional unmark)
745bc783 10200 "Mark articles under current thread as read.
41487370
LMI
10201If the prefix argument is positive, remove any kinds of marks.
10202If the prefix argument is negative, tick articles instead."
745bc783 10203 (interactive "P")
41487370 10204 (gnus-set-global-variables)
745bc783
JB
10205 (if unmark
10206 (setq unmark (prefix-numeric-value unmark)))
41487370
LMI
10207 (let ((killing t)
10208 (level (gnus-summary-thread-level)))
10209 (save-excursion
10210 ;; Expand the thread.
10211 (gnus-summary-show-thread)
10212 (while killing
10213 ;; Mark the article...
10214 (cond ((null unmark) (gnus-summary-mark-article-as-read
10215 gnus-killed-mark))
10216 ((> unmark 0) (gnus-summary-mark-article-as-unread
10217 gnus-unread-mark))
10218 (t (gnus-summary-mark-article-as-unread gnus-ticked-mark)))
10219 ;; ...and go forward until either the buffer ends or the subtree
10220 ;; ends.
10221 (if (not (and (zerop (forward-line 1))
10222 (> (gnus-summary-thread-level) level)))
10223 (setq killing nil))))
10224 ;; Hide killed subtrees.
10225 (and (null unmark)
10226 gnus-thread-hide-killed
10227 (gnus-summary-hide-thread))
10228 ;; If marked as read, go to next unread subject.
10229 (if (null unmark)
10230 ;; Go to next unread subject.
10231 (gnus-summary-next-subject 1 t)))
10232 (gnus-set-mode-line 'summary))
745bc783 10233
41487370 10234;; Summary sorting commands
745bc783 10235
41487370
LMI
10236(defun gnus-summary-sort-by-number (&optional reverse)
10237 "Sort summary buffer by article number.
745bc783
JB
10238Argument REVERSE means reverse order."
10239 (interactive "P")
41487370
LMI
10240 (gnus-set-global-variables)
10241 (gnus-summary-sort
10242 ;; `gnus-summary-article-number' is a macro, and `sort-subr' wants
10243 ;; a function, so we wrap it.
10244 (cons (lambda () (gnus-summary-article-number))
10245 'gnus-thread-sort-by-number) reverse))
10246
10247(defun gnus-summary-sort-by-author (&optional reverse)
10248 "Sort summary buffer by author name alphabetically.
745bc783
JB
10249If case-fold-search is non-nil, case of letters is ignored.
10250Argument REVERSE means reverse order."
10251 (interactive "P")
41487370
LMI
10252 (gnus-set-global-variables)
10253 (gnus-summary-sort
10254 (cons
10255 (lambda ()
10256 (let* ((header (gnus-get-header-by-num (gnus-summary-article-number)))
7e988fb6
LMI
10257 extract)
10258 (if (not (vectorp header))
10259 ""
10260 (setq extract (funcall gnus-extract-address-components
10261 (mail-header-from header)))
10262 (concat (or (car extract) (cdr extract))
10263 "\r" (int-to-string (mail-header-number header))
10264 "\r" (mail-header-subject header)))))
41487370
LMI
10265 'gnus-thread-sort-by-author)
10266 reverse))
10267
10268(defun gnus-summary-sort-by-subject (&optional reverse)
10269 "Sort summary buffer by subject alphabetically. `Re:'s are ignored.
745bc783
JB
10270If case-fold-search is non-nil, case of letters is ignored.
10271Argument REVERSE means reverse order."
10272 (interactive "P")
41487370
LMI
10273 (gnus-set-global-variables)
10274 (gnus-summary-sort
10275 (cons
10276 (lambda ()
10277 (let* ((header (gnus-get-header-by-num (gnus-summary-article-number)))
7e988fb6
LMI
10278 extract)
10279 (if (not (vectorp header))
10280 ""
10281 (setq extract (funcall gnus-extract-address-components
10282 (mail-header-from header)))
10283 (concat
10284 (downcase (gnus-simplify-subject (gnus-summary-subject-string) t))
10285 "\r" (int-to-string (mail-header-number header))
10286 "\r" (or (car extract) (cdr extract))))))
41487370
LMI
10287 'gnus-thread-sort-by-subject)
10288 reverse))
10289
10290(defun gnus-summary-sort-by-date (&optional reverse)
10291 "Sort summary buffer by date.
745bc783
JB
10292Argument REVERSE means reverse order."
10293 (interactive "P")
41487370
LMI
10294 (gnus-set-global-variables)
10295 (gnus-summary-sort
10296 (cons
10297 (lambda ()
10298 (gnus-sortable-date
10299 (mail-header-date
10300 (gnus-get-header-by-num (gnus-summary-article-number)))))
10301 'gnus-thread-sort-by-date)
10302 reverse))
10303
10304(defun gnus-summary-sort-by-score (&optional reverse)
10305 "Sort summary buffer by score.
10306Argument REVERSE means reverse order."
745bc783 10307 (interactive "P")
41487370
LMI
10308 (gnus-set-global-variables)
10309 (gnus-summary-sort
10310 (cons (lambda () (gnus-summary-article-score))
10311 'gnus-thread-sort-by-score)
10312 (not reverse)))
10313
10314(defvar gnus-summary-already-sorted nil)
10315(defun gnus-summary-sort (predicate reverse)
10316 ;; Sort summary buffer by PREDICATE. REVERSE means reverse order.
10317 (if gnus-summary-already-sorted
10318 ()
10319 (let (buffer-read-only)
10320 (if (not gnus-show-threads)
10321 ;; We do untreaded sorting...
10322 (progn
10323 (goto-char (point-min))
10324 (sort-subr reverse 'forward-line 'end-of-line (car predicate)))
10325 ;; ... or we do threaded sorting.
10326 (let ((gnus-thread-sort-functions (list (cdr predicate)))
10327 (gnus-summary-prepare-hook nil)
10328 (gnus-summary-already-sorted nil))
10329 ;; We do that by simply regenerating the threads.
10330 (gnus-summary-prepare)
10331 (and gnus-show-threads
10332 gnus-thread-hide-subtree
10333 (gnus-summary-hide-all-threads))
10334 ;; If in async mode, we send some info to the backend.
10335 (and gnus-newsgroup-async
10336 (setq gnus-newsgroup-threads (nreverse gnus-newsgroup-threads))
10337 (gnus-request-asynchronous
10338 gnus-newsgroup-name
10339 (if (and gnus-asynchronous-article-function
10340 (fboundp gnus-asynchronous-article-function))
10341 (funcall gnus-asynchronous-article-function
10342 gnus-newsgroup-threads)
10343 gnus-newsgroup-threads))))))))
10344
10345
10346(defun gnus-sortable-date (date)
10347 "Make sortable string by string-lessp from DATE.
10348Timezone package is used."
10349 (let* ((date (timezone-fix-time date nil nil)) ;[Y M D H M S]
10350 (year (aref date 0))
10351 (month (aref date 1))
10352 (day (aref date 2)))
10353 (timezone-make-sortable-date
10354 year month day
10355 (timezone-make-time-string
10356 (aref date 3) (aref date 4) (aref date 5)))))
10357
10358
10359;; Summary saving commands.
10360
10361(defun gnus-summary-save-article (&optional n)
10362 "Save the current article using the default saver function.
10363If N is a positive number, save the N next articles.
10364If N is a negative number, save the N previous articles.
10365If N is nil and any articles have been marked with the process mark,
10366save those articles instead.
b027f415 10367The variable `gnus-default-article-saver' specifies the saver function."
41487370
LMI
10368 (interactive "P")
10369 (gnus-set-global-variables)
10370 (let ((articles (gnus-summary-work-articles n)))
10371 (while articles
10372 (let ((header (gnus-get-header-by-num (car articles))))
10373 (if (vectorp header)
10374 (progn
10375 (save-window-excursion
10376 (gnus-summary-select-article t nil nil (car articles)))
10377 (or gnus-save-all-headers
10378 (gnus-article-hide-headers t))
10379 ;; Remove any X-Gnus lines.
10380 (save-excursion
10381 (save-restriction
10382 (set-buffer gnus-article-buffer)
10383 (let ((buffer-read-only nil))
10384 (goto-char (point-min))
10385 (narrow-to-region (point) (or (search-forward "\n\n" nil t)
10386 (point-max)))
10387 (while (re-search-forward "^X-Gnus" nil t)
10388 (beginning-of-line)
10389 (delete-region (point)
10390 (progn (forward-line 1) (point))))
10391 (widen))))
10392 (save-window-excursion
10393 (if gnus-default-article-saver
10394 (funcall gnus-default-article-saver)
10395 (error "No default saver is defined."))))
10396 (if (assq 'name header)
10397 (gnus-copy-file (cdr (assq 'name header)))
b94ae5f7 10398 (gnus-message 1 "Article %d is unsavable" (car articles)))))
41487370
LMI
10399 (gnus-summary-remove-process-mark (car articles))
10400 (setq articles (cdr articles)))
10401 (gnus-summary-position-cursor)
10402 n))
10403
10404(defun gnus-summary-pipe-output (&optional arg)
10405 "Pipe the current article to a subprocess.
10406If N is a positive number, pipe the N next articles.
10407If N is a negative number, pipe the N previous articles.
10408If N is nil and any articles have been marked with the process mark,
10409pipe those articles instead."
10410 (interactive "P")
10411 (gnus-set-global-variables)
10412 (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe))
10413 (gnus-summary-save-article arg)))
10414
10415(defun gnus-summary-save-article-mail (&optional arg)
10416 "Append the current article to an mail file.
10417If N is a positive number, save the N next articles.
10418If N is a negative number, save the N previous articles.
10419If N is nil and any articles have been marked with the process mark,
10420save those articles instead."
10421 (interactive "P")
10422 (gnus-set-global-variables)
10423 (let ((gnus-default-article-saver 'gnus-summary-save-in-mail))
10424 (gnus-summary-save-article arg)))
10425
10426(defun gnus-summary-save-article-rmail (&optional arg)
10427 "Append the current article to an rmail file.
10428If N is a positive number, save the N next articles.
10429If N is a negative number, save the N previous articles.
10430If N is nil and any articles have been marked with the process mark,
10431save those articles instead."
10432 (interactive "P")
10433 (gnus-set-global-variables)
10434 (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail))
10435 (gnus-summary-save-article arg)))
10436
10437(defun gnus-summary-save-article-file (&optional arg)
10438 "Append the current article to a file.
10439If N is a positive number, save the N next articles.
10440If N is a negative number, save the N previous articles.
10441If N is nil and any articles have been marked with the process mark,
10442save those articles instead."
10443 (interactive "P")
10444 (gnus-set-global-variables)
10445 (let ((gnus-default-article-saver 'gnus-summary-save-in-file))
10446 (gnus-summary-save-article arg)))
10447
10448(defun gnus-read-save-file-name (prompt default-name)
10449 (let ((methods gnus-split-methods)
10450 split-name)
10451 (if (not gnus-split-methods)
10452 ()
10453 (save-excursion
10454 (set-buffer gnus-article-buffer)
10455 (gnus-narrow-to-headers)
10456 (while methods
10457 (goto-char (point-min))
10458 (and (condition-case ()
10459 (re-search-forward (car (car methods)) nil t)
10460 (error nil))
10461 (setq split-name (cons (nth 1 (car methods)) split-name)))
10462 (setq methods (cdr methods)))
10463 (widen)))
10464 (cond ((null split-name)
10465 (read-file-name
10466 (concat prompt " (default "
10467 (file-name-nondirectory default-name) ") ")
10468 (file-name-directory default-name)
10469 default-name))
10470 ((= 1 (length split-name))
10471 (read-file-name
10472 (concat prompt " (default " (car split-name) ") ")
10473 gnus-article-save-directory
10474 (concat gnus-article-save-directory (car split-name))))
10475 (t
10476 (setq split-name (mapcar (lambda (el) (list el))
10477 (nreverse split-name)))
10478 (let ((result (completing-read
10479 (concat prompt " ")
10480 split-name nil nil)))
10481 (concat gnus-article-save-directory
10482 (if (string= result "")
10483 (car (car split-name))
10484 result)))))))
745bc783 10485
b027f415 10486(defun gnus-summary-save-in-rmail (&optional filename)
745bc783
JB
10487 "Append this article to Rmail file.
10488Optional argument FILENAME specifies file name.
10489Directory to save to is default to `gnus-article-save-directory' which
10490is initialized from the SAVEDIR environment variable."
10491 (interactive)
41487370
LMI
10492 (gnus-set-global-variables)
10493 (let ((default-name
10494 (funcall gnus-rmail-save-name gnus-newsgroup-name
10495 gnus-current-headers gnus-newsgroup-last-rmail)))
10496 (or filename
10497 (setq filename (gnus-read-save-file-name
10498 "Save in rmail file:" default-name)))
10499 (gnus-make-directory (file-name-directory filename))
10500 (gnus-eval-in-buffer-window
10501 gnus-article-buffer
10502 (save-excursion
10503 (save-restriction
10504 (widen)
10505 (gnus-output-to-rmail filename))))
10506 ;; Remember the directory name to save articles
10507 (setq gnus-newsgroup-last-rmail filename)))
745bc783 10508
b027f415 10509(defun gnus-summary-save-in-mail (&optional filename)
745bc783
JB
10510 "Append this article to Unix mail file.
10511Optional argument FILENAME specifies file name.
10512Directory to save to is default to `gnus-article-save-directory' which
10513is initialized from the SAVEDIR environment variable."
10514 (interactive)
41487370
LMI
10515 (gnus-set-global-variables)
10516 (let ((default-name
10517 (funcall gnus-mail-save-name gnus-newsgroup-name
10518 gnus-current-headers gnus-newsgroup-last-mail)))
10519 (or filename
10520 (setq filename (gnus-read-save-file-name
10521 "Save in Unix mail file:" default-name)))
10522 (setq filename
10523 (expand-file-name filename
10524 (and default-name
10525 (file-name-directory default-name))))
10526 (gnus-make-directory (file-name-directory filename))
10527 (gnus-eval-in-buffer-window
10528 gnus-article-buffer
10529 (save-excursion
10530 (save-restriction
10531 (widen)
10532 (if (and (file-readable-p filename) (mail-file-babyl-p filename))
10533 (gnus-output-to-rmail filename)
10534 (rmail-output filename 1 t t)))))
10535 ;; Remember the directory name to save articles.
10536 (setq gnus-newsgroup-last-mail filename)))
745bc783 10537
b027f415 10538(defun gnus-summary-save-in-file (&optional filename)
745bc783
JB
10539 "Append this article to file.
10540Optional argument FILENAME specifies file name.
10541Directory to save to is default to `gnus-article-save-directory' which
10542is initialized from the SAVEDIR environment variable."
10543 (interactive)
41487370
LMI
10544 (gnus-set-global-variables)
10545 (let ((default-name
10546 (funcall gnus-file-save-name gnus-newsgroup-name
10547 gnus-current-headers gnus-newsgroup-last-file)))
10548 (or filename
10549 (setq filename (gnus-read-save-file-name
10550 "Save in file:" default-name)))
10551 (gnus-make-directory (file-name-directory filename))
10552 (gnus-eval-in-buffer-window
10553 gnus-article-buffer
10554 (save-excursion
10555 (save-restriction
10556 (widen)
10557 (gnus-output-to-file filename))))
10558 ;; Remember the directory name to save articles.
10559 (setq gnus-newsgroup-last-file filename)))
10560
10561(defun gnus-summary-save-in-pipe (&optional command)
745bc783
JB
10562 "Pipe this article to subprocess."
10563 (interactive)
41487370
LMI
10564 (gnus-set-global-variables)
10565 (let ((command (read-string "Shell command on article: "
10566 gnus-last-shell-command)))
10567 (if (string-equal command "")
10568 (setq command gnus-last-shell-command))
10569 (gnus-eval-in-buffer-window
10570 gnus-article-buffer
10571 (save-restriction
10572 (widen)
10573 (shell-command-on-region (point-min) (point-max) command nil)))
10574 (setq gnus-last-shell-command command)))
10575
10576;; Summary extract commands
10577
10578(defun gnus-summary-insert-pseudos (pslist &optional not-view)
10579 (let ((buffer-read-only nil)
10580 (article (gnus-summary-article-number))
10581 b)
10582 (or (gnus-summary-goto-subject article)
10583 (error (format "No such article: %d" article)))
10584 (gnus-summary-position-cursor)
10585 ;; If all commands are to be bunched up on one line, we collect
10586 ;; them here.
10587 (if gnus-view-pseudos-separately
10588 ()
10589 (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
10590 files action)
10591 (while ps
10592 (setq action (cdr (assq 'action (car ps))))
10593 (setq files (list (cdr (assq 'name (car ps)))))
10594 (while (and ps (cdr ps)
10595 (string= (or action "1")
10596 (or (cdr (assq 'action (car (cdr ps)))) "2")))
10597 (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
10598 (setcdr ps (cdr (cdr ps))))
10599 (if (not files)
10600 ()
10601 (if (not (string-match "%s" action))
10602 (setq files (cons " " files)))
10603 (setq files (cons " " files))
10604 (and (assq 'execute (car ps))
10605 (setcdr (assq 'execute (car ps))
10606 (funcall (if (string-match "%s" action)
10607 'format 'concat)
10608 action
10609 (mapconcat (lambda (f) f) files " ")))))
10610 (setq ps (cdr ps)))))
10611 (if (and gnus-view-pseudos (not not-view))
10612 (while pslist
10613 (and (assq 'execute (car pslist))
10614 (gnus-execute-command (cdr (assq 'execute (car pslist)))
10615 (eq gnus-view-pseudos 'not-confirm)))
10616 (setq pslist (cdr pslist)))
10617 (save-excursion
10618 (while pslist
10619 (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
10620 (gnus-summary-article-number)))
10621 (forward-line 1)
10622 (setq b (point))
10623 (insert " " (file-name-nondirectory
10624 (cdr (assq 'name (car pslist))))
10625 ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
10626 (add-text-properties
10627 b (1+ b) (list 'gnus-number gnus-reffed-article-number
10628 'gnus-mark gnus-unread-mark
10629 'gnus-level 0
10630 'gnus-pseudo (car pslist)))
10631 (forward-line -1)
10632 (gnus-sethash (int-to-string gnus-reffed-article-number)
10633 (car pslist) gnus-newsgroup-headers-hashtb-by-number)
10634 (setq gnus-newsgroup-unreads
10635 (cons gnus-reffed-article-number gnus-newsgroup-unreads))
10636 (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
10637 (setq pslist (cdr pslist)))))))
10638
10639(defun gnus-pseudos< (p1 p2)
10640 (let ((c1 (cdr (assq 'action p1)))
10641 (c2 (cdr (assq 'action p2))))
10642 (and c1 c2 (string< c1 c2))))
10643
10644(defun gnus-request-pseudo-article (props)
10645 (cond ((assq 'execute props)
10646 (gnus-execute-command (cdr (assq 'execute props)))))
10647 (let ((gnus-current-article (gnus-summary-article-number)))
10648 (run-hooks 'gnus-mark-article-hook)))
10649
10650(defun gnus-execute-command (command &optional automatic)
10651 (save-excursion
10652 (gnus-article-setup-buffer)
10653 (set-buffer gnus-article-buffer)
10654 (let ((command (if automatic command (read-string "Command: " command)))
10655 (buffer-read-only nil))
10656 (erase-buffer)
10657 (insert "$ " command "\n\n")
10658 (if gnus-view-pseudo-asynchronously
10659 (start-process "gnus-execute" nil "sh" "-c" command)
10660 (call-process "sh" nil t nil "-c" command)))))
745bc783 10661
41487370
LMI
10662(defun gnus-copy-file (file &optional to)
10663 "Copy FILE to TO."
10664 (interactive
10665 (list (read-file-name "Copy file: " default-directory)
10666 (read-file-name "Copy file to: " default-directory)))
10667 (gnus-set-global-variables)
10668 (or to (setq to (read-file-name "Copy file to: " default-directory)))
10669 (and (file-directory-p to)
10670 (setq to (concat (file-name-as-directory to)
10671 (file-name-nondirectory file))))
10672 (copy-file file to))
10673
10674;; Summary kill commands.
10675
10676(defun gnus-summary-edit-global-kill (article)
10677 "Edit the \"global\" kill file."
10678 (interactive (list (gnus-summary-article-number)))
10679 (gnus-set-global-variables)
10680 (gnus-group-edit-global-kill article))
745bc783 10681
b027f415 10682(defun gnus-summary-edit-local-kill ()
41487370 10683 "Edit a local kill file applied to the current newsgroup."
745bc783 10684 (interactive)
41487370
LMI
10685 (gnus-set-global-variables)
10686 (setq gnus-current-headers
10687 (gnus-gethash
10688 (int-to-string (gnus-summary-article-number))
10689 gnus-newsgroup-headers-hashtb-by-number))
10690 (gnus-set-global-variables)
10691 (gnus-group-edit-local-kill
10692 (gnus-summary-article-number) gnus-newsgroup-name))
745bc783
JB
10693
10694\f
10695;;;
41487370 10696;;; Gnus article mode
745bc783
JB
10697;;;
10698
41487370
LMI
10699(put 'gnus-article-mode 'mode-class 'special)
10700
b94ae5f7 10701(defvar gnus-bugaboo nil)
41487370 10702
b027f415 10703(if gnus-article-mode-map
745bc783 10704 nil
b027f415
RS
10705 (setq gnus-article-mode-map (make-keymap))
10706 (suppress-keymap gnus-article-mode-map)
10707 (define-key gnus-article-mode-map " " 'gnus-article-next-page)
10708 (define-key gnus-article-mode-map "\177" 'gnus-article-prev-page)
41487370 10709 (define-key gnus-article-mode-map "\C-c^" 'gnus-article-refer-article)
b027f415
RS
10710 (define-key gnus-article-mode-map "h" 'gnus-article-show-summary)
10711 (define-key gnus-article-mode-map "s" 'gnus-article-show-summary)
41487370 10712 (define-key gnus-article-mode-map "\C-c\C-m" 'gnus-article-mail)
b027f415 10713 (define-key gnus-article-mode-map "?" 'gnus-article-describe-briefly)
41487370
LMI
10714 (define-key gnus-article-mode-map gnus-mouse-2 'gnus-article-push-button)
10715 (define-key gnus-article-mode-map "\r" 'gnus-article-press-button)
10716 (define-key gnus-article-mode-map "\t" 'gnus-article-next-button)
10717 (define-key gnus-article-mode-map "\C-c\C-b" 'gnus-bug)
10718
10719 ;; Duplicate almost all summary keystrokes in the article mode map.
10720 (let ((commands
10721 (list
10722 "p" "N" "P" "\M-\C-n" "\M-\C-p"
10723 "\M-n" "\M-p" "." "," "\M-s" "\M-r" "<" ">" "j"
10724 "u" "!" "U" "d" "D" "E" "\M-u" "\M-U" "k" "\C-k" "\M-\C-k"
10725 "\M-\C-l" "e" "#" "\M-#" "\M-\C-t" "\M-\C-s" "\M-\C-h"
10726 "\M-\C-f" "\M-\C-b" "\M-\C-u" "\M-\C-d" "&" "\C-w"
10727 "\C-t" "?" "\C-c\M-\C-s" "\C-c\C-s\C-n" "\C-c\C-s\C-a"
10728 "\C-c\C-s\C-s" "\C-c\C-s\C-d" "\C-c\C-s\C-i" "\C-x\C-s"
10729 "\M-g" "w" "\C-c\C-r" "\M-t" "C"
10730 "o" "\C-o" "|" "\M-k" "\M-K" "V" "\C-c\C-d"
10731 "\C-c\C-i" "x" "X" "t" "g" "?" "l"
10732 "\C-c\C-v\C-v" "\C-d" "v"
10733;; "Mt" "M!" "Md" "Mr"
10734;; "Mc" "M " "Me" "Mx" "M?" "Mb" "MB" "M#" "M\M-#" "M\M-r"
10735;; "M\M-\C-r" "MD" "M\M-D" "MS" "MC" "MH" "M\C-c" "Mk" "MK"
10736;; "Ms" "Mc" "Mu" "Mm" "Mk" "Gn" "Gp" "GN" "GP" "G\C-n" "G\C-p"
10737;; "G\M-n" "G\M-p" "Gf" "Gb" "Gg" "Gl" "Gp" "Tk" "Tl" "Ti" "TT"
10738;; "Ts" "TS" "Th" "TH" "Tn" "Tp" "Tu" "Td" "T#" "A " "An" "A\177" "Ap"
10739;; "A\r" "A<" "A>" "Ab" "Ae" "A^" "Ar" "Aw" "Ac" "Ag" "At" "Am"
10740;; "As" "Wh" "Ws" "Wc" "Wo" "Ww" "Wd" "Wq" "Wf" "Wt" "W\C-t"
10741;; "WT" "WA" "Wa" "WH" "WC" "WS" "Wb" "Hv" "Hf" "Hd" "Hh" "Hi"
10742;; "Be" "B\177" "Bm" "Br" "Bw" "Bc" "Bq" "Bi" "Oo" "Om" "Or"
10743;; "Of" "Oh" "Ov" "Op" "Vu" "V\C-s" "V\C-r" "Vr" "V&" "VT" "Ve"
10744;; "VD" "Vk" "VK" "Vsn" "Vsa" "Vss" "Vsd" "Vsi"
10745 )))
b94ae5f7 10746 (while (and gnus-bugaboo commands) ; disabled
41487370
LMI
10747 (define-key gnus-article-mode-map (car commands)
10748 'gnus-article-summary-command)
10749 (setq commands (cdr commands))))
10750
10751 (let ((commands (list "q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
10752;; "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
10753 "=" "n" "^" "\M-^")))
b94ae5f7 10754 (while (and gnus-bugaboo commands) ; disabled
41487370
LMI
10755 (define-key gnus-article-mode-map (car commands)
10756 'gnus-article-summary-command-nosave)
10757 (setq commands (cdr commands)))))
10758
b027f415
RS
10759
10760(defun gnus-article-mode ()
41487370
LMI
10761 "Major mode for displaying an article.
10762
10763All normal editing commands are switched off.
10764
10765The following commands are available:
10766
10767\\<gnus-article-mode-map>
10768\\[gnus-article-next-page]\t Scroll the article one page forwards
10769\\[gnus-article-prev-page]\t Scroll the article one page backwards
10770\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
10771\\[gnus-article-show-summary]\t Display the summary buffer
10772\\[gnus-article-mail]\t Send a reply to the address near point
10773\\[gnus-article-describe-briefly]\t Describe the current mode briefly
10774\\[gnus-info-find-node]\t Go to the Gnus info node"
745bc783 10775 (interactive)
41487370 10776 (if gnus-visual (gnus-article-make-menu-bar))
745bc783 10777 (kill-all-local-variables)
a828a776 10778 (gnus-simplify-mode-line)
745bc783 10779 (setq mode-name "Article")
41487370 10780 (setq major-mode 'gnus-article-mode)
b027f415
RS
10781 (make-local-variable 'minor-mode-alist)
10782 (or (assq 'gnus-show-mime minor-mode-alist)
10783 (setq minor-mode-alist
10784 (cons (list 'gnus-show-mime " MIME") minor-mode-alist)))
b027f415 10785 (use-local-map gnus-article-mode-map)
745bc783
JB
10786 (make-local-variable 'page-delimiter)
10787 (setq page-delimiter gnus-page-delimiter)
41487370 10788 (buffer-disable-undo (current-buffer))
745bc783 10789 (setq buffer-read-only t) ;Disable modification
b027f415 10790 (run-hooks 'gnus-article-mode-hook))
745bc783 10791
b027f415 10792(defun gnus-article-setup-buffer ()
41487370
LMI
10793 "Initialize article mode buffer."
10794 ;; Returns the article buffer.
10795 (if (get-buffer gnus-article-buffer)
745bc783 10796 (save-excursion
41487370
LMI
10797 (set-buffer gnus-article-buffer)
10798 (buffer-disable-undo (current-buffer))
10799 (setq buffer-read-only t)
10800 (gnus-add-current-to-buffer-list)
10801 (or (eq major-mode 'gnus-article-mode)
10802 (gnus-article-mode))
10803 (current-buffer))
10804 (save-excursion
10805 (set-buffer (get-buffer-create gnus-article-buffer))
10806 (gnus-add-current-to-buffer-list)
10807 (gnus-article-mode)
10808 (current-buffer))))
10809
10810;; Set article window start at LINE, where LINE is the number of lines
10811;; from the head of the article.
10812(defun gnus-article-set-window-start (&optional line)
10813 (set-window-start
10814 (get-buffer-window gnus-article-buffer)
10815 (save-excursion
10816 (set-buffer gnus-article-buffer)
10817 (goto-char (point-min))
10818 (if (not line)
10819 (point-min)
10820 (gnus-message 6 "Moved to bookmark")
10821 (search-forward "\n\n" nil t)
10822 (forward-line line)
10823 (point)))))
10824
10825(defun gnus-request-article-this-buffer (article group)
10826 "Get an article and insert it into this buffer."
10827 (setq group (or group gnus-newsgroup-name))
10828
10829 ;; Open server if it has closed.
10830 (gnus-check-server (gnus-find-method-for-group group))
10831
10832 ;; Using `gnus-request-article' directly will insert the article into
10833 ;; `nntp-server-buffer' - so we'll save some time by not having to
10834 ;; copy it from the server buffer into the article buffer.
10835
10836 ;; We only request an article by message-id when we do not have the
10837 ;; headers for it, so we'll have to get those.
10838 (and (stringp article)
10839 (let ((gnus-override-method gnus-refer-article-method))
10840 (gnus-read-header article)))
10841
10842 ;; If the article number is negative, that means that this article
10843 ;; doesn't belong in this newsgroup (possibly), so we find its
10844 ;; message-id and request it by id instead of number.
10845 (if (not (numberp article))
10846 ()
10847 (save-excursion
10848 (set-buffer gnus-summary-buffer)
10849 (let ((header (gnus-get-header-by-num article)))
10850 (if (< article 0)
10851 (if (vectorp header)
10852 ;; It's a real article.
10853 (setq article (mail-header-id header))
10854 ;; It is an extracted pseudo-article.
10855 (setq article 'pseudo)
10856 (gnus-request-pseudo-article header)))
10857
10858 (let ((method (gnus-find-method-for-group gnus-newsgroup-name)))
10859 (if (not (eq (car method) 'nneething))
10860 ()
10861 (let ((dir (concat (file-name-as-directory (nth 1 method))
10862 (mail-header-subject header))))
10863 (if (file-directory-p dir)
10864 (progn
10865 (setq article 'nneething)
10866 (gnus-group-enter-directory dir)))))))))
10867
10868 ;; Check the cache.
10869 (if (and gnus-use-cache
10870 (numberp article)
10871 (gnus-cache-request-article article group))
10872 'article
10873 ;; Get the article and put into the article buffer.
10874 (if (or (stringp article) (numberp article))
10875 (progn
10876 (erase-buffer)
10877 ;; There may be some overlays that we have to kill...
10878 (insert "i")
7e988fb6
LMI
10879 (let ((overlays (and (fboundp 'overlays-at)
10880 (overlays-at (point-min)))))
41487370
LMI
10881 (while overlays
10882 (delete-overlay (car overlays))
10883 (setq overlays (cdr overlays))))
10884 (erase-buffer)
10885 (let ((gnus-override-method
10886 (and (stringp article) gnus-refer-article-method)))
10887 (and (gnus-request-article article group (current-buffer))
10888 'article)))
10889 article)))
10890
10891(defun gnus-read-header (id)
10892 "Read the headers of article ID and enter them into the Gnus system."
10893 (let (header)
10894 (if (not (setq header
10895 (car (if (let ((gnus-nov-is-evil t))
10896 (gnus-retrieve-headers
10897 (list id) gnus-newsgroup-name))
10898 (gnus-get-newsgroup-headers)))))
10899 nil
10900 (if (stringp id)
10901 (mail-header-set-number header gnus-reffed-article-number))
10902 (setq gnus-newsgroup-headers (cons header gnus-newsgroup-headers))
10903 (gnus-sethash (int-to-string (mail-header-number header)) header
10904 gnus-newsgroup-headers-hashtb-by-number)
10905 (if (stringp id)
10906 (setq gnus-reffed-article-number (1- gnus-reffed-article-number)))
10907 (setq gnus-current-headers header)
10908 header)))
10909
10910(defun gnus-article-prepare (article &optional all-headers header)
10911 "Prepare ARTICLE in article mode buffer.
10912ARTICLE should either be an article number or a Message-ID.
10913If ARTICLE is an id, HEADER should be the article headers.
10914If ALL-HEADERS is non-nil, no headers are hidden."
745bc783 10915 (save-excursion
41487370
LMI
10916 ;; Make sure we start in a summary buffer.
10917 (or (eq major-mode 'gnus-summary-mode)
10918 (set-buffer gnus-summary-buffer))
10919 (setq gnus-summary-buffer (current-buffer))
10920 ;; Make sure the connection to the server is alive.
10921 (or (gnus-server-opened (gnus-find-method-for-group gnus-newsgroup-name))
10922 (progn
10923 (gnus-check-server
10924 (gnus-find-method-for-group gnus-newsgroup-name))
10925 (gnus-request-group gnus-newsgroup-name t)))
10926 (let* ((article (if header (mail-header-number header) article))
10927 (summary-buffer (current-buffer))
10928 (internal-hook gnus-article-internal-prepare-hook)
10929 (group gnus-newsgroup-name)
10930 result)
10931 (save-excursion
10932 (gnus-article-setup-buffer)
10933 (set-buffer gnus-article-buffer)
10934 (if (not (setq result (let ((buffer-read-only nil))
10935 (gnus-request-article-this-buffer
10936 article group))))
10937 ;; There is no such article.
10938 (save-excursion
10939 (if (not (numberp article))
10940 ()
10941 (setq gnus-article-current
10942 (cons gnus-newsgroup-name article))
10943 (set-buffer gnus-summary-buffer)
10944 (setq gnus-current-article article)
10945 (gnus-summary-mark-article article gnus-canceled-mark))
10946 (gnus-message 1 "No such article (may be canceled)")
10947 (ding)
10948 nil)
10949 (if (or (eq result 'pseudo) (eq result 'nneething))
10950 (progn
10951 (save-excursion
10952 (set-buffer summary-buffer)
10953 (setq gnus-last-article gnus-current-article
10954 gnus-newsgroup-history (cons gnus-current-article
10955 gnus-newsgroup-history)
10956 gnus-current-article 0
10957 gnus-current-headers nil
10958 gnus-article-current nil)
10959 (if (eq result 'nneething)
10960 (gnus-configure-windows 'summary)
10961 (gnus-configure-windows 'article))
10962 (gnus-set-global-variables))
10963 (gnus-set-mode-line 'article))
10964 ;; The result from the `request' was an actual article -
10965 ;; or at least some text that is now displayed in the
10966 ;; article buffer.
745bc783
JB
10967 (if (and (numberp article)
10968 (not (eq article gnus-current-article)))
41487370
LMI
10969 ;; Seems like a new article has been selected.
10970 ;; `gnus-current-article' must be an article number.
10971 (save-excursion
10972 (set-buffer summary-buffer)
10973 (setq gnus-last-article gnus-current-article
10974 gnus-newsgroup-history (cons gnus-current-article
10975 gnus-newsgroup-history)
10976 gnus-current-article article
10977 gnus-current-headers
10978 (gnus-get-header-by-num gnus-current-article)
10979 gnus-article-current
10980 (cons gnus-newsgroup-name gnus-current-article))
10981 (gnus-summary-show-thread)
b027f415 10982 (run-hooks 'gnus-mark-article-hook)
41487370
LMI
10983 (gnus-set-mode-line 'summary)
10984 (and gnus-visual
10985 (run-hooks 'gnus-visual-mark-article-hook))
10986 ;; Set the global newsgroup variables here.
10987 ;; Suggested by Jim Sisolak
10988 ;; <sisolak@trans4.neep.wisc.edu>.
10989 (gnus-set-global-variables)
10990 (setq gnus-have-all-headers
10991 (or all-headers gnus-show-all-headers))
10992 (and gnus-use-cache
10993 (vectorp (gnus-get-header-by-number article))
10994 (gnus-cache-possibly-enter-article
10995 group article
10996 (gnus-get-header-by-number article)
10997 (memq article gnus-newsgroup-marked)
10998 (memq article gnus-newsgroup-dormant)
10999 (memq article gnus-newsgroup-unreads)))))
11000 ;; Hooks for getting information from the article.
11001 ;; This hook must be called before being narrowed.
11002 (let (buffer-read-only)
11003 (run-hooks 'internal-hook)
11004 (run-hooks 'gnus-article-prepare-hook)
11005 ;; Decode MIME message.
11006 (if (and gnus-show-mime
11007 (or (not gnus-strict-mime)
11008 (gnus-fetch-field "Mime-Version")))
11009 (funcall gnus-show-mime-method))
11010 ;; Perform the article display hooks.
11011 (run-hooks 'gnus-article-display-hook))
745bc783
JB
11012 ;; Do page break.
11013 (goto-char (point-min))
41487370
LMI
11014 (and gnus-break-pages (gnus-narrow-to-page))
11015 (gnus-set-mode-line 'article)
11016 (gnus-configure-windows 'article)
11017 (goto-char (point-min))
11018 t))))))
745bc783 11019
b027f415 11020(defun gnus-article-show-all-headers ()
41487370
LMI
11021 "Show all article headers in article mode buffer."
11022 (save-excursion
11023 (gnus-article-setup-buffer)
11024 (set-buffer gnus-article-buffer)
11025 (let ((buffer-read-only nil))
11026 (remove-text-properties (point-min) (point-max)
11027 gnus-hidden-properties))))
745bc783 11028
41487370
LMI
11029(defun gnus-article-hide-headers-if-wanted ()
11030 "Hide unwanted headers if `gnus-have-all-headers' is nil.
b94ae5f7 11031Provided for backwards compatibility."
41487370
LMI
11032 (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)
11033 (gnus-article-hide-headers)))
745bc783 11034
41487370
LMI
11035(defun gnus-article-hide-headers (&optional delete)
11036 "Hide unwanted headers and possibly sort them as well."
745bc783 11037 (interactive "P")
41487370
LMI
11038 (save-excursion
11039 (set-buffer gnus-article-buffer)
11040 (save-restriction
11041 (let ((sorted gnus-sorted-header-list)
11042 (buffer-read-only nil)
11043 want-list beg want-l)
11044 ;; First we narrow to just the headers.
11045 (widen)
11046 (goto-char (point-min))
11047 ;; Hide any "From " lines at the beginning of (mail) articles.
11048 (while (looking-at "From ")
11049 (forward-line 1))
11050 (or (bobp)
11051 (add-text-properties (point-min) (point) gnus-hidden-properties))
11052 ;; Then treat the rest of the header lines.
11053 (narrow-to-region
11054 (point)
11055 (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
11056 ;; Then we use the two regular expressions
11057 ;; `gnus-ignored-headers' and `gnus-visible-headers' to
11058 ;; select which header lines is to remain visible in the
11059 ;; article buffer.
11060 (goto-char (point-min))
11061 (while (re-search-forward "^[^ \t]*:" nil t)
11062 (beginning-of-line)
11063 ;; We add the headers we want to keep to a list and delete
11064 ;; them from the buffer.
11065 (if (or (and (stringp gnus-visible-headers)
11066 (looking-at gnus-visible-headers))
11067 (and (not (stringp gnus-visible-headers))
11068 (stringp gnus-ignored-headers)
11069 (not (looking-at gnus-ignored-headers))))
11070 (progn
11071 (setq beg (point))
11072 (forward-line 1)
11073 ;; Be sure to get multi-line headers...
11074 (re-search-forward "^[^ \t]*:" nil t)
11075 (beginning-of-line)
11076 (setq want-list
11077 (cons (buffer-substring beg (point)) want-list))
11078 (delete-region beg (point))
11079 (goto-char beg))
11080 (forward-line 1)))
11081 ;; Next we perform the sorting by looking at
11082 ;; `gnus-sorted-header-list'.
11083 (goto-char (point-min))
11084 (while (and sorted want-list)
11085 (setq want-l want-list)
11086 (while (and want-l
11087 (not (string-match (car sorted) (car want-l))))
11088 (setq want-l (cdr want-l)))
11089 (if want-l
11090 (progn
11091 (insert (car want-l))
11092 (setq want-list (delq (car want-l) want-list))))
11093 (setq sorted (cdr sorted)))
11094 ;; Any headers that were not matched by the sorted list we
11095 ;; just tack on the end of the visible header list.
11096 (while want-list
11097 (insert (car want-list))
11098 (setq want-list (cdr want-list)))
11099 ;; And finally we make the unwanted headers invisible.
11100 (if delete
11101 (delete-region (point) (point-max))
11102 ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
11103 (add-text-properties (point) (point-max) gnus-hidden-properties))))))
11104
11105;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
11106(defun gnus-article-treat-overstrike ()
11107 "Translate overstrikes into bold text."
745bc783 11108 (interactive)
41487370
LMI
11109 (save-excursion
11110 (set-buffer gnus-article-buffer)
11111 (let ((buffer-read-only nil))
11112 (while (search-forward "\b" nil t)
11113 (let ((next (following-char))
11114 (previous (char-after (- (point) 2))))
11115 (cond ((eq next previous)
11116 (put-text-property (- (point) 2) (point)
11117 'invisible t)
11118 (put-text-property (point) (1+ (point))
11119 'face 'bold))
11120 ((eq next ?_)
11121 (put-text-property (1- (point)) (1+ (point))
11122 'invisible t)
11123 (put-text-property (1- (point)) (point)
11124 'face 'underline))
11125 ((eq previous ?_)
11126 (put-text-property (- (point) 2) (point)
11127 'invisible t)
11128 (put-text-property (point) (1+ (point))
11129 'face 'underline))))))))
11130
11131(defun gnus-article-word-wrap ()
11132 "Format too long lines."
745bc783 11133 (interactive)
41487370
LMI
11134 (save-excursion
11135 (set-buffer gnus-article-buffer)
11136 (let ((buffer-read-only nil))
11137 (goto-char (point-min))
11138 (search-forward "\n\n" nil t)
11139 (end-of-line 1)
11140 (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
11141 (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
11142 (adaptive-fill-mode t))
11143 (while (not (eobp))
11144 (and (>= (current-column) (min fill-column (window-width)))
11145 (/= (preceding-char) ?:)
11146 (fill-paragraph nil))
11147 (end-of-line 2))))))
11148
11149(defun gnus-article-remove-cr ()
11150 "Remove carriage returns from an article."
745bc783 11151 (interactive)
41487370
LMI
11152 (save-excursion
11153 (set-buffer gnus-article-buffer)
11154 (let ((buffer-read-only nil))
11155 (goto-char (point-min))
11156 (while (search-forward "\r" nil t)
11157 (replace-match "" t t)))))
745bc783 11158
41487370
LMI
11159(defun gnus-article-display-x-face (&optional force)
11160 "Look for an X-Face header and display it if present."
11161 (interactive (list 'force))
11162 (save-excursion
11163 (set-buffer gnus-article-buffer)
11164 (let ((inhibit-point-motion-hooks t)
11165 (case-fold-search nil)
11166 from)
11167 (save-restriction
11168 (goto-char (point-min))
11169 (search-forward "\n\n")
11170 (narrow-to-region (point-min) (point))
11171 (goto-char (point-min))
11172 (setq from (mail-fetch-field "from"))
11173 (if (not (and gnus-article-x-face-command
11174 (or force
11175 (not gnus-article-x-face-too-ugly)
11176 (and gnus-article-x-face-too-ugly from
11177 (not (string-match gnus-article-x-face-too-ugly
11178 from))))
11179 (progn
11180 (goto-char (point-min))
11181 (re-search-forward "^X-Face: " nil t))))
11182 nil
11183 (let ((beg (point))
11184 (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
11185 (if (symbolp gnus-article-x-face-command)
11186 (and (or (fboundp gnus-article-x-face-command)
11187 (error "%s is not a function"
11188 gnus-article-x-face-command))
11189 (funcall gnus-article-x-face-command beg end))
11190 (call-process-region beg end "sh" nil 0 nil
11191 "-c" gnus-article-x-face-command))))))))
11192
11193(defun gnus-article-de-quoted-unreadable (&optional force)
11194 "Do a naive translation of a quoted-printable-encoded article.
11195This is in no way, shape or form meant as a replacement for real MIME
11196processing, but is simply a stop-gap measure until MIME support is
11197written.
11198If FORCE, decode the article whether it is marked as quoted-printable
11199or not."
11200 (interactive (list 'force))
11201 (save-excursion
11202 (set-buffer gnus-article-buffer)
11203 (let ((case-fold-search t)
11204 (buffer-read-only nil)
11205 (type (gnus-fetch-field "content-transfer-encoding")))
11206 (if (or force (and type (string-match "quoted-printable" type)))
11207 (progn
11208 (goto-char (point-min))
11209 (search-forward "\n\n" nil 'move)
11210 (gnus-mime-decode-quoted-printable (point) (point-max)))))))
745bc783 11211
41487370
LMI
11212(defun gnus-mime-decode-quoted-printable (from to)
11213 ;; Decode quoted-printable from region between FROM and TO.
11214 (save-excursion
11215 (goto-char from)
11216 (while (search-forward "=" to t)
11217 (cond ((eq (following-char) ?\n)
11218 (delete-char -1)
11219 (delete-char 1))
11220 ((looking-at "[0-9A-F][0-9A-F]")
11221 (delete-char -1)
11222 (insert (hexl-hex-string-to-integer
11223 (buffer-substring (point) (+ 2 (point)))))
11224 (delete-char 2))
11225 ((looking-at "=")
11226 (delete-char 1))
11227 ((gnus-message 3 "Malformed MIME quoted-printable message"))))))
11228
11229(defvar gnus-article-time-units
11230 (list (cons 'year (* 365.25 24 60 60))
11231 (cons 'week (* 7 24 60 60))
11232 (cons 'day (* 24 60 60))
11233 (cons 'hour (* 60 60))
11234 (cons 'minute 60)
11235 (cons 'second 1)))
11236
11237(defun gnus-article-date-ut (&optional type)
11238 "Convert DATE date to universal time in the current article.
11239If TYPE is `local', convert to local time; if it is `lapsed', output
11240how much time has lapsed since DATE."
11241 (interactive (list 'ut))
11242 (let ((date (mail-header-date (or gnus-current-headers
11243 (gnus-get-header-by-number
11244 (gnus-summary-article-number))"")))
11245 (date-regexp "^Date: \\|^X-Sent: "))
11246 (if (or (not date)
11247 (string= date ""))
11248 ()
11249 (save-excursion
11250 (set-buffer gnus-article-buffer)
11251 (let ((buffer-read-only nil))
11252 (goto-char (point-min))
11253 (if (and (re-search-forward date-regexp nil t)
11254 (progn
11255 (beginning-of-line)
11256 (looking-at date-regexp)))
11257 (delete-region (gnus-point-at-bol)
11258 (progn (end-of-line) (1+ (point))))
11259 (goto-char (point-min))
11260 (goto-char (- (search-forward "\n\n") 2)))
11261 (insert
11262 (cond
11263 ((eq type 'local)
11264 (concat "Date: " (condition-case ()
11265 (timezone-make-date-arpa-standard date)
11266 (error date))
11267 "\n"))
11268 ((eq type 'ut)
11269 (concat "Date: "
11270 (condition-case ()
11271 (timezone-make-date-arpa-standard date nil "UT")
11272 (error date))
11273 "\n"))
11274 ((eq type 'lapsed)
11275 ;; If the date is seriously mangled, the timezone
11276 ;; functions are liable to bug out, so we condition-case
11277 ;; the entire thing.
11278 (let* ((real-sec (condition-case ()
11279 (- (gnus-seconds-since-epoch
11280 (timezone-make-date-arpa-standard
11281 (current-time-string)
11282 (current-time-zone) "UT"))
11283 (gnus-seconds-since-epoch
11284 (timezone-make-date-arpa-standard
11285 date nil "UT")))
11286 (error 0)))
11287 (sec (abs real-sec))
11288 num prev)
11289 (if (zerop sec)
11290 "X-Sent: Now\n"
11291 (concat
11292 "X-Sent: "
11293 (mapconcat
11294 (lambda (unit)
11295 (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
11296 ""
11297 (setq sec (- sec (* num (cdr unit))))
11298 (prog1
11299 (concat (if prev ", " "") (int-to-string
11300 (floor num))
11301 " " (symbol-name (car unit))
11302 (if (> num 1) "s" ""))
11303 (setq prev t))))
11304 gnus-article-time-units "")
11305 (if (> real-sec 0)
11306 " ago\n"
11307 " in the future\n")))))
11308 (t
11309 (error "Unknown conversion type: %s" type)))))))))
745bc783 11310
41487370
LMI
11311(defun gnus-article-date-local ()
11312 "Convert the current article date to the local timezone."
745bc783 11313 (interactive)
41487370 11314 (gnus-article-date-ut 'local))
745bc783 11315
41487370
LMI
11316(defun gnus-article-date-lapsed ()
11317 "Convert the current article date to time lapsed since it was sent."
745bc783 11318 (interactive)
41487370 11319 (gnus-article-date-ut 'lapsed))
745bc783 11320
41487370
LMI
11321(defun gnus-article-maybe-highlight ()
11322 "Do some article highlighting if `gnus-visual' is non-nil."
11323 (if gnus-visual (gnus-article-highlight-some)))
745bc783 11324
41487370 11325;; Article savers.
745bc783
JB
11326
11327(defun gnus-output-to-rmail (file-name)
11328 "Append the current article to an Rmail file named FILE-NAME."
11329 (require 'rmail)
11330 ;; Most of these codes are borrowed from rmailout.el.
11331 (setq file-name (expand-file-name file-name))
f670fcba 11332 (setq rmail-default-rmail-file file-name)
745bc783 11333 (let ((artbuf (current-buffer))
41487370 11334 (tmpbuf (get-buffer-create " *Gnus-output*")))
745bc783
JB
11335 (save-excursion
11336 (or (get-file-buffer file-name)
11337 (file-exists-p file-name)
41487370 11338 (if (gnus-yes-or-no-p
745bc783
JB
11339 (concat "\"" file-name "\" does not exist, create it? "))
11340 (let ((file-buffer (create-file-buffer file-name)))
11341 (save-excursion
11342 (set-buffer file-buffer)
11343 (rmail-insert-rmail-file-header)
11344 (let ((require-final-newline nil))
11345 (write-region (point-min) (point-max) file-name t 1)))
11346 (kill-buffer file-buffer))
11347 (error "Output file does not exist")))
11348 (set-buffer tmpbuf)
41487370 11349 (buffer-disable-undo (current-buffer))
745bc783
JB
11350 (erase-buffer)
11351 (insert-buffer-substring artbuf)
11352 (gnus-convert-article-to-rmail)
11353 ;; Decide whether to append to a file or to an Emacs buffer.
11354 (let ((outbuf (get-file-buffer file-name)))
11355 (if (not outbuf)
11356 (append-to-file (point-min) (point-max) file-name)
11357 ;; File has been visited, in buffer OUTBUF.
11358 (set-buffer outbuf)
11359 (let ((buffer-read-only nil)
11360 (msg (and (boundp 'rmail-current-message)
41487370 11361 (symbol-value 'rmail-current-message))))
745bc783
JB
11362 ;; If MSG is non-nil, buffer is in RMAIL mode.
11363 (if msg
11364 (progn (widen)
11365 (narrow-to-region (point-max) (point-max))))
11366 (insert-buffer-substring tmpbuf)
11367 (if msg
11368 (progn
11369 (goto-char (point-min))
11370 (widen)
11371 (search-backward "\^_")
11372 (narrow-to-region (point) (point-max))
11373 (goto-char (1+ (point-min)))
11374 (rmail-count-new-messages t)
41487370
LMI
11375 (rmail-show-message msg)))))))
11376 (kill-buffer tmpbuf)))
745bc783
JB
11377
11378(defun gnus-output-to-file (file-name)
11379 "Append the current article to a file named FILE-NAME."
11380 (setq file-name (expand-file-name file-name))
11381 (let ((artbuf (current-buffer))
41487370 11382 (tmpbuf (get-buffer-create " *Gnus-output*")))
745bc783
JB
11383 (save-excursion
11384 (set-buffer tmpbuf)
41487370 11385 (buffer-disable-undo (current-buffer))
745bc783
JB
11386 (erase-buffer)
11387 (insert-buffer-substring artbuf)
11388 ;; Append newline at end of the buffer as separator, and then
11389 ;; save it to file.
11390 (goto-char (point-max))
11391 (insert "\n")
11392 (append-to-file (point-min) (point-max) file-name))
41487370 11393 (kill-buffer tmpbuf)))
745bc783
JB
11394
11395(defun gnus-convert-article-to-rmail ()
11396 "Convert article in current buffer to Rmail message format."
11397 (let ((buffer-read-only nil))
11398 ;; Convert article directly into Babyl format.
11399 ;; Suggested by Rob Austein <sra@lcs.mit.edu>
11400 (goto-char (point-min))
11401 (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
11402 (while (search-forward "\n\^_" nil t) ;single char
41487370 11403 (replace-match "\n^_" t t)) ;2 chars: "^" and "_"
745bc783
JB
11404 (goto-char (point-max))
11405 (insert "\^_")))
11406
41487370
LMI
11407(defun gnus-narrow-to-page (&optional arg)
11408 "Make text outside current page invisible except for page delimiter.
11409A numeric arg specifies to move forward or backward by that many pages,
11410thus showing a page other than the one point was originally in."
11411 (interactive "P")
11412 (setq arg (if arg (prefix-numeric-value arg) 0))
11413 (save-excursion
11414 (forward-page -1) ;Beginning of current page.
11415 (widen)
11416 (if (> arg 0)
11417 (forward-page arg)
11418 (if (< arg 0)
11419 (forward-page (1- arg))))
11420 ;; Find the end of the page.
11421 (forward-page)
11422 ;; If we stopped due to end of buffer, stay there.
11423 ;; If we stopped after a page delimiter, put end of restriction
11424 ;; at the beginning of that line.
11425 ;; These are commented out.
11426 ;; (if (save-excursion (beginning-of-line)
11427 ;; (looking-at page-delimiter))
11428 ;; (beginning-of-line))
11429 (narrow-to-region (point)
11430 (progn
11431 ;; Find the top of the page.
11432 (forward-page -1)
11433 ;; If we found beginning of buffer, stay there.
11434 ;; If extra text follows page delimiter on same line,
11435 ;; include it.
11436 ;; Otherwise, show text starting with following line.
11437 (if (and (eolp) (not (bobp)))
11438 (forward-line 1))
11439 (point)))))
745bc783 11440
41487370
LMI
11441(defun gnus-gmt-to-local ()
11442 "Rewrite Date header described in GMT to local in current buffer.
11443Intended to be used with gnus-article-prepare-hook."
11444 (save-excursion
11445 (save-restriction
11446 (widen)
11447 (goto-char (point-min))
11448 (narrow-to-region (point-min)
11449 (progn (search-forward "\n\n" nil 'move) (point)))
11450 (goto-char (point-min))
11451 (if (re-search-forward "^Date:[ \t]\\(.*\\)$" nil t)
11452 (let ((buffer-read-only nil)
11453 (date (buffer-substring-no-properties
11454 (match-beginning 1) (match-end 1))))
11455 (delete-region (match-beginning 1) (match-end 1))
11456 (insert
11457 (timezone-make-date-arpa-standard
11458 date nil (current-time-zone))))))))
745bc783 11459
745bc783 11460
41487370 11461;; Article mode commands
745bc783 11462
41487370
LMI
11463(defun gnus-article-next-page (&optional lines)
11464 "Show next page of current article.
11465If end of article, return non-nil. Otherwise return nil.
11466Argument LINES specifies lines to be scrolled up."
11467 (interactive "P")
11468 (move-to-window-line -1)
11469 ;; Fixed by enami@ptgd.sony.co.jp (enami tsugutomo)
11470 (if (save-excursion
11471 (end-of-line)
11472 (and (pos-visible-in-window-p) ;Not continuation line.
11473 (eobp)))
11474 ;; Nothing in this page.
11475 (if (or (not gnus-break-pages)
11476 (save-excursion
11477 (save-restriction
11478 (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
11479 t ;Nothing more.
11480 (gnus-narrow-to-page 1) ;Go to next page.
11481 nil)
11482 ;; More in this page.
11483 (condition-case ()
11484 (scroll-up lines)
11485 (end-of-buffer
11486 ;; Long lines may cause an end-of-buffer error.
11487 (goto-char (point-max))))
11488 nil))
b027f415 11489
41487370
LMI
11490(defun gnus-article-prev-page (&optional lines)
11491 "Show previous page of current article.
11492Argument LINES specifies lines to be scrolled down."
11493 (interactive "P")
11494 (move-to-window-line 0)
11495 (if (and gnus-break-pages
11496 (bobp)
11497 (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
11498 (progn
11499 (gnus-narrow-to-page -1) ;Go to previous page.
11500 (goto-char (point-max))
11501 (recenter -1))
11502 (scroll-down lines)))
745bc783 11503
41487370
LMI
11504(defun gnus-article-refer-article ()
11505 "Read article specified by message-id around point."
11506 (interactive)
11507 (search-forward ">" nil t) ;Move point to end of "<....>".
11508 (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
11509 (let ((message-id
11510 (buffer-substring (match-beginning 1) (match-end 1))))
11511 (set-buffer gnus-summary-buffer)
11512 (gnus-summary-refer-article message-id))
11513 (error "No references around point")))
745bc783 11514
41487370
LMI
11515(defun gnus-article-show-summary ()
11516 "Reconfigure windows to show summary buffer."
11517 (interactive)
11518 (gnus-configure-windows 'article)
11519 (gnus-summary-goto-subject gnus-current-article))
745bc783 11520
41487370
LMI
11521(defun gnus-article-describe-briefly ()
11522 "Describe article mode commands briefly."
745bc783 11523 (interactive)
41487370
LMI
11524 (gnus-message 6
11525 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-next-page]:Next page \\[gnus-article-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
745bc783 11526
41487370
LMI
11527(defun gnus-article-summary-command ()
11528 "Execute the last keystroke in the summary buffer."
745bc783 11529 (interactive)
41487370
LMI
11530 (let ((obuf (current-buffer))
11531 (owin (current-window-configuration))
11532 func)
11533 (switch-to-buffer gnus-summary-buffer 'norecord)
11534 (setq func (lookup-key (current-local-map) (this-command-keys)))
11535 (call-interactively func)
11536 (set-buffer obuf)
11537 (set-window-configuration owin)
11538 (set-window-point (get-buffer-window (current-buffer)) (point))))
11539
11540(defun gnus-article-summary-command-nosave ()
11541 "Execute the last keystroke in the summary buffer."
11542 (interactive)
11543 (let (func)
11544 (pop-to-buffer gnus-summary-buffer 'norecord)
11545 (setq func (lookup-key (current-local-map) (this-command-keys)))
11546 (call-interactively func)))
745bc783 11547
41487370
LMI
11548\f
11549;; Basic ideas by emv@math.lsa.umich.edu (Edward Vielmetti)
11550
11551;;;###autoload
11552(defalias 'gnus-batch-kill 'gnus-batch-score)
11553;;;###autoload
11554(defun gnus-batch-score ()
11555 "Run batched scoring.
11556Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ...
11557Newsgroups is a list of strings in Bnews format. If you want to score
11558the comp hierarchy, you'd say \"comp.all\". If you would not like to
11559score the alt hierarchy, you'd say \"!alt.all\"."
11560 (interactive)
11561 (let* ((yes-and-no
11562 (gnus-newsrc-parse-options
11563 (apply (function concat)
11564 (mapcar (lambda (g) (concat g " "))
11565 command-line-args-left))))
11566 (gnus-expert-user t)
11567 (nnmail-spool-file nil)
11568 (gnus-use-dribble-file nil)
11569 (yes (car yes-and-no))
11570 (no (cdr yes-and-no))
11571 group newsrc entry
11572 ;; Disable verbose message.
11573 gnus-novice-user gnus-large-newsgroup)
11574 ;; Eat all arguments.
11575 (setq command-line-args-left nil)
11576 ;; Start Gnus.
11577 (gnus)
11578 ;; Apply kills to specified newsgroups in command line arguments.
11579 (setq newsrc (cdr gnus-newsrc-alist))
11580 (while newsrc
11581 (setq group (car (car newsrc)))
11582 (setq entry (gnus-gethash group gnus-newsrc-hashtb))
11583 (if (and (<= (nth 1 (car newsrc)) gnus-level-subscribed)
11584 (and (car entry)
11585 (or (eq (car entry) t)
11586 (not (zerop (car entry)))))
11587 (if yes (string-match yes group) t)
11588 (or (null no) (not (string-match no group))))
745bc783 11589 (progn
41487370
LMI
11590 (gnus-summary-read-group group nil t)
11591 (and (eq (current-buffer) (get-buffer gnus-summary-buffer))
11592 (gnus-summary-exit))))
11593 (setq newsrc (cdr newsrc)))
11594 ;; Exit Emacs.
11595 (switch-to-buffer gnus-group-buffer)
11596 (gnus-group-save-newsrc)))
745bc783 11597
41487370
LMI
11598(defun gnus-apply-kill-file ()
11599 "Apply a kill file to the current newsgroup.
11600Returns the number of articles marked as read."
11601 (if (or (file-exists-p (gnus-newsgroup-kill-file nil))
11602 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
11603 (gnus-apply-kill-file-internal)
11604 0))
11605
11606(defun gnus-kill-save-kill-buffer ()
745bc783 11607 (save-excursion
41487370
LMI
11608 (let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name)))
11609 (if (get-file-buffer file)
11610 (progn
11611 (set-buffer (get-file-buffer file))
11612 (and (buffer-modified-p) (save-buffer))
11613 (kill-buffer (current-buffer)))))))
745bc783 11614
41487370
LMI
11615(defvar gnus-kill-file-name "KILL"
11616 "Suffix of the kill files.")
b027f415 11617
41487370
LMI
11618(defun gnus-newsgroup-kill-file (newsgroup)
11619 "Return the name of a kill file name for NEWSGROUP.
11620If NEWSGROUP is nil, return the global kill file name instead."
11621 (cond ((or (null newsgroup)
11622 (string-equal newsgroup ""))
11623 ;; The global KILL file is placed at top of the directory.
11624 (expand-file-name gnus-kill-file-name
11625 (or gnus-kill-files-directory "~/News")))
11626 ((gnus-use-long-file-name 'not-kill)
11627 ;; Append ".KILL" to newsgroup name.
b94ae5f7 11628 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
41487370
LMI
11629 "." gnus-kill-file-name)
11630 (or gnus-kill-files-directory "~/News")))
11631 (t
11632 ;; Place "KILL" under the hierarchical directory.
11633 (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
11634 "/" gnus-kill-file-name)
11635 (or gnus-kill-files-directory "~/News")))))
b027f415 11636
41487370
LMI
11637\f
11638;;;
11639;;; Dribble file
11640;;;
745bc783 11641
41487370
LMI
11642(defvar gnus-dribble-ignore nil)
11643(defvar gnus-dribble-eval-file nil)
11644
11645(defun gnus-dribble-file-name ()
11646 (concat gnus-current-startup-file "-dribble"))
11647
11648(defun gnus-dribble-enter (string)
11649 (if (and (not gnus-dribble-ignore)
11650 gnus-dribble-buffer
11651 (buffer-name gnus-dribble-buffer))
11652 (let ((obuf (current-buffer)))
11653 (set-buffer gnus-dribble-buffer)
11654 (insert string "\n")
11655 (set-window-point (get-buffer-window (current-buffer)) (point-max))
11656 (set-buffer obuf))))
11657
11658(defun gnus-dribble-read-file ()
11659 (let ((dribble-file (gnus-dribble-file-name)))
11660 (save-excursion
11661 (set-buffer (setq gnus-dribble-buffer
11662 (get-buffer-create
11663 (file-name-nondirectory dribble-file))))
11664 (gnus-add-current-to-buffer-list)
11665 (erase-buffer)
11666 (set-visited-file-name dribble-file)
11667 (buffer-disable-undo (current-buffer))
11668 (bury-buffer (current-buffer))
11669 (set-buffer-modified-p nil)
11670 (let ((auto (make-auto-save-file-name))
11671 (gnus-dribble-ignore t))
11672 (if (or (file-exists-p auto) (file-exists-p dribble-file))
11673 (progn
11674 (if (file-newer-than-file-p auto dribble-file)
11675 (setq dribble-file auto))
11676 (insert-file-contents dribble-file)
11677 (if (not (zerop (buffer-size)))
11678 (set-buffer-modified-p t))
11679 (if (gnus-y-or-n-p
11680 "Auto-save file exists. Do you want to read it? ")
11681 (setq gnus-dribble-eval-file t))))))))
11682
11683(defun gnus-dribble-eval-file ()
11684 (if (not gnus-dribble-eval-file)
11685 ()
11686 (setq gnus-dribble-eval-file nil)
11687 (save-excursion
11688 (let ((gnus-dribble-ignore t))
11689 (set-buffer gnus-dribble-buffer)
11690 (eval-buffer (current-buffer))))))
11691
11692(defun gnus-dribble-delete-file ()
11693 (if (file-exists-p (gnus-dribble-file-name))
11694 (delete-file (gnus-dribble-file-name)))
11695 (if gnus-dribble-buffer
11696 (save-excursion
11697 (set-buffer gnus-dribble-buffer)
11698 (let ((auto (make-auto-save-file-name)))
11699 (if (file-exists-p auto)
11700 (delete-file auto))
11701 (erase-buffer)
11702 (set-buffer-modified-p nil)))))
11703
11704(defun gnus-dribble-save ()
11705 (if (and gnus-dribble-buffer
11706 (buffer-name gnus-dribble-buffer))
11707 (save-excursion
11708 (set-buffer gnus-dribble-buffer)
11709 (save-buffer))))
745bc783 11710
41487370
LMI
11711(defun gnus-dribble-clear ()
11712 (save-excursion
11713 (if (gnus-buffer-exists-p gnus-dribble-buffer)
11714 (progn
11715 (set-buffer gnus-dribble-buffer)
11716 (erase-buffer)
11717 (set-buffer-modified-p nil)
11718 (setq buffer-saved-size (buffer-size))))))
745bc783 11719
745bc783 11720;;;
41487370 11721;;; Server Communication
745bc783
JB
11722;;;
11723
41487370
LMI
11724(defun gnus-start-news-server (&optional confirm)
11725 "Open a method for getting news.
11726If CONFIRM is non-nil, the user will be asked for an NNTP server."
11727 (let (how)
11728 (if gnus-current-select-method
11729 ;; Stream is already opened.
11730 nil
11731 ;; Open NNTP server.
11732 (if (null gnus-nntp-service) (setq gnus-nntp-server nil))
11733 (if confirm
11734 (progn
11735 ;; Read server name with completion.
11736 (setq gnus-nntp-server
11737 (completing-read "NNTP server: "
11738 (mapcar (lambda (server) (list server))
11739 (cons (list gnus-nntp-server)
11740 gnus-secondary-servers))
11741 nil nil gnus-nntp-server))))
11742
11743 (if (and gnus-nntp-server
11744 (stringp gnus-nntp-server)
11745 (not (string= gnus-nntp-server "")))
11746 (setq gnus-select-method
11747 (cond ((or (string= gnus-nntp-server "")
11748 (string= gnus-nntp-server "::"))
11749 (list 'nnspool (system-name)))
11750 ((string-match "^:" gnus-nntp-server)
11751 (list 'nnmh gnus-nntp-server
11752 (list 'nnmh-directory
11753 (file-name-as-directory
11754 (expand-file-name
11755 (concat "~/" (substring
11756 gnus-nntp-server 1)))))
11757 (list 'nnmh-get-new-mail nil)))
11758 (t
11759 (list 'nntp gnus-nntp-server)))))
11760
11761 (setq how (car gnus-select-method))
11762 (cond ((eq how 'nnspool)
11763 (require 'nnspool)
11764 (gnus-message 5 "Looking up local news spool..."))
11765 ((eq how 'nnmh)
11766 (require 'nnmh)
11767 (gnus-message 5 "Looking up mh spool..."))
11768 (t
11769 (require 'nntp)))
11770 (setq gnus-current-select-method gnus-select-method)
11771 (run-hooks 'gnus-open-server-hook)
11772 (or
11773 ;; gnus-open-server-hook might have opened it
11774 (gnus-server-opened gnus-select-method)
11775 (gnus-open-server gnus-select-method)
11776 (gnus-y-or-n-p
11777 (format
11778 "%s open error: '%s'. Continue? "
11779 (nth 1 gnus-select-method)
11780 (gnus-status-message gnus-select-method)))
11781 (progn
11782 (gnus-message 1 "Couldn't open server on %s"
11783 (nth 1 gnus-select-method))
11784 (ding)
11785 nil)))))
11786
11787(defun gnus-check-server (&optional method)
11788 "If the news server is down, start it up again."
11789 (let ((method (if method method gnus-select-method)))
11790 (and (stringp method)
11791 (setq method (gnus-server-to-method method)))
11792 (if (gnus-server-opened method)
11793 ;; Stream is already opened.
11794 t
11795 ;; Open server.
11796 (gnus-message 5 "Opening server %s on %s..." (car method) (nth 1 method))
11797 (run-hooks 'gnus-open-server-hook)
11798 (prog1
11799 (gnus-open-server method)
11800 (message "")))))
11801
11802(defun gnus-nntp-message (&optional message)
11803 "Check the status of the NNTP server.
11804If the status of the server is clear and MESSAGE is non-nil, MESSAGE
11805is returned insted of the status string."
11806 (let ((status (gnus-status-message (gnus-find-method-for-group
11807 gnus-newsgroup-name)))
11808 (message (or message "")))
11809 (if (and (stringp status) (> (length status) 0))
11810 status message)))
11811
11812(defun gnus-get-function (method function)
11813 (and (stringp method)
11814 (setq method (gnus-server-to-method method)))
11815 (let ((func (intern (format "%s-%s" (car method) function))))
11816 (if (not (fboundp func))
b027f415 11817 (progn
41487370
LMI
11818 (require (car method))
11819 (if (not (fboundp func))
11820 (error "No such function: %s" func))))
11821 func))
11822
11823;;; Interface functions to the backends.
11824
11825(defun gnus-open-server (method)
11826 (funcall (gnus-get-function method 'open-server)
11827 (nth 1 method) (nthcdr 2 method)))
11828
11829(defun gnus-close-server (method)
11830 (funcall (gnus-get-function method 'close-server) (nth 1 method)))
11831
11832(defun gnus-request-list (method)
11833 (funcall (gnus-get-function method 'request-list) (nth 1 method)))
11834
11835(defun gnus-request-list-newsgroups (method)
11836 (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method)))
11837
11838(defun gnus-request-newgroups (date method)
11839 (funcall (gnus-get-function method 'request-newgroups)
11840 date (nth 1 method)))
11841
11842(defun gnus-server-opened (method)
11843 (funcall (gnus-get-function method 'server-opened) (nth 1 method)))
11844
11845(defun gnus-status-message (method)
11846 (let ((method (if (stringp method) (gnus-find-method-for-group method)
11847 method)))
11848 (funcall (gnus-get-function method 'status-message) (nth 1 method))))
11849
11850(defun gnus-request-group (group &optional dont-check)
11851 (let ((method (gnus-find-method-for-group group)))
11852 (funcall (gnus-get-function method 'request-group)
11853 (gnus-group-real-name group) (nth 1 method) dont-check)))
11854
11855(defun gnus-request-asynchronous (group &optional articles)
11856 (let ((method (gnus-find-method-for-group group)))
11857 (funcall (gnus-get-function method 'request-asynchronous)
11858 (gnus-group-real-name group) (nth 1 method) articles)))
11859
11860(defun gnus-list-active-group (group)
11861 (let ((method (gnus-find-method-for-group group))
11862 (func 'list-active-group))
11863 (and (gnus-check-backend-function func group)
11864 (funcall (gnus-get-function method func)
11865 (gnus-group-real-name group) (nth 1 method)))))
11866
11867(defun gnus-request-group-description (group)
11868 (let ((method (gnus-find-method-for-group group))
11869 (func 'request-group-description))
11870 (and (gnus-check-backend-function func group)
11871 (funcall (gnus-get-function method func)
11872 (gnus-group-real-name group) (nth 1 method)))))
11873
11874(defun gnus-close-group (group)
11875 (let ((method (gnus-find-method-for-group group)))
11876 (funcall (gnus-get-function method 'close-group)
11877 (gnus-group-real-name group) (nth 1 method))))
11878
11879(defun gnus-retrieve-headers (articles group)
11880 (let ((method (gnus-find-method-for-group group)))
11881 (if (and gnus-use-cache (numberp (car articles)))
11882 (gnus-cache-retrieve-headers articles group)
11883 (funcall (gnus-get-function method 'retrieve-headers)
11884 articles (gnus-group-real-name group) (nth 1 method)))))
11885
11886(defun gnus-retrieve-groups (groups method)
11887 (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method)))
11888
11889(defun gnus-request-article (article group &optional buffer)
11890 (let ((method (gnus-find-method-for-group group)))
11891 (funcall (gnus-get-function method 'request-article)
11892 article (gnus-group-real-name group) (nth 1 method) buffer)))
11893
11894(defun gnus-request-head (article group)
11895 (let ((method (gnus-find-method-for-group group)))
11896 (funcall (gnus-get-function method 'request-head)
11897 article (gnus-group-real-name group) (nth 1 method))))
11898
11899(defun gnus-request-body (article group)
11900 (let ((method (gnus-find-method-for-group group)))
11901 (funcall (gnus-get-function method 'request-body)
11902 article (gnus-group-real-name group) (nth 1 method))))
11903
11904;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
11905(defun gnus-request-post-buffer (post group subject header artbuf
11906 info follow-to respect-poster)
11907 (let* ((info (or info (and group (nth 2 (gnus-gethash
11908 group gnus-newsrc-hashtb)))))
11909 (method
11910 (if (and gnus-post-method
11911 ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
11912 (memq 'post (assoc
11913 (format "%s" (car (gnus-find-method-for-group
11914 gnus-newsgroup-name)))
11915 gnus-valid-select-methods)))
11916 gnus-post-method
11917 (gnus-find-method-for-group gnus-newsgroup-name))))
11918 (or (gnus-check-server method)
11919 (error "Can't open server %s:%s" (car method) (nth 1 method)))
11920 (let ((mail-self-blind nil)
11921 (mail-archive-file-name nil))
11922 (funcall (gnus-get-function method 'request-post-buffer)
11923 post group subject header artbuf info follow-to
11924 respect-poster))))
11925
11926(defun gnus-request-post (method &optional force)
11927 (and (stringp method)
11928 (setq method (gnus-server-to-method method)))
11929 (and (not force) gnus-post-method
11930 (memq 'post (assoc (format "%s" (car method))
11931 gnus-valid-select-methods))
11932 (setq method gnus-post-method))
11933 (funcall (gnus-get-function method 'request-post)
11934 (nth 1 method)))
11935
11936(defun gnus-request-expire-articles (articles group &optional force)
11937 (let ((method (gnus-find-method-for-group group)))
11938 (funcall (gnus-get-function method 'request-expire-articles)
11939 articles (gnus-group-real-name group) (nth 1 method)
11940 force)))
11941
11942(defun gnus-request-move-article
11943 (article group server accept-function &optional last)
11944 (let ((method (gnus-find-method-for-group group)))
11945 (funcall (gnus-get-function method 'request-move-article)
11946 article (gnus-group-real-name group)
11947 (nth 1 method) accept-function last)))
11948
11949(defun gnus-request-accept-article (group &optional last)
11950 (let ((func (if (symbolp group) group
11951 (car (gnus-find-method-for-group group)))))
11952 (funcall (intern (format "%s-request-accept-article" func))
11953 (if (stringp group) (gnus-group-real-name group) group)
11954 last)))
11955
11956(defun gnus-request-replace-article (article group buffer)
11957 (let ((func (car (gnus-find-method-for-group group))))
11958 (funcall (intern (format "%s-request-replace-article" func))
11959 article (gnus-group-real-name group) buffer)))
11960
11961(defun gnus-request-create-group (group)
11962 (let ((method (gnus-find-method-for-group group)))
11963 (funcall (gnus-get-function method 'request-create-group)
11964 (gnus-group-real-name group) (nth 1 method))))
11965
11966(defun gnus-member-of-valid (symbol group)
11967 (memq symbol (assoc
11968 (format "%s" (car (gnus-find-method-for-group group)))
11969 gnus-valid-select-methods)))
11970
11971(defun gnus-secondary-method-p (method)
11972 (let ((methods gnus-secondary-select-methods)
11973 (gmethod (gnus-server-get-method nil method)))
11974 (while (and methods
11975 (not (equal (gnus-server-get-method nil (car methods))
11976 gmethod)))
11977 (setq methods (cdr methods)))
11978 methods))
11979
11980(defun gnus-find-method-for-group (group &optional info)
11981 (or gnus-override-method
11982 (and (not group)
11983 gnus-select-method)
11984 (let ((info (or info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))))
11985 method)
11986 (if (or (not info)
11987 (not (setq method (nth 4 info))))
11988 (setq method gnus-select-method)
11989 (setq method
11990 (cond ((stringp method)
11991 (gnus-server-to-method method))
11992 ((stringp (car method))
11993 (gnus-server-extend-method group method))
11994 (t
11995 method))))
11996 (gnus-server-add-address method))))
11997
11998(defun gnus-check-backend-function (func group)
11999 (let ((method (if (stringp group) (car (gnus-find-method-for-group group))
12000 group)))
12001 (fboundp (intern (format "%s-%s" method func)))))
12002
12003(defun gnus-methods-using (method)
12004 (let ((valids gnus-valid-select-methods)
12005 outs)
12006 (while valids
12007 (if (memq method (car valids))
12008 (setq outs (cons (car valids) outs)))
12009 (setq valids (cdr valids)))
12010 outs))
12011
12012;;;
12013;;; Active & Newsrc File Handling
12014;;;
12015
12016;; Newsrc related functions.
12017;; Gnus internal format of gnus-newsrc-alist:
12018;; (("alt.general" 3 (1 . 1))
12019;; ("alt.misc" 3 ((1 . 10) (12 . 15)))
12020;; ("alt.test" 7 (1 . 99) (45 57 93)) ...)
12021;; The first item is the group name; the second is the subscription
12022;; level; the third is either a range of a list of ranges of read
12023;; articles, the optional fourth element is a list of marked articles,
12024;; the optional fifth element is the select method.
12025;;
12026;; Gnus internal format of gnus-newsrc-hashtb:
12027;; (95 ("alt.general" 3 (1 . 1)) ("alt.misc" 3 ((1 . 10) (12 . 15))) ...)
12028;; This is the entry for "alt.misc". The first element is the number
12029;; of unread articles in "alt.misc". The cdr of this entry is the
12030;; element *before* "alt.misc" in gnus-newsrc-alist, which makes is
12031;; trivial to remove or add new elements into gnus-newsrc-alist
12032;; without scanning the entire list. So, to get the actual information
12033;; of "alt.misc", you'd say something like
12034;; (nth 2 (gnus-gethash "alt.misc" gnus-newsrc-hashtb))
12035;;
12036;; Gnus internal format of gnus-active-hashtb:
12037;; ((1 . 1))
12038;; (5 . 10))
12039;; (67 . 99)) ...)
12040;; The only element in each entry in this hash table is a range of
12041;; (possibly) available articles. (Articles in this range may have
12042;; been expired or canceled.)
12043;;
12044;; Gnus internal format of gnus-killed-list and gnus-zombie-list:
12045;; ("alt.misc" "alt.test" "alt.general" ...)
12046
12047(defun gnus-setup-news (&optional rawfile level)
12048 "Setup news information.
12049If RAWFILE is non-nil, the .newsrc file will also be read.
12050If LEVEL is non-nil, the news will be set up at level LEVEL."
12051 (let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile)))))
12052 ;; Clear some variables to re-initialize news information.
12053 (if init (setq gnus-newsrc-alist nil
12054 gnus-active-hashtb nil))
12055
12056 ;; Read the newsrc file and create `gnus-newsrc-hashtb'.
12057 (if init (gnus-read-newsrc-file rawfile))
12058
12059 ;; If we don't read the complete active file, we fill in the
12060 ;; hashtb here.
12061 (if (or (null gnus-read-active-file)
12062 (eq gnus-read-active-file 'some))
12063 (gnus-update-active-hashtb-from-killed))
12064
12065 ;; Read the active file and create `gnus-active-hashtb'.
12066 ;; If `gnus-read-active-file' is nil, then we just create an empty
12067 ;; hash table. The partial filling out of the hash table will be
12068 ;; done in `gnus-get-unread-articles'.
12069 (and gnus-read-active-file
12070 (not level)
12071 (gnus-read-active-file))
12072
12073 (or gnus-active-hashtb
12074 (setq gnus-active-hashtb (make-vector 4095 0)))
12075
12076 ;; Possibly eval the dribble file.
12077 (and init gnus-use-dribble-file (gnus-dribble-eval-file))
12078
12079 (gnus-update-format-specifications)
12080
12081 ;; Find new newsgroups and treat them.
12082 (if (and init gnus-check-new-newsgroups gnus-read-active-file (not level)
7e988fb6 12083 (gnus-check-server gnus-select-method))
41487370
LMI
12084 (gnus-find-new-newsgroups))
12085
12086 ;; Find the number of unread articles in each non-dead group.
12087 (let ((gnus-read-active-file (and (not level) gnus-read-active-file)))
12088 (gnus-get-unread-articles (or level (1+ gnus-level-subscribed))))
12089
12090 (if (and init gnus-check-bogus-newsgroups
12091 gnus-read-active-file (not level)
12092 (gnus-server-opened gnus-select-method))
12093 (gnus-check-bogus-newsgroups))))
745bc783
JB
12094
12095(defun gnus-find-new-newsgroups ()
41487370
LMI
12096 "Search for new newsgroups and add them.
12097Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.'
12098The `-n' option line from .newsrc is respected."
12099 (interactive)
12100 (or (gnus-check-first-time-used)
12101 (if (or (consp gnus-check-new-newsgroups)
12102 (eq gnus-check-new-newsgroups 'ask-server))
12103 (gnus-ask-server-for-new-groups)
12104 (let ((groups 0)
12105 group new-newsgroups)
12106 (gnus-message 5 "Looking for new newsgroups...")
12107 (or gnus-have-read-active-file (gnus-read-active-file))
12108 (setq gnus-newsrc-last-checked-date (current-time-string))
12109 (if (not gnus-killed-hashtb) (gnus-make-hashtable-from-killed))
12110 ;; Go though every newsgroup in `gnus-active-hashtb' and compare
12111 ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
12112 (mapatoms
12113 (lambda (sym)
12114 (if (or (null (setq group (symbol-name sym)))
12115 (null (symbol-value sym))
12116 (gnus-gethash group gnus-killed-hashtb)
12117 (gnus-gethash group gnus-newsrc-hashtb))
12118 ()
12119 (let ((do-sub (gnus-matches-options-n group)))
12120 (cond
12121 ((eq do-sub 'subscribe)
12122 (setq groups (1+ groups))
12123 (gnus-sethash group group gnus-killed-hashtb)
12124 (funcall gnus-subscribe-options-newsgroup-method group))
12125 ((eq do-sub 'ignore)
12126 nil)
12127 (t
12128 (setq groups (1+ groups))
12129 (gnus-sethash group group gnus-killed-hashtb)
12130 (if gnus-subscribe-hierarchical-interactive
12131 (setq new-newsgroups (cons group new-newsgroups))
12132 (funcall gnus-subscribe-newsgroup-method group)))))))
12133 gnus-active-hashtb)
12134 (if new-newsgroups
12135 (gnus-subscribe-hierarchical-interactive new-newsgroups))
12136 ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
12137 (if (> groups 0)
12138 (gnus-message 6 "%d new newsgroup%s arrived."
12139 groups (if (> groups 1) "s have" " has"))
12140 (gnus-message 6 "No new newsgroups."))))))
12141
12142(defun gnus-matches-options-n (group)
b94ae5f7 12143 ;; Returns `subscribe' if the group is to be unconditionally
41487370
LMI
12144 ;; subscribed, `ignore' if it is to be ignored, and nil if there is
12145 ;; no match for the group.
12146
12147 ;; First we check the two user variables.
12148 (cond
12149 ((and gnus-options-subscribe
12150 (string-match gnus-options-subscribe group))
12151 'subscribe)
12152 ((and gnus-options-not-subscribe
12153 (string-match gnus-options-not-subscribe group))
12154 'ignore)
12155 ;; Then we go through the list that was retrieved from the .newsrc
12156 ;; file. This list has elements on the form
12157 ;; `(REGEXP . {ignore,subscribe})'. The first match found (the list
12158 ;; is in the reverse order of the options line) is returned.
12159 (t
12160 (let ((regs gnus-newsrc-options-n))
12161 (while (and regs
12162 (not (string-match (car (car regs)) group)))
12163 (setq regs (cdr regs)))
12164 (and regs (cdr (car regs)))))))
12165
12166(defun gnus-ask-server-for-new-groups ()
12167 (let* ((date (or gnus-newsrc-last-checked-date (current-time-string)))
12168 (methods (cons gnus-select-method
12169 (append
12170 (and (consp gnus-check-new-newsgroups)
12171 gnus-check-new-newsgroups)
12172 gnus-secondary-select-methods)))
12173 (groups 0)
12174 (new-date (current-time-string))
12175 (hashtb (gnus-make-hashtable 100))
12176 group new-newsgroups got-new method)
12177 ;; Go through both primary and secondary select methods and
12178 ;; request new newsgroups.
12179 (while methods
12180 (setq method (gnus-server-get-method nil (car methods)))
12181 (and (gnus-check-server method)
12182 (gnus-request-newgroups date method)
12183 (save-excursion
12184 (setq got-new t)
12185 (set-buffer nntp-server-buffer)
12186 ;; Enter all the new groups in a hashtable.
12187 (gnus-active-to-gnus-format method hashtb 'ignore)))
12188 (setq methods (cdr methods)))
12189 (and got-new (setq gnus-newsrc-last-checked-date new-date))
12190 ;; Now all new groups from all select methods are in `hashtb'.
745bc783 12191 (mapatoms
41487370
LMI
12192 (lambda (group-sym)
12193 (setq group (symbol-name group-sym))
12194 (if (or (null group)
12195 (null (symbol-value group-sym))
12196 (gnus-gethash group gnus-newsrc-hashtb)
12197 (member group gnus-zombie-list)
12198 (member group gnus-killed-list))
12199 ;; The group is already known.
12200 ()
12201 (and (symbol-value group-sym)
12202 (gnus-sethash group (symbol-value group-sym) gnus-active-hashtb))
12203 (let ((do-sub (gnus-matches-options-n group)))
12204 (cond ((eq do-sub 'subscribe)
12205 (setq groups (1+ groups))
12206 (gnus-sethash group group gnus-killed-hashtb)
12207 (funcall
12208 gnus-subscribe-options-newsgroup-method group))
12209 ((eq do-sub 'ignore)
12210 nil)
12211 (t
12212 (setq groups (1+ groups))
12213 (gnus-sethash group group gnus-killed-hashtb)
12214 (if gnus-subscribe-hierarchical-interactive
12215 (setq new-newsgroups (cons group new-newsgroups))
12216 (funcall gnus-subscribe-newsgroup-method group)))))))
12217 hashtb)
12218 (if new-newsgroups
12219 (gnus-subscribe-hierarchical-interactive new-newsgroups))
12220 ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
12221 (if (> groups 0)
12222 (gnus-message 6 "%d new newsgroup%s arrived."
12223 groups (if (> groups 1) "s have" " has")))
12224 got-new))
12225
12226(defun gnus-check-first-time-used ()
12227 (if (or (> (length gnus-newsrc-alist) 1)
12228 (file-exists-p gnus-startup-file)
12229 (file-exists-p (concat gnus-startup-file ".el"))
12230 (file-exists-p (concat gnus-startup-file ".eld")))
12231 nil
12232 (gnus-message 6 "First time user; subscribing you to default groups")
12233 (or gnus-have-read-active-file (gnus-read-active-file))
12234 (setq gnus-newsrc-last-checked-date (current-time-string))
12235 (let ((groups gnus-default-subscribed-newsgroups)
12236 group)
12237 (if (eq groups t)
12238 nil
12239 (setq groups (or groups gnus-backup-default-subscribed-newsgroups))
12240 (mapatoms
12241 (lambda (sym)
12242 (if (null (setq group (symbol-name sym)))
12243 ()
12244 (let ((do-sub (gnus-matches-options-n group)))
12245 (cond
12246 ((eq do-sub 'subscribe)
12247 (gnus-sethash group group gnus-killed-hashtb)
12248 (funcall gnus-subscribe-options-newsgroup-method group))
12249 ((eq do-sub 'ignore)
12250 nil)
12251 (t
12252 (setq gnus-killed-list (cons group gnus-killed-list)))))))
12253 gnus-active-hashtb)
12254 (while groups
12255 (if (gnus-gethash (car groups) gnus-active-hashtb)
12256 (gnus-group-change-level
12257 (car groups) gnus-level-default-subscribed gnus-level-killed))
12258 (setq groups (cdr groups)))
12259 (gnus-group-make-help-group)
12260 (and gnus-novice-user
12261 (gnus-message 7 "`A k' to list killed groups"))))))
12262
12263(defun gnus-subscribe-group (group previous &optional method)
12264 (gnus-group-change-level
12265 (if method
12266 (list t group gnus-level-default-subscribed nil nil method)
12267 group)
12268 gnus-level-default-subscribed gnus-level-killed previous t))
12269
12270;; `gnus-group-change-level' is the fundamental function for changing
12271;; subscription levels of newsgroups. This might mean just changing
12272;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back
12273;; again, which subscribes/unsubscribes a group, which is equally
12274;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and
12275;; from 8-9 to 1-7 means that you remove the group from the list of
12276;; killed (or zombie) groups and add them to the (kinda) subscribed
12277;; groups. And last but not least, moving from 8 to 9 and 9 to 8,
12278;; which is trivial.
12279;; ENTRY can either be a string (newsgroup name) or a list (if
12280;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST),
12281;; otherwise it's a list in the format of the `gnus-newsrc-hashtb'
12282;; entries.
12283;; LEVEL is the new level of the group, OLDLEVEL is the old level and
12284;; PREVIOUS is the group (in hashtb entry format) to insert this group
12285;; after.
12286(defun gnus-group-change-level (entry level &optional oldlevel
12287 previous fromkilled)
12288 (let (group info active num)
12289 ;; Glean what info we can from the arguments
12290 (if (consp entry)
12291 (if fromkilled (setq group (nth 1 entry))
12292 (setq group (car (nth 2 entry))))
12293 (setq group entry))
12294 (if (and (stringp entry)
12295 oldlevel
12296 (< oldlevel gnus-level-zombie))
12297 (setq entry (gnus-gethash entry gnus-newsrc-hashtb)))
12298 (if (and (not oldlevel)
12299 (consp entry))
12300 (setq oldlevel (car (cdr (nth 2 entry)))))
12301 (if (stringp previous)
12302 (setq previous (gnus-gethash previous gnus-newsrc-hashtb)))
12303
12304 (if (and (>= oldlevel gnus-level-zombie)
12305 (gnus-gethash group gnus-newsrc-hashtb))
12306 ;; We are trying to subscribe a group that is already
12307 ;; subscribed.
12308 () ; Do nothing.
12309
12310 (or (gnus-ephemeral-group-p group)
12311 (gnus-dribble-enter
12312 (format "(gnus-group-change-level %S %S %S %S %S)"
12313 group level oldlevel (car (nth 2 previous)) fromkilled)))
12314
12315 ;; Then we remove the newgroup from any old structures, if needed.
12316 ;; If the group was killed, we remove it from the killed or zombie
12317 ;; list. If not, and it is in fact going to be killed, we remove
12318 ;; it from the newsrc hash table and assoc.
12319 (cond ((>= oldlevel gnus-level-zombie)
12320 (if (= oldlevel gnus-level-zombie)
12321 (setq gnus-zombie-list (delete group gnus-zombie-list))
12322 (setq gnus-killed-list (delete group gnus-killed-list))))
12323 (t
12324 (if (and (>= level gnus-level-zombie)
12325 entry)
12326 (progn
12327 (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb)
12328 (if (nth 3 entry)
12329 (setcdr (gnus-gethash (car (nth 3 entry))
12330 gnus-newsrc-hashtb)
12331 (cdr entry)))
12332 (setcdr (cdr entry) (cdr (cdr (cdr entry))))))))
12333
12334 ;; Finally we enter (if needed) the list where it is supposed to
12335 ;; go, and change the subscription level. If it is to be killed,
12336 ;; we enter it into the killed or zombie list.
12337 (cond ((>= level gnus-level-zombie)
12338 ;; Remove from the hash table.
12339 (gnus-sethash group nil gnus-newsrc-hashtb)
12340 (or (gnus-group-foreign-p group)
12341 ;; We do not enter foreign groups into the list of dead
12342 ;; groups.
12343 (if (= level gnus-level-zombie)
12344 (setq gnus-zombie-list (cons group gnus-zombie-list))
12345 (setq gnus-killed-list (cons group gnus-killed-list)))))
12346 (t
12347 ;; If the list is to be entered into the newsrc assoc, and
12348 ;; it was killed, we have to create an entry in the newsrc
12349 ;; hashtb format and fix the pointers in the newsrc assoc.
12350 (if (>= oldlevel gnus-level-zombie)
12351 (progn
12352 (if (listp entry)
12353 (progn
12354 (setq info (cdr entry))
12355 (setq num (car entry)))
12356 (setq active (gnus-gethash group gnus-active-hashtb))
12357 (setq num
12358 (if active (- (1+ (cdr active)) (car active)) t))
12359 ;; Check whether the group is foreign. If so, the
12360 ;; foreign select method has to be entered into the
12361 ;; info.
12362 (let ((method (gnus-group-method-name group)))
12363 (if (eq method gnus-select-method)
12364 (setq info (list group level nil))
12365 (setq info (list group level nil nil method)))))
12366 (or previous
12367 (setq previous
12368 (let ((p gnus-newsrc-alist))
12369 (while (cdr (cdr p))
12370 (setq p (cdr p)))
12371 p)))
12372 (setq entry (cons info (cdr (cdr previous))))
12373 (if (cdr previous)
12374 (progn
12375 (setcdr (cdr previous) entry)
12376 (gnus-sethash group (cons num (cdr previous))
12377 gnus-newsrc-hashtb))
12378 (setcdr previous entry)
12379 (gnus-sethash group (cons num previous)
12380 gnus-newsrc-hashtb))
12381 (if (cdr entry)
12382 (setcdr (gnus-gethash (car (car (cdr entry)))
12383 gnus-newsrc-hashtb)
12384 entry)))
12385 ;; It was alive, and it is going to stay alive, so we
12386 ;; just change the level and don't change any pointers or
12387 ;; hash table entries.
12388 (setcar (cdr (car (cdr (cdr entry)))) level)))))))
12389
12390(defun gnus-kill-newsgroup (newsgroup)
12391 "Obsolete function. Kills a newsgroup."
12392 (gnus-group-change-level
12393 (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed))
745bc783
JB
12394
12395(defun gnus-check-bogus-newsgroups (&optional confirm)
41487370
LMI
12396 "Remove bogus newsgroups.
12397If CONFIRM is non-nil, the user has to confirm the deletion of every
12398newsgroup."
12399 (let ((newsrc (cdr gnus-newsrc-alist))
12400 bogus group entry)
12401 (gnus-message 5 "Checking bogus newsgroups...")
12402 (or gnus-have-read-active-file (gnus-read-active-file))
12403 ;; Find all bogus newsgroup that are subscribed.
12404 (while newsrc
12405 (setq group (car (car newsrc)))
12406 (if (or (gnus-gethash group gnus-active-hashtb) ; Active
12407 (nth 4 (car newsrc)) ; Foreign
745bc783 12408 (and confirm
41487370
LMI
12409 (not (gnus-y-or-n-p
12410 (format "Remove bogus newsgroup: %s " group)))))
12411 ;; Don't remove.
12412 ()
745bc783
JB
12413 ;; Found a bogus newsgroup.
12414 (setq bogus (cons group bogus)))
41487370
LMI
12415 (setq newsrc (cdr newsrc)))
12416 ;; Remove all bogus subscribed groups by first killing them, and
12417 ;; then removing them from the list of killed groups.
745bc783 12418 (while bogus
41487370
LMI
12419 (and (setq entry (gnus-gethash (car bogus) gnus-newsrc-hashtb))
12420 (progn
12421 (gnus-group-change-level entry gnus-level-killed)
12422 (setq gnus-killed-list (delete (car bogus) gnus-killed-list))))
745bc783 12423 (setq bogus (cdr bogus)))
41487370
LMI
12424 ;; Then we remove all bogus groups from the list of killed and
12425 ;; zombie groups. They are are removed without confirmation.
12426 (let ((dead-lists '(gnus-killed-list gnus-zombie-list))
12427 killed)
12428 (while dead-lists
12429 (setq killed (symbol-value (car dead-lists)))
12430 (while killed
12431 (setq group (car killed))
12432 (or (gnus-gethash group gnus-active-hashtb)
12433 ;; The group is bogus.
12434 (set (car dead-lists)
12435 (delete group (symbol-value (car dead-lists)))))
12436 (setq killed (cdr killed)))
12437 (setq dead-lists (cdr dead-lists))))
12438 (gnus-message 5 "Checking bogus newsgroups...done")))
12439
12440(defun gnus-check-duplicate-killed-groups ()
12441 "Remove duplicates from the list of killed groups."
12442 (interactive)
12443 (let ((killed gnus-killed-list))
12444 (while killed
12445 (gnus-message 9 "%d" (length killed))
12446 (setcdr killed (delete (car killed) (cdr killed)))
12447 (setq killed (cdr killed)))))
12448
12449;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb'
12450;; and compute how many unread articles there are in each group.
12451(defun gnus-get-unread-articles (&optional level)
12452 (let* ((newsrc (cdr gnus-newsrc-alist))
12453 (level (or level (1+ gnus-level-subscribed)))
12454 (foreign-level
12455 (min
12456 (cond ((and gnus-activate-foreign-newsgroups
12457 (not (numberp gnus-activate-foreign-newsgroups)))
12458 (1+ gnus-level-subscribed))
12459 ((numberp gnus-activate-foreign-newsgroups)
12460 gnus-activate-foreign-newsgroups)
12461 (t 0))
12462 level))
12463 info group active virtuals method)
12464 (gnus-message 5 "Checking new news...")
745bc783 12465
41487370
LMI
12466 (while newsrc
12467 (setq info (car newsrc)
12468 group (car info)
12469 active (gnus-gethash group gnus-active-hashtb))
12470
12471 ;; Check newsgroups. If the user doesn't want to check them, or
12472 ;; they can't be checked (for instance, if the news server can't
12473 ;; be reached) we just set the number of unread articles in this
12474 ;; newsgroup to t. This means that Gnus thinks that there are
12475 ;; unread articles, but it has no idea how many.
12476 (if (and (setq method (nth 4 info))
12477 (not (gnus-server-equal gnus-select-method
12478 (gnus-server-get-method nil method)))
12479 (not (gnus-secondary-method-p method)))
12480 ;; These groups are foreign. Check the level.
12481 (if (<= (nth 1 info) foreign-level)
12482 (if (eq (car (if (stringp method)
12483 (gnus-server-to-method method)
12484 (nth 4 info))) 'nnvirtual)
12485 ;; We have to activate the virtual groups after all
12486 ;; the others, so we just pop them on a list for
12487 ;; now.
12488 (setq virtuals (cons info virtuals))
12489 (and (setq active (gnus-activate-group (car info)))
12490 ;; Close the groups as we look at them!
12491 (gnus-close-group group))))
12492
12493 ;; These groups are native or secondary.
12494 (if (and (not gnus-read-active-file)
12495 (<= (nth 1 info) level))
12496 (progn
12497 (or gnus-read-active-file (gnus-check-server method))
12498 (setq active (gnus-activate-group (car info))))))
12499
12500 (if active
12501 (gnus-get-unread-articles-in-group info active)
12502 ;; The group couldn't be reached, so we nix out the number of
12503 ;; unread articles and stuff.
12504 (gnus-sethash group nil gnus-active-hashtb)
12505 (setcar (gnus-gethash group gnus-newsrc-hashtb) t))
12506
12507 (setq newsrc (cdr newsrc)))
12508
12509 ;; Activate the virtual groups. This has to be done after all the
12510 ;; other groups.
12511 ;; !!! If one virtual group contains another virtual group, even
12512 ;; doing it this way might cause problems.
12513 (while virtuals
12514 (and (setq active (gnus-activate-group (car (car virtuals))))
12515 (gnus-get-unread-articles-in-group (car virtuals) active))
12516 (setq virtuals (cdr virtuals)))
12517
12518 (gnus-message 5 "Checking new news...done")))
12519
12520;; Create a hash table out of the newsrc alist. The `car's of the
12521;; alist elements are used as keys.
12522(defun gnus-make-hashtable-from-newsrc-alist ()
12523 (let ((alist gnus-newsrc-alist)
12524 (ohashtb gnus-newsrc-hashtb)
12525 prev)
12526 (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)))
12527 (setq alist
12528 (setq prev (setq gnus-newsrc-alist
12529 (if (equal (car (car gnus-newsrc-alist))
12530 "dummy.group")
12531 gnus-newsrc-alist
12532 (cons (list "dummy.group" 0 nil) alist)))))
12533 (while alist
12534 (gnus-sethash (car (car alist))
12535 (cons (and ohashtb (car (gnus-gethash
12536 (car (car alist)) ohashtb)))
12537 prev) gnus-newsrc-hashtb)
12538 (setq prev alist
12539 alist (cdr alist)))))
12540
12541(defun gnus-make-hashtable-from-killed ()
12542 "Create a hash table from the killed and zombie lists."
12543 (let ((lists '(gnus-killed-list gnus-zombie-list))
12544 list)
12545 (setq gnus-killed-hashtb
12546 (gnus-make-hashtable
12547 (+ (length gnus-killed-list) (length gnus-zombie-list))))
12548 (while lists
12549 (setq list (symbol-value (car lists)))
12550 (setq lists (cdr lists))
12551 (while list
12552 (gnus-sethash (car list) (car list) gnus-killed-hashtb)
12553 (setq list (cdr list))))))
12554
12555(defun gnus-get-unread-articles-in-group (info active)
12556 (let* ((range (nth 2 info))
12557 (num 0)
12558 (marked (nth 3 info)))
12559 ;; If a cache is present, we may have to alter the active info.
12560 (and gnus-use-cache
12561 (gnus-cache-possibly-alter-active (car info) active))
12562 ;; Modify the list of read articles according to what articles
12563 ;; are available; then tally the unread articles and add the
12564 ;; number to the group hash table entry.
12565 (cond
12566 ((zerop (cdr active))
12567 (setq num 0))
12568 ((not range)
12569 (setq num (- (1+ (cdr active)) (car active))))
12570 ((not (listp (cdr range)))
12571 ;; Fix a single (num . num) range according to the
12572 ;; active hash table.
12573 ;; Fix by Carsten Bormann <cabo@Informatik.Uni-Bremen.DE>.
12574 (and (< (cdr range) (car active)) (setcdr range (1- (car active))))
12575 (and (> (cdr range) (cdr active)) (setcdr range (cdr active)))
12576 ;; Compute number of unread articles.
12577 (setq num (max 0 (- (cdr active) (- (1+ (cdr range)) (car range))))))
12578 (t
12579 ;; The read list is a list of ranges. Fix them according to
12580 ;; the active hash table.
12581 ;; First peel off any elements that are below the lower
12582 ;; active limit.
12583 (while (and (cdr range)
12584 (>= (car active)
12585 (or (and (atom (car (cdr range))) (car (cdr range)))
12586 (car (car (cdr range))))))
12587 (if (numberp (car range))
12588 (setcar range
12589 (cons (car range)
12590 (or (and (numberp (car (cdr range)))
12591 (car (cdr range)))
12592 (cdr (car (cdr range))))))
12593 (setcdr (car range)
12594 (or (and (numberp (nth 1 range)) (nth 1 range))
12595 (cdr (car (cdr range))))))
12596 (setcdr range (cdr (cdr range))))
12597 ;; Adjust the first element to be the same as the lower limit.
12598 (if (and (not (atom (car range)))
12599 (< (cdr (car range)) (car active)))
12600 (setcdr (car range) (1- (car active))))
12601 ;; Then we want to peel off any elements that are higher
12602 ;; than the upper active limit.
12603 (let ((srange range))
12604 ;; Go past all legal elements.
12605 (while (and (cdr srange)
12606 (<= (or (and (atom (car (cdr srange)))
12607 (car (cdr srange)))
12608 (car (car (cdr srange)))) (cdr active)))
12609 (setq srange (cdr srange)))
12610 (if (cdr srange)
12611 ;; Nuke all remaining illegal elements.
12612 (setcdr srange nil))
12613
12614 ;; Adjust the final element.
12615 (if (and (not (atom (car srange)))
12616 (> (cdr (car srange)) (cdr active)))
12617 (setcdr (car srange) (cdr active))))
12618 ;; Compute the number of unread articles.
12619 (while range
12620 (setq num (+ num (- (1+ (or (and (atom (car range)) (car range))
12621 (cdr (car range))))
12622 (or (and (atom (car range)) (car range))
12623 (car (car range))))))
12624 (setq range (cdr range)))
12625 (setq num (max 0 (- (cdr active) num)))))
12626 (and info
12627 (progn
12628 (and (assq 'tick marked)
12629 (inline (gnus-remove-illegal-marked-articles
12630 (assq 'tick marked) (nth 2 info))))
12631 (and (assq 'dormant marked)
12632 (inline (gnus-remove-illegal-marked-articles
12633 (assq 'dormant marked) (nth 2 info))))
12634 (setcar
12635 (gnus-gethash (car info) gnus-newsrc-hashtb)
12636 (setq num (max 0 (- num (length (cdr (assq 'tick marked)))
12637 (length (cdr (assq 'dormant marked)))))))))
12638 num))
12639
12640(defun gnus-remove-illegal-marked-articles (marked ranges)
12641 (let ((m (cdr marked)))
12642 ;; Make sure that all ticked articles are a subset of the unread
12643 ;; articles.
12644 (while m
12645 (if (gnus-member-of-range (car m) ranges)
12646 (setcdr marked (cdr m))
12647 (setq marked m))
12648 (setq m (cdr m)))))
12649
12650(defun gnus-activate-group (group)
12651 ;; Check whether a group has been activated or not.
12652 (let ((method (gnus-find-method-for-group group))
12653 active)
12654 (and (gnus-check-server method)
12655 ;; We escape all bugs and quit here to make it possible to
12656 ;; continue if a group is so out-there that it reports bugs
12657 ;; and stuff.
12658 (condition-case ()
12659 (gnus-request-group group)
12660 (error nil)
12661 (quit nil))
12662 (save-excursion
12663 (set-buffer nntp-server-buffer)
12664 (goto-char (point-min))
12665 ;; Parse the result we got from `gnus-request-group'.
12666 (and (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+")
12667 (progn
12668 (goto-char (match-beginning 1))
12669 (gnus-sethash
12670 group (setq active (cons (read (current-buffer))
12671 (read (current-buffer))))
12672 gnus-active-hashtb))
12673 ;; Return the new active info.
12674 active)))))
12675
12676(defun gnus-update-read-articles
12677 (group unread unselected ticked &optional domarks replied expirable killed
12678 dormant bookmark score)
12679 "Update the list of read and ticked articles in GROUP using the
12680UNREAD and TICKED lists.
12681Note: UNSELECTED has to be sorted over `<'.
12682Returns whether the updating was successful."
12683 (let* ((active (or gnus-newsgroup-active
12684 (gnus-gethash group gnus-active-hashtb)))
12685 (entry (gnus-gethash group gnus-newsrc-hashtb))
12686 (info (nth 2 entry))
12687 (marked (nth 3 info))
12688 (prev 1)
12689 (unread (sort (copy-sequence unread) (function <)))
12690 read)
12691 (if (or (not info) (not active))
12692 ;; There is no info on this group if it was, in fact,
12693 ;; killed. Gnus stores no information on killed groups, so
12694 ;; there's nothing to be done.
12695 ;; One could store the information somewhere temporarily,
12696 ;; perhaps... Hmmm...
12697 ()
12698 ;; Remove any negative articles numbers.
12699 (while (and unread (< (car unread) 0))
12700 (setq unread (cdr unread)))
12701 ;; Remove any expired article numbers
12702 (while (and unread (< (car unread) (car active)))
12703 (setq unread (cdr unread)))
12704 (while (and ticked (< (car ticked) (car active)))
12705 (setq ticked (cdr ticked)))
12706 (while (and dormant (< (car dormant) (car active)))
12707 (setq dormant (cdr dormant)))
12708 (setq unread (sort (append unselected unread) '<))
12709 ;; Compute the ranges of read articles by looking at the list of
12710 ;; unread articles.
12711 (while unread
12712 (if (/= (car unread) prev)
12713 (setq read (cons (if (= prev (1- (car unread))) prev
12714 (cons prev (1- (car unread)))) read)))
12715 (setq prev (1+ (car unread)))
12716 (setq unread (cdr unread)))
12717 (if (<= prev (cdr active))
12718 (setq read (cons (cons prev (cdr active)) read)))
12719 ;; Enter this list into the group info.
12720 (setcar (cdr (cdr info))
12721 (if (> (length read) 1) (nreverse read) read))
12722 ;; Enter the list of ticked articles.
12723 (gnus-set-marked-articles
12724 info ticked
12725 (if domarks replied (cdr (assq 'reply marked)))
12726 (if domarks expirable (cdr (assq 'expire marked)))
12727 (if domarks killed (cdr (assq 'killed marked)))
12728 (if domarks dormant (cdr (assq 'dormant marked)))
12729 (if domarks bookmark (cdr (assq 'bookmark marked)))
12730 (if domarks score (cdr (assq 'score marked))))
12731 ;; Set the number of unread articles in gnus-newsrc-hashtb.
12732 (gnus-get-unread-articles-in-group
12733 info (gnus-gethash group gnus-active-hashtb))
12734 t)))
12735
12736(defun gnus-make-articles-unread (group articles)
12737 "Mark ARTICLES in GROUP as unread."
12738 (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb)
12739 (gnus-gethash (gnus-group-real-name group)
12740 gnus-newsrc-hashtb))))
12741 (ranges (nth 2 info))
12742 news)
12743 (while articles
12744 (and (gnus-member-of-range (car articles) ranges)
12745 (setq news (cons (car articles) news)))
12746 (setq articles (cdr articles)))
12747 (if (not news)
12748 ()
12749 (setcar (nthcdr 2 info)
12750 (gnus-remove-from-range (nth 2 info) (nreverse news)))
12751 (gnus-group-update-group group t))))
12752
12753;; Enter all dead groups into the hashtb.
12754(defun gnus-update-active-hashtb-from-killed ()
12755 (let ((hashtb (setq gnus-active-hashtb (make-vector 4095 0)))
12756 (lists (list gnus-killed-list gnus-zombie-list))
12757 killed)
12758 (while lists
12759 (setq killed (car lists))
12760 (while killed
12761 (gnus-sethash (car killed) nil hashtb)
12762 (setq killed (cdr killed)))
12763 (setq lists (cdr lists)))))
12764
12765;; Get the active file(s) from the backend(s).
745bc783 12766(defun gnus-read-active-file ()
41487370
LMI
12767 (gnus-group-set-mode-line)
12768 (let ((methods (if (gnus-check-server gnus-select-method)
12769 ;; The native server is available.
12770 (cons gnus-select-method gnus-secondary-select-methods)
12771 ;; The native server is down, so we just do the
12772 ;; secondary ones.
12773 gnus-secondary-select-methods))
12774 list-type)
12775 (setq gnus-have-read-active-file nil)
12776 (save-excursion
12777 (set-buffer nntp-server-buffer)
12778 (while methods
12779 (let* ((method (gnus-server-get-method nil (car methods)))
12780 (where (nth 1 method))
12781 (mesg (format "Reading active file%s via %s..."
12782 (if (and where (not (zerop (length where))))
12783 (concat " from " where) "")
12784 (car method))))
12785 (gnus-message 5 mesg)
12786 (if (not (gnus-check-server method))
12787 ()
12788 (cond
12789 ((and (eq gnus-read-active-file 'some)
12790 (gnus-check-backend-function 'retrieve-groups (car method)))
12791 (let ((newsrc (cdr gnus-newsrc-alist))
12792 (gmethod (gnus-server-get-method nil method))
12793 groups)
12794 (while newsrc
12795 (and (gnus-server-equal
12796 (gnus-find-method-for-group
12797 (car (car newsrc)) (car newsrc))
12798 gmethod)
12799 (setq groups (cons (gnus-group-real-name
12800 (car (car newsrc))) groups)))
12801 (setq newsrc (cdr newsrc)))
12802 (gnus-check-server method)
12803 (setq list-type (gnus-retrieve-groups groups method))
12804 (cond
12805 ((not list-type)
12806 (gnus-message
12807 1 "Cannot read partial active file from %s server."
12808 (car method))
12809 (ding)
12810 (sit-for 2))
12811 ((eq list-type 'active)
12812 (gnus-active-to-gnus-format method gnus-active-hashtb))
12813 (t
12814 (gnus-groups-to-gnus-format method gnus-active-hashtb)))))
12815 (t
12816 (if (not (gnus-request-list method))
12817 (progn
12818 (gnus-message 1 "Cannot read active file from %s server."
12819 (car method))
12820 (ding))
12821 (gnus-active-to-gnus-format method)
12822 ;; We mark this active file as read.
12823 (setq gnus-have-read-active-file
12824 (cons method gnus-have-read-active-file))
12825 (gnus-message 5 "%sdone" mesg))))))
12826 (setq methods (cdr methods))))))
12827
12828;; Read an active file and place the results in `gnus-active-hashtb'.
12829(defun gnus-active-to-gnus-format (method &optional hashtb ignore-errors)
12830 (let ((cur (current-buffer))
12831 (hashtb (or hashtb
12832 (if (and gnus-active-hashtb
12833 (not (equal method gnus-select-method)))
12834 gnus-active-hashtb
12835 (setq gnus-active-hashtb
12836 (if (equal method gnus-select-method)
12837 (gnus-make-hashtable
12838 (count-lines (point-min) (point-max)))
12839 (gnus-make-hashtable 4096))))))
12840 (flag-hashtb (gnus-make-hashtable 60)))
12841 ;; Delete unnecessary lines.
12842 (goto-char (point-min))
12843 (while (search-forward "\nto." nil t)
12844 (delete-region (1+ (match-beginning 0))
12845 (progn (forward-line 1) (point))))
12846 (or (string= gnus-ignored-newsgroups "")
12847 (progn
12848 (goto-char (point-min))
12849 (delete-matching-lines gnus-ignored-newsgroups)))
12850 ;; Make the group names readable as a lisp expression even if they
12851 ;; contain special characters.
12852 ;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>.
12853 (goto-char (point-max))
12854 (while (re-search-backward "[][';?()#]" nil t)
12855 (insert ?\\))
12856 ;; If these are groups from a foreign select method, we insert the
12857 ;; group prefix in front of the group names.
12858 (and method (not (gnus-server-equal
12859 (gnus-server-get-method nil method)
12860 (gnus-server-get-method nil gnus-select-method)))
12861 (let ((prefix (gnus-group-prefixed-name "" method)))
12862 (goto-char (point-min))
12863 (while (and (not (eobp))
12864 (progn (insert prefix)
12865 (zerop (forward-line 1)))))))
12866 ;; Store the active file in a hash table.
12867 (goto-char (point-min))
12868 (if (string-match "%[oO]" gnus-group-line-format)
12869 ;; Suggested by Brian Edmonds <edmonds@cs.ubc.ca>.
12870 ;; If we want information on moderated groups, we use this
12871 ;; loop...
12872 (let* ((mod-hashtb (make-vector 7 0))
12873 (m (intern "m" mod-hashtb))
12874 group max min)
12875 (while (not (eobp))
12876 (condition-case nil
12877 (progn
12878 (narrow-to-region (point) (gnus-point-at-eol))
12879 (setq group (let ((obarray hashtb)) (read cur)))
12880 (if (and (numberp (setq max (read cur)))
12881 (numberp (setq min (read cur)))
12882 (progn
12883 (skip-chars-forward " \t")
12884 (not
12885 (or (= (following-char) ?=)
12886 (= (following-char) ?x)
12887 (= (following-char) ?j)))))
12888 (set group (cons min max))
12889 (set group nil))
12890 ;; Enter moderated groups into a list.
12891 (if (eq (let ((obarray mod-hashtb)) (read cur)) m)
12892 (setq gnus-moderated-list
12893 (cons (symbol-name group) gnus-moderated-list))))
12894 (error
12895 (and group
12896 (symbolp group)
12897 (set group nil))))
12898 (widen)
12899 (forward-line 1)))
12900 ;; And if we do not care about moderation, we use this loop,
12901 ;; which is faster.
12902 (let (group max min)
12903 (while (not (eobp))
12904 (condition-case ()
12905 (progn
12906 (narrow-to-region (point) (gnus-point-at-eol))
12907 ;; group gets set to a symbol interned in the hash table
12908 ;; (what a hack!!) - jwz
12909 (setq group (let ((obarray hashtb)) (read cur)))
12910 (if (and (numberp (setq max (read cur)))
12911 (numberp (setq min (read cur)))
12912 (progn
12913 (skip-chars-forward " \t")
12914 (not
12915 (or (= (following-char) ?=)
12916 (= (following-char) ?x)
12917 (= (following-char) ?j)))))
12918 (set group (cons min max))
12919 (set group nil)))
12920 (error
12921 (progn
12922 (and group
12923 (symbolp group)
12924 (set group nil))
12925 (or ignore-errors
12926 (gnus-message 3 "Warning - illegal active: %s"
12927 (buffer-substring
12928 (gnus-point-at-bol) (gnus-point-at-eol)))))))
12929 (widen)
12930 (forward-line 1))))))
12931
12932(defun gnus-groups-to-gnus-format (method &optional hashtb)
12933 ;; Parse a "groups" active file.
12934 (let ((cur (current-buffer))
12935 (hashtb (or hashtb
12936 (if (and method gnus-active-hashtb)
12937 gnus-active-hashtb
12938 (setq gnus-active-hashtb
12939 (gnus-make-hashtable
12940 (count-lines (point-min) (point-max)))))))
12941 (prefix (and method
12942 (not (gnus-server-equal
12943 (gnus-server-get-method nil method)
12944 (gnus-server-get-method nil gnus-select-method)))
12945 (gnus-group-prefixed-name "" method))))
745bc783 12946
41487370
LMI
12947 (goto-char (point-min))
12948 ;; We split this into to separate loops, one with the prefix
12949 ;; and one without to speed the reading up somewhat.
12950 (if prefix
12951 (let (min max opoint group)
12952 (while (not (eobp))
12953 (condition-case ()
12954 (progn
12955 (read cur) (read cur)
12956 (setq min (read cur)
12957 max (read cur)
12958 opoint (point))
12959 (skip-chars-forward " \t")
12960 (insert prefix)
12961 (goto-char opoint)
12962 (set (let ((obarray hashtb)) (read cur))
12963 (cons min max)))
12964 (error (and group (symbolp group) (set group nil))))
12965 (forward-line 1)))
12966 (let (min max group)
12967 (while (not (eobp))
12968 (condition-case ()
12969 (if (= (following-char) ?2)
12970 (progn
12971 (read cur) (read cur)
12972 (setq min (read cur)
12973 max (read cur))
12974 (set (setq group (let ((obarray hashtb)) (read cur)))
12975 (cons min max))))
12976 (error (and group (symbolp group) (set group nil))))
12977 (forward-line 1))))))
12978
12979(defun gnus-read-newsrc-file (&optional force)
12980 "Read startup file.
12981If FORCE is non-nil, the .newsrc file is read."
12982 ;; Reset variables that might be defined in the .newsrc.eld file.
745bc783
JB
12983 (let ((variables gnus-variable-list))
12984 (while variables
12985 (set (car variables) nil)
12986 (setq variables (cdr variables))))
12987 (let* ((newsrc-file gnus-current-startup-file)
41487370 12988 (quick-file (concat newsrc-file ".el")))
745bc783 12989 (save-excursion
41487370
LMI
12990 ;; We always load the .newsrc.eld file. If always contains
12991 ;; much information that can not be gotten from the .newsrc
12992 ;; file (ticked articles, killed groups, foreign methods, etc.)
12993 (gnus-read-newsrc-el-file quick-file)
12994
12995 (if (or force
12996 (and (file-newer-than-file-p newsrc-file quick-file)
12997 (file-newer-than-file-p newsrc-file
12998 (concat quick-file "d")))
12999 (not gnus-newsrc-alist))
13000 ;; We read the .newsrc file. Note that if there if a
13001 ;; .newsrc.eld file exists, it has already been read, and
13002 ;; the `gnus-newsrc-hashtb' has been created. While reading
13003 ;; the .newsrc file, Gnus will only use the information it
13004 ;; can find there for changing the data already read -
13005 ;; ie. reading the .newsrc file will not trash the data
13006 ;; already read (except for read articles).
13007 (save-excursion
13008 (gnus-message 5 "Reading %s..." newsrc-file)
13009 (set-buffer (find-file-noselect newsrc-file))
13010 (buffer-disable-undo (current-buffer))
13011 (gnus-newsrc-to-gnus-format)
13012 (kill-buffer (current-buffer))
13013 (gnus-message 5 "Reading %s...done" newsrc-file))))))
13014
13015(defun gnus-read-newsrc-el-file (file)
13016 (let ((ding-file (concat file "d")))
13017 ;; We always, always read the .eld file.
13018 (gnus-message 5 "Reading %s..." ding-file)
13019 (let (gnus-newsrc-assoc)
745bc783 13020 (condition-case nil
41487370 13021 (load ding-file t t t)
745bc783 13022 (error nil))
41487370
LMI
13023 (and gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))
13024 (let ((inhibit-quit t))
13025 (gnus-uncompress-newsrc-alist))
13026 (gnus-make-hashtable-from-newsrc-alist)
13027 (if (not (file-newer-than-file-p file ding-file))
13028 ()
13029 ;; Old format quick file
13030 (gnus-message 5 "Reading %s..." file)
13031 ;; The .el file is newer than the .eld file, so we read that one
13032 ;; as well.
13033 (gnus-read-old-newsrc-el-file file))))
13034
13035;; Parse the old-style quick startup file
13036(defun gnus-read-old-newsrc-el-file (file)
13037 (let (newsrc killed marked group m)
13038 (prog1
13039 (let ((gnus-killed-assoc nil)
13040 gnus-marked-assoc gnus-newsrc-alist gnus-newsrc-assoc)
13041 (prog1
13042 (condition-case nil
13043 (load file t t t)
13044 (error nil))
13045 (setq newsrc gnus-newsrc-assoc
13046 killed gnus-killed-assoc
13047 marked gnus-marked-assoc)))
13048 (setq gnus-newsrc-alist nil)
13049 (while newsrc
13050 (setq group (car newsrc))
13051 (let ((info (nth 2 (gnus-gethash (car group) gnus-newsrc-hashtb))))
13052 (if info
13053 (progn
13054 (setcar (nthcdr 2 info) (cdr (cdr group)))
13055 (setcar (cdr info)
13056 (if (nth 1 group) gnus-level-default-subscribed
13057 gnus-level-default-unsubscribed))
13058 (setq gnus-newsrc-alist (cons info gnus-newsrc-alist)))
13059 (setq gnus-newsrc-alist
13060 (cons
13061 (setq info
13062 (list (car group)
13063 (if (nth 1 group) gnus-level-default-subscribed
13064 gnus-level-default-unsubscribed)
13065 (cdr (cdr group))))
13066 gnus-newsrc-alist)))
13067 (if (setq m (assoc (car group) marked))
13068 (setcdr (cdr (cdr info))
13069 (cons (list (cons 'tick (cdr m))) nil))))
13070 (setq newsrc (cdr newsrc)))
13071 (setq newsrc killed)
13072 (while newsrc
13073 (setcar newsrc (car (car newsrc)))
13074 (setq newsrc (cdr newsrc)))
13075 (setq gnus-killed-list killed))
13076 ;; The .el file version of this variable does not begin with
13077 ;; "options", while the .eld version does, so we just add it if it
13078 ;; isn't there.
13079 (and
13080 gnus-newsrc-options
13081 (progn
13082 (and (not (string-match "^ *options" gnus-newsrc-options))
13083 (setq gnus-newsrc-options (concat "options " gnus-newsrc-options)))
13084 (and (not (string-match "\n$" gnus-newsrc-options))
13085 (setq gnus-newsrc-options (concat gnus-newsrc-options "\n")))
13086 ;; Finally, if we read some options lines, we parse them.
13087 (or (string= gnus-newsrc-options "")
13088 (gnus-newsrc-parse-options gnus-newsrc-options))))
13089
13090 (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))
13091 (gnus-make-hashtable-from-newsrc-alist)))
13092
745bc783
JB
13093(defun gnus-make-newsrc-file (file)
13094 "Make server dependent file name by catenating FILE and server host name."
13095 (let* ((file (expand-file-name file nil))
41487370
LMI
13096 (real-file (concat file "-" (nth 1 gnus-select-method))))
13097 (if (or (file-exists-p real-file)
13098 (file-exists-p (concat real-file ".el"))
13099 (file-exists-p (concat real-file ".eld")))
13100 real-file file)))
13101
13102(defun gnus-uncompress-newsrc-alist ()
13103 ;; Uncompress all lists of marked articles in the newsrc assoc.
13104 (let ((newsrc gnus-newsrc-alist)
13105 marked)
13106 (while newsrc
13107 (if (not (setq marked (nth 3 (car newsrc))))
13108 ()
13109 (while marked
13110 (or (eq 'score (car (car marked)))
13111 (eq 'bookmark (car (car marked)))
13112 (eq 'killed (car (car marked)))
13113 (setcdr (car marked) (gnus-uncompress-range (cdr (car marked)))))
13114 (setq marked (cdr marked))))
13115 (setq newsrc (cdr newsrc)))))
13116
13117(defun gnus-compress-newsrc-alist ()
13118 ;; Compress all lists of marked articles in the newsrc assoc.
13119 (let ((newsrc gnus-newsrc-alist)
13120 marked)
13121 (while newsrc
13122 (if (not (setq marked (nth 3 (car newsrc))))
13123 ()
13124 (while marked
13125 (or (eq 'score (car (car marked)))
13126 (eq 'bookmark (car (car marked)))
13127 (eq 'killed (car (car marked)))
13128 (setcdr (car marked)
13129 (condition-case ()
13130 (gnus-compress-sequence
13131 (sort (cdr (car marked)) '<) t)
13132 (error (cdr (car marked))))))
13133 (setq marked (cdr marked))))
13134 (setq newsrc (cdr newsrc)))))
745bc783
JB
13135
13136(defun gnus-newsrc-to-gnus-format ()
41487370
LMI
13137 (setq gnus-newsrc-options "")
13138 (setq gnus-newsrc-options-n nil)
13139
13140 (or gnus-active-hashtb
13141 (setq gnus-active-hashtb (make-vector 4095 0)))
13142 (let ((buf (current-buffer))
13143 (already-read (> (length gnus-newsrc-alist) 1))
13144 group subscribed options-symbol newsrc Options-symbol
13145 symbol reads num1)
745bc783 13146 (goto-char (point-min))
41487370
LMI
13147 ;; We intern the symbol `options' in the active hashtb so that we
13148 ;; can `eq' against it later.
13149 (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil)
13150 (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil)
13151
13152 (while (not (eobp))
13153 ;; We first read the first word on the line by narrowing and
13154 ;; then reading into `gnus-active-hashtb'. Most groups will
13155 ;; already exist in that hashtb, so this will save some string
13156 ;; space.
13157 (narrow-to-region
13158 (point)
13159 (progn (skip-chars-forward "^ \t!:\n") (point)))
13160 (goto-char (point-min))
13161 (setq symbol
13162 (and (/= (point-min) (point-max))
13163 (let ((obarray gnus-active-hashtb)) (read buf))))
13164 (widen)
13165 ;; Now, the symbol we have read is either `options' or a group
13166 ;; name. If it is an options line, we just add it to a string.
13167 (cond
13168 ((or (eq symbol options-symbol)
13169 (eq symbol Options-symbol))
13170 (setq gnus-newsrc-options
b94ae5f7 13171 ;; This concating is quite inefficient, but since our
41487370
LMI
13172 ;; thorough studies show that approx 99.37% of all
13173 ;; .newsrc files only contain a single options line, we
13174 ;; don't give a damn, frankly, my dear.
13175 (concat gnus-newsrc-options
13176 (buffer-substring
13177 (gnus-point-at-bol)
13178 ;; Options may continue on the next line.
13179 (or (and (re-search-forward "^[^ \t]" nil 'move)
13180 (progn (beginning-of-line) (point)))
13181 (point)))))
13182 (forward-line -1))
13183 (symbol
13184 (or (boundp symbol) (set symbol nil))
13185 ;; It was a group name.
13186 (setq subscribed (= (following-char) ?:)
13187 group (symbol-name symbol)
13188 reads nil)
13189 (if (eolp)
13190 ;; If the line ends here, this is clearly a buggy line, so
13191 ;; we put point a the beginning of line and let the cond
13192 ;; below do the error handling.
13193 (beginning-of-line)
13194 ;; We skip to the beginning of the ranges.
13195 (skip-chars-forward "!: \t"))
13196 ;; We are now at the beginning of the list of read articles.
13197 ;; We read them range by range.
13198 (while
13199 (cond
13200 ((looking-at "[0-9]+")
13201 ;; We narrow and read a number instead of buffer-substring/
13202 ;; string-to-int because it's faster. narrow/widen is
13203 ;; faster than save-restriction/narrow, and save-restriction
13204 ;; produces a garbage object.
13205 (setq num1 (progn
13206 (narrow-to-region (match-beginning 0) (match-end 0))
13207 (read buf)))
13208 (widen)
13209 ;; If the next character is a dash, then this is a range.
13210 (if (= (following-char) ?-)
13211 (progn
13212 ;; We read the upper bound of the range.
13213 (forward-char 1)
13214 (if (not (looking-at "[0-9]+"))
13215 ;; This is a buggy line, by we pretend that
13216 ;; it's kinda OK. Perhaps the user should be
13217 ;; dinged?
13218 (setq reads (cons num1 reads))
13219 (setq reads
13220 (cons
13221 (cons num1
13222 (progn
13223 (narrow-to-region (match-beginning 0)
13224 (match-end 0))
13225 (read buf)))
13226 reads))
13227 (widen)))
13228 ;; It was just a simple number, so we add it to the
13229 ;; list of ranges.
13230 (setq reads (cons num1 reads)))
13231 ;; If the next char in ?\n, then we have reached the end
13232 ;; of the line and return nil.
13233 (/= (following-char) ?\n))
13234 ((= (following-char) ?\n)
13235 ;; End of line, so we end.
13236 nil)
13237 (t
13238 ;; Not numbers and not eol, so this might be a buggy
13239 ;; line...
13240 (or (eobp)
13241 ;; If it was eob instead of ?\n, we allow it.
13242 (progn
13243 ;; The line was buggy.
13244 (setq group nil)
13245 (gnus-message 3 "Mangled line: %s"
13246 (buffer-substring (gnus-point-at-bol)
13247 (gnus-point-at-eol)))
13248 (ding)
13249 (sit-for 1)))
13250 nil))
13251 ;; Skip past ", ". Spaces are illegal in these ranges, but
13252 ;; we allow them, because it's a common mistake to put a
13253 ;; space after the comma.
13254 (skip-chars-forward ", "))
13255
13256 ;; We have already read .newsrc.eld, so we gently update the
13257 ;; data in the hash table with the information we have just
13258 ;; read.
13259 (if (not group)
13260 ()
13261 (let ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
13262 level)
13263 (if info
13264 ;; There is an entry for this file in the alist.
13265 (progn
13266 (setcar (nthcdr 2 info) (nreverse reads))
13267 ;; We update the level very gently. In fact, we
13268 ;; only change it if there's been a status change
13269 ;; from subscribed to unsubscribed, or vice versa.
13270 (setq level (nth 1 info))
13271 (cond ((and (<= level gnus-level-subscribed)
13272 (not subscribed))
13273 (setq level (if reads
13274 gnus-level-default-unsubscribed
13275 (1+ gnus-level-default-unsubscribed))))
13276 ((and (> level gnus-level-subscribed) subscribed)
13277 (setq level gnus-level-default-subscribed)))
13278 (setcar (cdr info) level))
13279 ;; This is a new group.
13280 (setq info (list group
13281 (if subscribed
13282 gnus-level-default-subscribed
13283 (if reads
13284 (1+ gnus-level-subscribed)
13285 gnus-level-default-unsubscribed))
13286 (nreverse reads))))
13287 (setq newsrc (cons info newsrc))))))
13288 (forward-line 1))
13289
13290 (setq newsrc (nreverse newsrc))
13291
13292 (if (not already-read)
13293 ()
13294 ;; We now have two newsrc lists - `newsrc', which is what we
13295 ;; have read from .newsrc, and `gnus-newsrc-alist', which is
13296 ;; what we've read from .newsrc.eld. We have to merge these
13297 ;; lists. We do this by "attaching" any (foreign) groups in the
13298 ;; gnus-newsrc-alist to the (native) group that precedes them.
13299 (let ((rc (cdr gnus-newsrc-alist))
13300 (prev gnus-newsrc-alist)
13301 entry mentry)
13302 (while rc
13303 (or (null (nth 4 (car rc))) ; It's a native group.
13304 (assoc (car (car rc)) newsrc) ; It's already in the alist.
13305 (if (setq entry (assoc (car (car prev)) newsrc))
13306 (setcdr (setq mentry (memq entry newsrc))
13307 (cons (car rc) (cdr mentry)))
13308 (setq newsrc (cons (car rc) newsrc))))
13309 (setq prev rc
13310 rc (cdr rc)))))
13311
13312 (setq gnus-newsrc-alist newsrc)
13313 ;; We make the newsrc hashtb.
13314 (gnus-make-hashtable-from-newsrc-alist)
13315
13316 ;; Finally, if we read some options lines, we parse them.
13317 (or (string= gnus-newsrc-options "")
13318 (gnus-newsrc-parse-options gnus-newsrc-options))))
13319
13320;; Parse options lines to find "options -n !all rec.all" and stuff.
13321;; The return value will be a list on the form
13322;; ((regexp1 . ignore)
13323;; (regexp2 . subscribe)...)
13324;; When handling new newsgroups, groups that match a `ignore' regexp
13325;; will be ignored, and groups that match a `subscribe' regexp will be
13326;; subscribed. A line like
13327;; options -n !all rec.all
13328;; will lead to a list that looks like
13329;; (("^rec\\..+" . subscribe)
13330;; ("^.+" . ignore))
13331;; So all "rec.*" groups will be subscribed, while all the other
13332;; groups will be ignored. Note that "options -n !all rec.all" is very
13333;; different from "options -n rec.all !all".
13334(defun gnus-newsrc-parse-options (options)
13335 (let (out eol)
13336 (save-excursion
13337 (gnus-set-work-buffer)
13338 (insert (regexp-quote options))
13339 ;; First we treat all continuation lines.
13340 (goto-char (point-min))
13341 (while (re-search-forward "\n[ \t]+" nil t)
13342 (replace-match " " t t))
13343 ;; Then we transform all "all"s into ".+"s.
13344 (goto-char (point-min))
13345 (while (re-search-forward "\\ball\\b" nil t)
13346 (replace-match ".+" t t))
13347 (goto-char (point-min))
13348 ;; We remove all other options than the "-n" ones.
13349 (while (re-search-forward "[ \t]-[^n][^-]*" nil t)
13350 (replace-match " ")
13351 (forward-char -1))
13352 (goto-char (point-min))
13353
13354 ;; We are only interested in "options -n" lines - we
13355 ;; ignore the other option lines.
13356 (while (re-search-forward "[ \t]-n" nil t)
13357 (setq eol
13358 (or (save-excursion
13359 (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t)
13360 (- (point) 2)))
13361 (gnus-point-at-eol)))
13362 ;; Search for all "words"...
13363 (while (re-search-forward "[^ \t,\n]+" eol t)
13364 (if (= (char-after (match-beginning 0)) ?!)
13365 ;; If the word begins with a bang (!), this is a "not"
13366 ;; spec. We put this spec (minus the bang) and the
13367 ;; symbol `ignore' into the list.
13368 (setq out (cons (cons (concat
13369 "^" (buffer-substring
13370 (1+ (match-beginning 0))
13371 (match-end 0)))
13372 'ignore) out))
13373 ;; There was no bang, so this is a "yes" spec.
13374 (setq out (cons (cons (concat
13375 "^" (buffer-substring (match-beginning 0)
13376 (match-end 0)))
13377 'subscribe) out)))))
13378
13379 (setq gnus-newsrc-options-n out))))
745bc783 13380
41487370 13381
745bc783 13382(defun gnus-save-newsrc-file ()
41487370 13383 "Save .newsrc file."
745bc783 13384 ;; Note: We cannot save .newsrc file if all newsgroups are removed
41487370
LMI
13385 ;; from the variable gnus-newsrc-alist.
13386 (and (or gnus-newsrc-alist gnus-killed-list)
745bc783 13387 gnus-current-startup-file
41487370
LMI
13388 (progn
13389 (run-hooks 'gnus-save-newsrc-hook)
13390 (save-excursion
13391 (if (and gnus-use-dribble-file
13392 (or (not gnus-dribble-buffer)
13393 (not (buffer-name gnus-dribble-buffer))
13394 (zerop (save-excursion
13395 (set-buffer gnus-dribble-buffer)
13396 (buffer-size)))))
13397 (gnus-message 4 "(No changes need to be saved)")
13398 (if gnus-save-newsrc-file
13399 (progn
13400 (gnus-message 5 "Saving %s..." gnus-current-startup-file)
13401 ;; Make backup file of master newsrc.
13402 (gnus-gnus-to-newsrc-format)
13403 (gnus-message 5 "Saving %s...done"
13404 gnus-current-startup-file)))
13405 ;; Quickly loadable .newsrc.
13406 (set-buffer (get-buffer-create " *Gnus-newsrc*"))
13407 (setq buffer-file-name (concat gnus-current-startup-file ".eld"))
13408 (gnus-add-current-to-buffer-list)
13409 (buffer-disable-undo (current-buffer))
13410 (erase-buffer)
13411 (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
13412 (gnus-gnus-to-quick-newsrc-format)
13413 (save-buffer)
13414 (kill-buffer (current-buffer))
13415 (gnus-message 5 "Saving %s.eld...done" gnus-current-startup-file)
13416 (gnus-dribble-delete-file))))))
745bc783
JB
13417
13418(defun gnus-gnus-to-quick-newsrc-format ()
41487370
LMI
13419 "Insert Gnus variables such as gnus-newsrc-alist in lisp format."
13420 (insert ";; Gnus startup file.\n")
13421 (insert ";; Never delete this file - touch .newsrc instead to force Gnus\n")
13422 (insert ";; to read .newsrc.\n")
13423 (insert "(setq gnus-newsrc-file-version "
13424 (prin1-to-string gnus-version) ")\n")
13425 (let ((variables gnus-variable-list)
13426 (inhibit-quit t)
13427 (gnus-newsrc-alist (cdr gnus-newsrc-alist))
13428 variable)
13429 ;; insert lisp expressions.
13430 (gnus-compress-newsrc-alist)
745bc783
JB
13431 (while variables
13432 (setq variable (car variables))
13433 (and (boundp variable)
13434 (symbol-value variable)
41487370 13435 (or gnus-save-killed-list (not (eq variable 'gnus-killed-list)))
745bc783
JB
13436 (insert "(setq " (symbol-name variable) " '"
13437 (prin1-to-string (symbol-value variable))
13438 ")\n"))
13439 (setq variables (cdr variables)))
41487370
LMI
13440 (gnus-uncompress-newsrc-alist)))
13441
13442
13443(defun gnus-gnus-to-newsrc-format ()
13444 ;; Generate and save the .newsrc file.
13445 (let ((newsrc (cdr gnus-newsrc-alist))
13446 info ranges range)
13447 (save-excursion
13448 (set-buffer (create-file-buffer gnus-current-startup-file))
13449 (setq buffer-file-name gnus-current-startup-file)
13450 (buffer-disable-undo (current-buffer))
13451 (erase-buffer)
13452 ;; Write options.
13453 (if gnus-newsrc-options (insert gnus-newsrc-options))
13454 ;; Write subscribed and unsubscribed.
13455 (while newsrc
13456 (setq info (car newsrc))
13457 (if (not (nth 4 info)) ;Don't write foreign groups to .newsrc.
13458 (progn
13459 (insert (car info) (if (> (nth 1 info) gnus-level-subscribed)
13460 "!" ":"))
13461 (if (setq ranges (nth 2 info))
13462 (progn
13463 (insert " ")
13464 (if (not (listp (cdr ranges)))
13465 (if (= (car ranges) (cdr ranges))
13466 (insert (int-to-string (car ranges)))
13467 (insert (int-to-string (car ranges)) "-"
13468 (int-to-string (cdr ranges))))
13469 (while ranges
13470 (setq range (car ranges)
13471 ranges (cdr ranges))
13472 (if (or (atom range) (= (car range) (cdr range)))
13473 (insert (int-to-string
13474 (or (and (atom range) range)
13475 (car range))))
13476 (insert (int-to-string (car range)) "-"
13477 (int-to-string (cdr range))))
13478 (if ranges (insert ","))))))
13479 (insert "\n")))
13480 (setq newsrc (cdr newsrc)))
13481 ;; It has been reported that sometime the modtime on the .newsrc
13482 ;; file seems to be off. We really do want to overwrite it, so
13483 ;; we clear the modtime here before saving. It's a bit odd,
13484 ;; though...
13485 ;; sometimes the modtime clear isn't sufficient. most brute force:
13486 ;; delete the silly thing entirely first. but this fails to provide
13487 ;; such niceties as .newsrc~ creation.
13488 (if gnus-modtime-botch
13489 (delete-file gnus-startup-file)
13490 (clear-visited-file-modtime))
13491 (save-buffer)
13492 (kill-buffer (current-buffer)))))
13493
13494(defun gnus-read-all-descriptions-files ()
13495 (let ((methods (cons gnus-select-method gnus-secondary-select-methods)))
13496 (while methods
13497 (gnus-read-descriptions-file (car methods))
13498 (setq methods (cdr methods)))
13499 t))
13500
13501(defun gnus-read-descriptions-file (&optional method)
13502 (let ((method (or method gnus-select-method)))
13503 ;; We create the hashtable whether we manage to read the desc file
13504 ;; to avoid trying to re-read after a failed read.
13505 (or gnus-description-hashtb
13506 (setq gnus-description-hashtb
13507 (gnus-make-hashtable (length gnus-active-hashtb))))
13508 ;; Mark this method's desc file as read.
13509 (gnus-sethash (gnus-group-prefixed-name "" method) "Has read"
13510 gnus-description-hashtb)
13511
13512 (gnus-message 5 "Reading descriptions file via %s..." (car method))
13513 (cond
13514 ((not (gnus-check-server method))
13515 (gnus-message 1 "Couldn't open server")
13516 nil)
13517 ((not (gnus-request-list-newsgroups method))
13518 (gnus-message 1 "Couldn't read newsgroups descriptions")
13519 nil)
13520 (t
13521 (let (group)
13522 (save-excursion
13523 (save-restriction
13524 (set-buffer nntp-server-buffer)
13525 (goto-char (point-min))
13526 (if (or (search-forward "\n.\n" nil t)
13527 (goto-char (point-max)))
13528 (progn
13529 (beginning-of-line)
13530 (narrow-to-region (point-min) (point))))
13531 (goto-char (point-min))
13532 (while (not (eobp))
13533 ;; If we get an error, we set group to 0, which is not a
13534 ;; symbol...
13535 (setq group
13536 (condition-case ()
13537 (let ((obarray gnus-description-hashtb))
13538 ;; Group is set to a symbol interned in this
13539 ;; hash table.
13540 (read nntp-server-buffer))
13541 (error 0)))
13542 (skip-chars-forward " \t")
13543 ;; ... which leads to this line being effectively ignored.
13544 (and (symbolp group)
13545 (set group (buffer-substring
13546 (point) (progn (end-of-line) (point)))))
13547 (forward-line 1))))
13548 (gnus-message 5 "Reading descriptions file...done")
13549 t)))))
13550
13551(defun gnus-group-get-description (group)
13552 ;; Get the description of a group by sending XGTITLE to the server.
13553 (and (gnus-request-group-description group)
13554 (save-excursion
13555 (set-buffer nntp-server-buffer)
13556 (goto-char (point-min))
13557 (and (looking-at "[^ \t]+[ \t]+\\(.*\\)")
13558 (buffer-substring (match-beginning 1) (match-end 1))))))
13559
13560;;;
13561;;; Server
13562;;;
13563
13564(defvar gnus-server-mode-hook nil
13565 "Hook run in `gnus-server-mode' buffers.")
13566
13567(defconst gnus-server-line-format " {%(%h:%w%)}\n"
13568 "Format of server lines.
13569It works along the same lines as a normal formatting string,
13570with some simple extensions.")
13571
13572(defvar gnus-server-mode-line-format "Gnus List of servers"
13573 "The format specification for the server mode line.")
13574
13575(defconst gnus-server-line-format-alist
13576 (list (list ?h 'how ?s)
13577 (list ?n 'name ?s)
13578 (list ?w 'where ?s)
745bc783 13579 ))
41487370
LMI
13580
13581(defconst gnus-server-mode-line-format-alist
13582 (list (list ?S 'news-server ?s)
13583 (list ?M 'news-method ?s)
13584 (list ?u 'user-defined ?s)))
13585
13586(defvar gnus-server-line-format-spec nil)
13587(defvar gnus-server-mode-line-format-spec nil)
13588(defvar gnus-server-killed-servers nil)
13589
13590(defvar gnus-server-mode-map nil)
13591(put 'gnus-server-mode 'mode-class 'special)
13592
13593(if gnus-server-mode-map
13594 nil
13595 (setq gnus-server-mode-map (make-sparse-keymap))
13596 (suppress-keymap gnus-server-mode-map)
13597 (define-key gnus-server-mode-map " " 'gnus-server-read-server)
13598 (define-key gnus-server-mode-map "\r" 'gnus-server-read-server)
13599 (define-key gnus-server-mode-map gnus-mouse-2 'gnus-server-pick-server)
13600 (define-key gnus-server-mode-map "q" 'gnus-server-exit)
13601 (define-key gnus-server-mode-map "l" 'gnus-server-list-servers)
13602 (define-key gnus-server-mode-map "k" 'gnus-server-kill-server)
13603 (define-key gnus-server-mode-map "y" 'gnus-server-yank-server)
13604 (define-key gnus-server-mode-map "c" 'gnus-server-copy-server)
13605 (define-key gnus-server-mode-map "a" 'gnus-server-add-server)
13606 (define-key gnus-server-mode-map "e" 'gnus-server-edit-server))
13607
13608(defun gnus-server-mode ()
13609 "Major mode for listing and editing servers.
13610
13611All normal editing commands are switched off.
13612\\<gnus-server-mode-map>
13613
13614For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]').
13615
13616The following commands are available:
13617
13618\\{gnus-server-mode-map}"
13619 (interactive)
13620 (if gnus-visual (gnus-server-make-menu-bar))
13621 (kill-all-local-variables)
a828a776 13622 (gnus-simplify-mode-line)
41487370
LMI
13623 (setq major-mode 'gnus-server-mode)
13624 (setq mode-name "Server")
13625 ; (gnus-group-set-mode-line)
13626 (setq mode-line-process nil)
13627 (use-local-map gnus-server-mode-map)
13628 (buffer-disable-undo (current-buffer))
13629 (setq truncate-lines t)
13630 (setq buffer-read-only t)
13631 (run-hooks 'gnus-server-mode-hook))
13632
13633(defun gnus-server-insert-server-line (sformat name method)
13634 (let* ((sformat (or sformat gnus-server-line-format-spec))
13635 (how (car method))
13636 (where (nth 1 method))
13637 b)
13638 (beginning-of-line)
13639 (setq b (point))
13640 ;; Insert the text.
13641 (insert (eval sformat))
13642 (add-text-properties b (1+ b) (list 'gnus-server (intern name)))))
13643
13644(defun gnus-server-setup-buffer ()
13645 (if (get-buffer gnus-server-buffer)
13646 ()
13647 (save-excursion
13648 (set-buffer (get-buffer-create gnus-server-buffer))
13649 (gnus-server-mode)
13650 (and gnus-carpal (gnus-carpal-setup-buffer 'server)))))
13651
13652(defun gnus-server-prepare ()
13653 (setq gnus-server-mode-line-format-spec
13654 (gnus-parse-format gnus-server-mode-line-format
13655 gnus-server-mode-line-format-alist))
13656 (setq gnus-server-line-format-spec
13657 (gnus-parse-format gnus-server-line-format
13658 gnus-server-line-format-alist))
13659 (let ((alist gnus-server-alist)
13660 (buffer-read-only nil))
13661 (erase-buffer)
13662 (while alist
13663 (gnus-server-insert-server-line nil (car (car alist)) (cdr (car alist)))
13664 (setq alist (cdr alist))))
b027f415 13665 (goto-char (point-min))
41487370
LMI
13666 (gnus-server-position-cursor))
13667
13668(defun gnus-server-server-name ()
13669 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
13670 (and server (symbol-name server))))
13671
13672(defalias 'gnus-server-position-cursor 'gnus-goto-colon)
13673
13674(defconst gnus-server-edit-buffer "*Gnus edit server*")
13675
13676(defun gnus-server-update-server (server)
13677 (save-excursion
13678 (set-buffer gnus-server-buffer)
13679 (let ((buffer-read-only nil)
13680 (info (cdr (assoc server gnus-server-alist))))
13681 (gnus-dribble-enter
13682 (concat "(gnus-server-set-info \"" server "\" '"
13683 (prin1-to-string info) ")"))
13684 ;; Buffer may be narrowed.
13685 (save-restriction
13686 (widen)
13687 (if (gnus-server-goto-server server)
13688 (delete-region (progn (beginning-of-line) (point))
13689 (progn (forward-line 1) (point))))
13690 (let ((entry (assoc server gnus-server-alist)))
13691 (gnus-server-insert-server-line nil (car entry) (cdr entry))
13692 (gnus-server-position-cursor))))))
13693
13694(defun gnus-server-set-info (server info)
13695 ;; Enter a select method into the virtual server alist.
13696 (gnus-dribble-enter
13697 (concat "(gnus-server-set-info \"" server "\" '"
13698 (prin1-to-string info) ")"))
13699 (let* ((server (nth 1 info))
13700 (entry (assoc server gnus-server-alist)))
13701 (if entry (setcdr entry info)
13702 (setq gnus-server-alist
13703 (nconc gnus-server-alist (list (cons server info)))))))
13704
13705(defun gnus-server-to-method (server)
13706 ;; Map virtual server names to select methods.
13707 (or (and (equal server "native") gnus-select-method)
13708 (cdr (assoc server gnus-server-alist))))
13709
13710(defun gnus-server-extend-method (group method)
13711 ;; This function "extends" a virtual server. If the server is
13712 ;; "hello", and the select method is ("hello" (my-var "something"))
13713 ;; in the group "alt.alt", this will result in a new virtual server
13714 ;; called "helly+alt.alt".
13715 (let ((entry
13716 (gnus-copy-sequence
13717 (if (equal (car method) "native") gnus-select-method
13718 (cdr (assoc (car method) gnus-server-alist))))))
13719 (setcar (cdr entry) (concat (nth 1 entry) "+" group))
13720 (nconc entry (cdr method))))
13721
13722(defun gnus-server-get-method (group method)
13723 ;; Input either a server name, and extended server name, or a
13724 ;; select method, and return a select method.
13725 (cond ((stringp method)
13726 (gnus-server-to-method method))
13727 ((and (stringp (car method)) group)
13728 (gnus-server-extend-method group method))
13729 (t
13730 (gnus-server-add-address method))))
13731
13732(defun gnus-server-add-address (method)
13733 (let ((method-name (symbol-name (car method))))
13734 (if (and (memq 'address (assoc method-name gnus-valid-select-methods))
13735 (not (assq (intern (concat method-name "-address")) method)))
13736 (append method (list (list (intern (concat method-name "-address"))
13737 (nth 1 method))))
13738 method)))
13739
13740(defun gnus-server-equal (s1 s2)
13741 (or (equal s1 s2)
13742 (and (= (length s1) (length s2))
13743 (progn
13744 (while (and s1 (member (car s1) s2))
13745 (setq s1 (cdr s1)))
13746 (null s1)))))
13747
13748;;; Interactive server functions.
13749
13750(defun gnus-server-kill-server (server)
13751 "Kill the server on the current line."
13752 (interactive (list (gnus-server-server-name)))
13753 (or (gnus-server-goto-server server)
13754 (if server (error "No such server: %s" server)
13755 (error "No server on the current line")))
13756 (gnus-dribble-enter "")
13757 (let ((buffer-read-only nil))
13758 (delete-region (progn (beginning-of-line) (point))
13759 (progn (forward-line 1) (point))))
13760 (setq gnus-server-killed-servers
13761 (cons (assoc server gnus-server-alist) gnus-server-killed-servers))
13762 (setq gnus-server-alist (delq (car gnus-server-killed-servers)
13763 gnus-server-alist))
13764 (gnus-server-position-cursor))
13765
13766(defun gnus-server-yank-server ()
13767 "Yank the previously killed server."
13768 (interactive)
13769 (or gnus-server-killed-servers
13770 (error "No killed servers to be yanked"))
13771 (let ((alist gnus-server-alist)
13772 (server (gnus-server-server-name))
13773 (killed (car gnus-server-killed-servers)))
13774 (if (not server)
13775 (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
13776 (if (string= server (car (car gnus-server-alist)))
13777 (setq gnus-server-alist (cons killed gnus-server-alist))
13778 (while (and (cdr alist)
13779 (not (string= server (car (car (cdr alist))))))
13780 (setq alist (cdr alist)))
13781 (setcdr alist (cons killed (cdr alist)))))
13782 (gnus-server-update-server (car killed))
13783 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
13784 (gnus-server-position-cursor)))
13785
13786(defun gnus-server-exit ()
13787 "Return to the group buffer."
de032aaa 13788 (interactive)
41487370
LMI
13789 (kill-buffer (current-buffer))
13790 (switch-to-buffer gnus-group-buffer))
de032aaa 13791
41487370
LMI
13792(defun gnus-server-list-servers ()
13793 "List all available servers."
de032aaa 13794 (interactive)
41487370
LMI
13795 (let ((cur (gnus-server-server-name)))
13796 (gnus-server-prepare)
13797 (if cur (gnus-server-goto-server cur)
13798 (goto-char (point-max))
13799 (forward-line -1))
13800 (gnus-server-position-cursor)))
13801
13802(defun gnus-server-copy-server (from to)
13803 (interactive
13804 (list
13805 (or (gnus-server-server-name)
13806 (error "No server on the current line"))
13807 (read-string "Copy to: ")))
13808 (or from (error "No server on current line"))
13809 (or (and to (not (string= to ""))) (error "No name to copy to"))
13810 (and (assoc to gnus-server-alist) (error "%s already exists" to))
13811 (or (assoc from gnus-server-alist)
13812 (error "%s: no such server" from))
13813 (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
13814 (setcar to-entry to)
13815 (setcar (nthcdr 2 to-entry) to)
13816 (setq gnus-server-killed-servers
13817 (cons to-entry gnus-server-killed-servers))
13818 (gnus-server-yank-server)))
13819
13820(defun gnus-server-add-server (how where)
13821 (interactive
13822 (list (intern (completing-read "Server method: "
13823 gnus-valid-select-methods nil t))
13824 (read-string "Server name: ")))
13825 (setq gnus-server-killed-servers
13826 (cons (list where how where) gnus-server-killed-servers))
13827 (gnus-server-yank-server))
13828
13829(defun gnus-server-goto-server (server)
13830 "Jump to a server line."
13831 (interactive
13832 (list (completing-read "Goto server: " gnus-server-alist nil t)))
13833 (let ((to (text-property-any (point-min) (point-max)
13834 'gnus-server (intern server))))
13835 (and to
13836 (progn
13837 (goto-char to)
13838 (gnus-server-position-cursor)))))
13839
13840(defun gnus-server-edit-server (server)
13841 "Edit the server on the current line."
13842 (interactive (list (gnus-server-server-name)))
13843 (or server
13844 (error "No server on current line"))
13845 (let ((winconf (current-window-configuration)))
13846 (get-buffer-create gnus-server-edit-buffer)
13847 (gnus-configure-windows 'edit-server)
13848 (gnus-add-current-to-buffer-list)
13849 (emacs-lisp-mode)
13850 (make-local-variable 'gnus-prev-winconf)
13851 (setq gnus-prev-winconf winconf)
13852 (use-local-map (copy-keymap (current-local-map)))
13853 (let ((done-func '(lambda ()
13854 "Exit editing mode and update the information."
13855 (interactive)
13856 (gnus-server-edit-server-done 'group))))
13857 (setcar (cdr (nth 4 done-func)) server)
13858 (local-set-key "\C-c\C-c" done-func))
13859 (erase-buffer)
13860 (insert ";; Type `C-c C-c' after you have edited the server.\n\n")
13861 (insert (pp-to-string (cdr (assoc server gnus-server-alist))))))
13862
13863(defun gnus-server-edit-server-done (server)
13864 (interactive)
13865 (set-buffer (get-buffer-create gnus-server-edit-buffer))
13866 (goto-char (point-min))
13867 (let ((form (read (current-buffer)))
13868 (winconf gnus-prev-winconf))
13869 (gnus-server-set-info server form)
13870 (kill-buffer (current-buffer))
13871 (and winconf (set-window-configuration winconf))
13872 (set-buffer gnus-server-buffer)
13873 (gnus-server-update-server (gnus-server-server-name))
13874 (gnus-server-list-servers)
13875 (gnus-server-position-cursor)))
13876
13877(defun gnus-server-read-server (server)
13878 "Browse a server."
13879 (interactive (list (gnus-server-server-name)))
13880 (gnus-browse-foreign-server (gnus-server-to-method server) (current-buffer)))
13881
13882(defun gnus-mouse-pick-server (e)
13883 (interactive "e")
13884 (mouse-set-point e)
13885 (gnus-server-read-server (gnus-server-server-name)))
13886
13887;;;
13888;;; entry points into gnus-score.el
13889;;;
70fcd1c2 13890
41487370
LMI
13891;;; Finding score files.
13892
13893(defvar gnus-global-score-files nil
13894 "*List of global score files and directories.
13895Set this variable if you want to use people's score files. One entry
13896for each score file or each score file directory. Gnus will decide
13897by itself what score files are applicable to which group.
13898
13899Say you want to use the single score file
13900\"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
13901score files in the \"/ftp.some-where:/pub/score\" directory.
13902
13903 (setq gnus-global-score-files
13904 '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
13905 \"/ftp.some-where:/pub/score\"))")
13906
13907(defun gnus-score-score-files (group)
13908 "Return a list of all possible score files."
13909 ;; Search and set any global score files.
13910 (and gnus-global-score-files
13911 (or gnus-internal-global-score-files
13912 (gnus-score-search-global-directories gnus-global-score-files)))
13913 ;; Fix the kill-file dir variable.
13914 (setq gnus-kill-files-directory
13915 (file-name-as-directory
13916 (or gnus-kill-files-directory "~/News/")))
13917 ;; If we can't read it, there are no score files.
13918 (if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
13919 (setq gnus-score-file-list nil)
13920 (if (gnus-use-long-file-name 'not-score)
13921 ;; We want long file names.
13922 (if (or (not gnus-score-file-list)
13923 (not (car gnus-score-file-list))
13924 (gnus-file-newer-than gnus-kill-files-directory
13925 (car gnus-score-file-list)))
13926 (setq gnus-score-file-list
13927 (cons (nth 5 (file-attributes gnus-kill-files-directory))
13928 (nreverse
13929 (directory-files
13930 gnus-kill-files-directory t
13931 (gnus-score-file-regexp))))))
13932 ;; We do not use long file names, so we have to do some
13933 ;; directory traversing.
13934 (let ((mdir (length (expand-file-name gnus-kill-files-directory)))
13935 (suffixes (list gnus-score-file-suffix gnus-adaptive-file-suffix))
13936 dir files suffix)
13937 (while suffixes
13938 (setq dir (expand-file-name
13939 (concat gnus-kill-files-directory
13940 (gnus-replace-chars-in-string group ?. ?/))))
13941 (setq dir (gnus-replace-chars-in-string dir ?: ?/))
13942 (setq suffix (car suffixes)
13943 suffixes (cdr suffixes))
13944 (if (file-exists-p (concat dir "/" suffix))
13945 (setq files (cons (concat dir "/" suffix) files)))
13946 (while (>= (1+ (length dir)) mdir)
13947 (and (file-exists-p (concat dir "/all/" suffix))
13948 (setq files (cons (concat dir "/all/" suffix) files)))
13949 (string-match "/[^/]*$" dir)
13950 (setq dir (substring dir 0 (match-beginning 0)))))
13951 (setq gnus-score-file-list
13952 (cons nil (nreverse files)))))
13953 (cdr gnus-score-file-list)))
13954
13955(defun gnus-score-file-regexp ()
13956 (concat "\\(" gnus-score-file-suffix
13957 "\\|" gnus-adaptive-file-suffix "\\)$"))
13958
13959(defun gnus-score-find-bnews (group)
13960 "Return a list of score files for GROUP.
13961The score files are those files in the ~/News directory which matches
13962GROUP using BNews sys file syntax."
13963 (let* ((sfiles (append (gnus-score-score-files group)
13964 gnus-internal-global-score-files))
13965 (kill-dir (file-name-as-directory
13966 (expand-file-name gnus-kill-files-directory)))
13967 (klen (length kill-dir))
13968 ofiles not-match regexp)
13969 (save-excursion
13970 (set-buffer (get-buffer-create "*gnus score files*"))
13971 (buffer-disable-undo (current-buffer))
13972 ;; Go through all score file names and create regexp with them
13973 ;; as the source.
13974 (while sfiles
13975 (erase-buffer)
13976 (insert (car sfiles))
13977 (goto-char (point-min))
13978 ;; First remove the suffix itself.
13979 (re-search-forward (concat "." (gnus-score-file-regexp)))
13980 (replace-match "" t t)
13981 (goto-char (point-min))
13982 (if (looking-at (regexp-quote kill-dir))
13983 ;; If the file name was just "SCORE", `klen' is one character
13984 ;; too much.
13985 (delete-char (min (1- (point-max)) klen))
13986 (goto-char (point-max))
13987 (search-backward "/")
13988 (delete-region (1+ (point)) (point-min)))
13989 ;; If short file names were used, we have to translate slashes.
13990 (goto-char (point-min))
13991 (while (re-search-forward "[/:]" nil t)
13992 (replace-match "." t t))
b94ae5f7 13993 ;; Kludge to get rid of "nntp+" problems.
41487370
LMI
13994 (goto-char (point-min))
13995 (and (looking-at "nn[a-z]+\\+")
13996 (progn
13997 (search-forward "+")
13998 (forward-char -1)
13999 (insert "\\")))
14000 ;; Translate ".all" to "[./].*";
14001 (while (search-forward ".all" nil t)
14002 (replace-match "[./:].*" t t))
14003 (goto-char (point-min))
14004 ;; Translate "all" to ".*".
14005 (while (search-forward "all" nil t)
14006 (replace-match ".*" t t))
14007 (goto-char (point-min))
14008 ;; Deal with "not."s.
14009 (if (looking-at "not.")
14010 (progn
14011 (setq not-match t)
14012 (setq regexp (buffer-substring 5 (point-max))))
14013 (setq regexp (buffer-substring 1 (point-max)))
14014 (setq not-match nil))
14015 ;; Finally - if this resulting regexp matches the group name,
14016 ;; we add this score file to the list of score files
14017 ;; applicable to this group.
14018 (if (or (and not-match
14019 (not (string-match regexp group)))
14020 (and (not not-match)
14021 (string-match regexp group)))
14022 (setq ofiles (cons (car sfiles) ofiles)))
14023 (setq sfiles (cdr sfiles)))
14024 (kill-buffer (current-buffer))
14025 ;; Slight kludge here - the last score file returned should be
14026 ;; the local score file, whether it exists or not. This is so
14027 ;; that any score commands the user enters will go to the right
14028 ;; file, and not end up in some global score file.
14029 (let ((localscore
14030 (expand-file-name
14031 (if (gnus-use-long-file-name 'not-score)
14032 (concat gnus-kill-files-directory group "."
14033 gnus-score-file-suffix)
14034 (concat gnus-kill-files-directory
14035 (gnus-replace-chars-in-string group ?. ?/ ?: ?/)
14036 "/" gnus-score-file-suffix)))))
b94ae5f7 14037 ;; The local score file might already be there, but it's
41487370
LMI
14038 ;; supposed to be the very last file, so we delete it from the
14039 ;; list if it's already there, and add it to the head of the
14040 ;; list.
14041 (setq ofiles (cons localscore (delete localscore ofiles))))
14042 (nreverse ofiles))))
14043
14044(defun gnus-score-find-single (group)
14045 "Return list containing the score file for GROUP."
14046 (list (gnus-score-file-name group gnus-adaptive-file-suffix)
14047 (gnus-score-file-name group)))
14048
14049(defun gnus-score-find-hierarchical (group)
14050 "Return list of score files for GROUP.
14051This includes the score file for the group and all its parents."
14052 (let ((all (copy-sequence '(nil)))
14053 (start 0))
14054 (while (string-match "\\." group (1+ start))
14055 (setq start (match-beginning 0))
14056 (setq all (cons (substring group 0 start) all)))
14057 (setq all (cons group all))
14058 (nconc
14059 (mapcar (lambda (newsgroup)
14060 (gnus-score-file-name newsgroup gnus-adaptive-file-suffix))
14061 (setq all (nreverse all)))
14062 (mapcar 'gnus-score-file-name all))))
14063
14064(defvar gnus-score-file-alist-cache nil)
14065
14066(defun gnus-score-find-alist (group)
14067 "Return list of score files for GROUP.
14068The list is determined from the variable gnus-score-file-alist."
14069 (let ((alist gnus-score-file-multiple-match-alist)
14070 score-files)
14071 ;; if this group has been seen before, return the cached entry
14072 (if (setq score-files (assoc group gnus-score-file-alist-cache))
14073 (cdr score-files) ;ensures caching groups with no matches
14074 ;; handle the multiple match alist
14075 (while alist
14076 (and (string-match (car (car alist)) group)
14077 (setq score-files
14078 (nconc score-files (copy-sequence (cdr (car alist))))))
14079 (setq alist (cdr alist)))
14080 (setq alist gnus-score-file-single-match-alist)
14081 ;; handle the single match alist
14082 (while alist
14083 (and (string-match (car (car alist)) group)
14084 ;; progn used just in case ("regexp") has no files
14085 ;; and score-files is still nil. -sj
14086 ;; this can be construed as a "stop searching here" feature :>
14087 ;; and used to simplify regexps in the single-alist
14088 (progn
14089 (setq score-files
14090 (nconc score-files (copy-sequence (cdr (car alist)))))
14091 (setq alist nil)))
14092 (setq alist (cdr alist)))
14093 ;; cache the score files
14094 (setq gnus-score-file-alist-cache
14095 (cons (cons group score-files) gnus-score-file-alist-cache))
14096 score-files)))
14097
14098
14099(defun gnus-possibly-score-headers (&optional trace)
14100 (let ((func gnus-score-find-score-files-function)
14101 score-files)
14102 (and func (not (listp func))
14103 (setq func (list func)))
14104 ;; Go through all the functions for finding score files (or actual
14105 ;; scores) and add them to a list.
14106 (setq score-files (gnus-score-find-alist gnus-newsgroup-name))
14107 (while func
14108 (and (symbolp (car func))
14109 (fboundp (car func))
14110 (setq score-files
14111 (nconc score-files (funcall (car func) gnus-newsgroup-name))))
14112 (setq func (cdr func)))
14113 (if score-files (gnus-score-headers score-files trace))))
14114
14115(defun gnus-score-file-name (newsgroup &optional suffix)
14116 "Return the name of a score file for NEWSGROUP."
14117 (let ((suffix (or suffix gnus-score-file-suffix)))
14118 (cond
14119 ((or (null newsgroup)
14120 (string-equal newsgroup ""))
14121 ;; The global score file is placed at top of the directory.
14122 (expand-file-name
14123 suffix (or gnus-kill-files-directory "~/News")))
14124 ((gnus-use-long-file-name 'not-score)
14125 ;; Append ".SCORE" to newsgroup name.
b94ae5f7 14126 (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup)
41487370
LMI
14127 "." suffix)
14128 (or gnus-kill-files-directory "~/News")))
14129 (t
14130 ;; Place "SCORE" under the hierarchical directory.
14131 (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
14132 "/" suffix)
14133 (or gnus-kill-files-directory "~/News"))))))
14134
14135(defun gnus-score-search-global-directories (files)
14136 "Scan all global score directories for score files."
14137 ;; Set the variable `gnus-internal-global-score-files' to all
14138 ;; available global score files.
14139 (interactive (list gnus-global-score-files))
14140 (let (out)
14141 (while files
14142 (if (string-match "/$" (car files))
14143 (setq out (nconc (directory-files
14144 (car files) t
14145 (concat (gnus-score-file-regexp) "$"))))
14146 (setq out (cons (car files) out)))
14147 (setq files (cdr files)))
14148 (setq gnus-internal-global-score-files out)))
14149
14150;; Allow redefinition of Gnus functions.
14151
14152(gnus-ems-redefine)
14153
14154(provide 'gnus)
44cdca98
RS
14155
14156;;; gnus.el ends here