From: morioka Date: Thu, 27 Nov 1997 07:18:20 +0000 (+0000) Subject: Quassia Gnus v0.11. X-Git-Tag: qgnus-0_11 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=4c2e20a67169654caf07221554d9e637d3f7bbfa;p=elisp%2Fgnus.git- Quassia Gnus v0.11. --- 4c2e20a67169654caf07221554d9e637d3f7bbfa diff --git a/GNUS-NEWS b/GNUS-NEWS new file mode 100644 index 0000000..cfa841d --- /dev/null +++ b/GNUS-NEWS @@ -0,0 +1,53 @@ +** Gnus changes. + +*** The Gnus alpha distribution no longer bundles Custom and Widget. +If your Emacs doesn't come with these libraries, fetch them from +. You also then need to +add the following to the lisp/dgnushack.el file: + + (push "~/lisp/custom" load-path) + +Modify to suit your needs. + +*** New functionality for using Gnus as an offline newsreader has been +added. A plethora of new commands and modes have been added. See the +Gnus manual for the full story. + +*** The nndraft backend has returned, but works differently than +before. All Message buffers are now also articles in the nndraft +group, which is created automatically. + +*** `gnus-alter-header-function' can now be used to alter header +values. + +*** `gnus-summary-goto-article' now accept Message-ID's. + +*** A new Message command for deleting text in the body of a message +outside the region: `C-c C-v'. + +*** You can now post to component group in nnvirtual groups with +`C-u C-c C-c'. + +*** `nntp-rlogin-program' -- new variable to ease customization. + +*** `C-u C-c C-c' in `gnus-article-edit-mode' will now inhibit +re-highlighting of the article buffer. + +*** New element in `gnus-boring-article-headers' -- `long-to'. + +*** `M-i' symbolic prefix command. See the section "Symbolic +Prefixes" in the Gnus manual for details. + +*** `L' and `I' in the summary buffer now take the symbolic prefix +`a' to add the score rule to the "all.SCORE" file. + +*** `gnus-simplify-subject-functions' variable to allow greater +control over simplification. + +*** `A T' -- new command for fetching the current thread. + +*** `/ T' -- new command for including the current thread in the +limit. + +*** `M-RET' is a new Message command for breaking cited text. + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..05503f4 --- /dev/null +++ b/Makefile @@ -0,0 +1,36 @@ +EMACS=emacs +XEMACS=xemacs + +all: lick info + +lick: + cd lisp; $(MAKE) EMACS=$(EMACS) all + +# Rule for Lars and nobody else. +some: + cd lisp; $(MAKE) EMACS=$(EMACS) some +l: + cd lisp; $(MAKE) EMACS=$(EMACS) clever + +info: + cd texi; $(MAKE) EMACS=$(EMACS) all + +clean: + rm -f */*.orig */*.rej *.orig *.rej + +xsome: + cd lisp; $(MAKE) EMACS=$(XEMACS) some + +elclean: + rm lisp/*.elc + +x: + make EMACS=xemacs + +distclean: + make clean + rm -r *~ + for i in lisp texi; do (cd $$i; make distclean); done + +osome: + make EMACS=emacs-19.34 some diff --git a/etc/gnus-tut.txt b/etc/gnus-tut.txt new file mode 100644 index 0000000..94e9500 --- /dev/null +++ b/etc/gnus-tut.txt @@ -0,0 +1,294 @@ +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: So you want to use the new Gnus +Message-ID: + +Actually, since you are reading this, chances are you are already +using the new Gnus. Congratulations. + +This entire newsgroup you are reading is, in fact, no real newsgroup +at all, in the traditional sense. It is an example of one of the +"foreign" select methods that Gnus may use. + +The text you are now reading is stored in the "etc" directory with the +rest of the Emacs sources. You are using the "nndoc" backend for +accessing it. Scary, isn't it? + +This isn't the real documentation. `M-x info', `m gnus ' to read +that. This "newsgroup" is intended as a kinder, gentler way of getting +people started. + +Gnus is a rewrite of GNUS 4.1, written by Masanobu Umeda. The rewrite +was done by moi, yours truly, your humble servant, Lars Magne +Ingebrigtsen. If you have a WWW browser, you can investigate to your +heart's delight at . + +;; Copyright (C) 1995 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: Starting up +Message-ID: + +If you are having problems with Gnus not finding your server, you have +to set `gnus-select-method'. A "method" is a way of specifying *how* +the news is to be found, and from *where*. + +Say you want to read news from you local, friendly nntp server +"news.my.local.server". + +(setq gnus-select-method '(nntp "news.my.local.server")) + +Quite easy, huh? + +From the news spool: + +(setq gnus-select-method '(nnspool "")) + +From your mh-e spool: + +(setq gnus-select-method '(nnmh "")) + +There's a whole bunch of other methods for reading mail and news, see +the "Foreign groups" article for that. + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: Where are all the groups, then? +Message-ID: + +If this is the first time you have used a newsreader, you won't have a +.newsrc file. This means that Gnus will think that all the newsgroups +on the server are "new", and kill them all. + +If you have a .newsrc file, the new groups will be processed with the +function in the `gnus-subscribe-newsgroup-method' variable, which is +`gnus-subscribe-zombies' by default. + +This means that all the groups have been made into "zombies" - not +quite dead, but not exactly alive, either. + +Jump back to the *Group* buffer, and type `A z' to list all the zombie +groups. Look though the list, and subscribe to the groups you want to +read by pressing `u' on the one you think look interesting. + +If all the groups have been killed, type `A k' to list all the killed +groups. Subscribe to them the same way. + +When you are satisfied, press `S z' to kill all the zombie groups. + +Now you should have a nice list of all groups you are interested in. + +(If you later want to subscribe to more groups, press `A k' to +list all the kill groups, and repeat. You can also type `U' and be +prompted for groups to subscribe to.) + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: I want to read my mail! +Message-ID: + +Yes, Virginia, you can read mail with Gnus. + +First you have to decide which mail backend you want to use. You have +nnml, which is a one-file-one-mail backend, which is quite nice, but +apt to make your systems administrator go crazy and come after you +with a shotgun. + +nnmbox uses a Unix mail box to store mail. Nice, but slow. + +nnmh uses mh-e folders, which is also a one-file-one-mail thingie, but +slower than nnml. (It doesn't support NOV files.) + +So if you want to go with nnmbox, you can simply say: + +(setq gnus-secondary-select-methods '((nnmbox ""))) + +(The same for the other methods, kind of.) + +You should also set `nnmail-split-methods' to something sensible: + +(setq nnmail-split-methods + '(("mail.junk" "From:.*Lars") + ("mail.misc ""))) + +This will put all mail from me in you junk mail group, and the rest in +"mail.misc". + +These groups will be subscribe the same way as the normal groups, so +you will probably find them among the zombie groups after you set +these variables and re-start Gnus. + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: Foreign newsgroups +Message-ID: + +These are groups that do not come from `gnus-select-method'. + +Say you want to read "alt.furniture.couches" from "news.funet.fi". You +can then either type `B news.funet.fi ' to browse that server and +subscribe to that group, or you can type +`G m alt.furniture.couchesnntpnews.funet.fi', if you +like to type a lot. + +If you want to read a directory as a newsgroup, you can create an +nndir group, much the same way. There's a shorthand for that, +though. If, for instance, you want to read the (ding) list archives, +you could type `G d /ftp '. + +There's lots more to know about foreign groups, but you have to read +the info pages to find out more. + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: Low level changes in GNUS, or, Wrong type argument: stringp, nil +Message-ID: + +Gnus really isn't GNUS, even though it looks like it. If you scrape +the surface, you'll find that most things have changed. + +This means that old code that relies on GNUS internals will fail. + +In particular, `gnus-newsrc-hashtb', `gnus-newsrc-assoc', +`gnus-killed-list', the `nntp-header-' macros and the display formats +have all changed. If you have some code lying around that depend on +these, or change these, you'll have to re-write your code. + +Old hilit19 code does not work at all. In fact, you should probably +remove all hilit code from all the Gnus hooks +(`gnus-group-prepare-hook', `gnus-summary-prepare-hook' and +`gnus-summary-article-hook'). (Well, at the very least the first +two.) Gnus provides various integrated functions for highlighting, +which are both faster and more accurated. + +There is absolutely no chance, whatsoever, of getting Gnus to work +with Emacs 18. It won't even work on Emacsen older than Emacs +19.30/XEmacs 19.13. Upgrade your Emacs or die. + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: How do I re-scan my mail groups? +Message-ID: + +Reading the active file from the nntp server is a drag. + +Just press `M-g' on the mail groups, and they will be re-scanned. + +You can also re-scan all the mail groups by putting them on level 1 +(`S l 1'), and saying `1 g' to re-scan all level 1 groups. + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: How do I set up virtual newsgroups? +Message-ID: + +Virtual newsgroups are collections of other newsgroups. Why people +want this is beyond me, but here goes: + +Create the group by saying + +`M-a my.virtual.newsgroupnnvirtual^rec\.aquaria\.*' + +This will create the group "nnvirtual:my.virtual.newsgroup", which +will collect all articles from all the groups in the "rec.aquaria" +hierarchy. + +If you want to edit the regular expression, just type `M-e' on the +group line. + +Note that all the groups that are part of the virtual group have to be +alive. This means that the cannot, absolutely not, be zombie or +killed. They can be unsubscribed; that's no problem. + +You can combine groups from different servers in the same virtual +newsgroup, something that may actually be useful. Say you have the +group "comp.headers" on the server "news.server.no" and the same group +on "news.server.edu". If people have posted articles with Distribution +headers that stop propagation of their articles, combining these two +newsgroups into one virtual newsgroup should give you a better view of +what's going on. + +One caveat, though: The virtual group article numbers from the first +source group (group A) will always be lower than the article numbers +from the second (group B). This means that Gnus will believe that +articles from group A are older than articles from group B. Threading +will lessen these problems, but it might be a good idea to sort the +threads over the date of the articles to get a correct feel for the +flow of the groups: + +(setq gnus-thread-sort-functions '(gnus-thread-sort-by-date)) + +If you only want this in virtual groups, you could say something along +the lines of: + +(setq gnus-select-group-hook + (lambda () + (if (eq 'nnvirtual (car (gnus-find-method-for-group + gnus-newsgroup-name))) + (progn + (make-local-variable 'gnus-thread-sort-functions) + (setq gnus-thread-sort-functions '(gnus-thread-sort-by-date)))))) + + +From lars Thu Feb 23 23:20:38 1995 +From: larsi@ifi.uio.no (ding) +Date: Fri Feb 24 13:40:45 1995 +Subject: Bugs & stuff +Message-ID: + +If you want to report a bug, please type `M-x gnus-bug'. This will +give me a precise overview of your Gnus and Emacs version numbers, +along with a look at all Gnus variables you have changed. + +Du not expect a reply back, but your bug should be fixed in the next +version. If the bug persists, please re-submit your bug report. + +When a bug occurs, I need a recipe for how to trigger the bug. You +have to tell me exactly what you do to uncover the bug, and you should +(setq debug-on-error t) and send me the backtrace along with the bug +report. + +If I am not able to reproduce the bug, I won't be able to fix it. + +I would, of course, prefer that you locate the bug, fix it, and mail +me the patches, but one can't have everything. + +If you have any questions on usage, the "ding@ifi.uio.no" mailing list +is where to post the questions. + + diff --git a/lisp/ChangeLog b/lisp/ChangeLog new file mode 100644 index 0000000..3a3d50b --- /dev/null +++ b/lisp/ChangeLog @@ -0,0 +1,364 @@ +Sat Sep 13 21:21:38 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.1 is released. + +Sat Sep 27 04:32:45 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.11 is released. + +Sat Sep 27 03:50:12 1997 Lars Magne Ingebrigtsen + + * message.el (message-send): Post without asking. + (message-mode): Modify paragraphs-start and paragraph-separate. + (message-newline-and-reformat): New command and keystroke. + +Thu Sep 25 00:13:41 1997 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-activate): Init server buffer. + +Wed Sep 24 04:11:59 1997 Lars Magne Ingebrigtsen + + * gnus-draft.el (gnus-draft-setup): Inexplicable binding problem + worked around. + + * nnsoup.el (nnsoup-always-save): Renamed. + +Wed Sep 24 04:11:02 1997 Nelson Jose dos Santos Ferreira + + * nnsoup.el (nnsoup-commit-reply-now): New variable. + (nnsoup-store-reply): Use it. + +Wed Sep 24 02:30:44 1997 Lars Magne Ingebrigtsen + + * gnus-ems.el (gnus-deactivate-mark): New alias. + +Tue Sep 23 07:56:07 1997 Lars Magne Ingebrigtsen + + * gnus.el: Win-away! + + * gnus-msg.el (gnus-setup-message): Don't trust make-symbol. + +Tue Sep 23 07:45:11 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.10 is released. + +Tue Sep 23 01:41:04 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-read-all-headers): New function. + (gnus-select-newsgroup): Use it. + (gnus-summary-refer-thread): Ditto. + (gnus-refer-thread-limit): New variable. + (gnus-summary-refer-thread): Use it. + + * gnus-nocem.el (gnus-nocem-message-wanted-p): New function. + (gnus-nocem-check-article): Use it. + (gnus-nocem-issuers): Dox ofx. + + * dgnushack.el (dgnushack-compile): Check for cus-edit. + + * message.el (message-included-forward-headers): Include Mime + headers. + (message-send): Allow posting without confirming from Agent. + +Mon Sep 22 05:43:14 1997 Lars Magne Ingebrigtsen + + * dgnushack.el (byte-compile-warnings): Don't warn about obsolete + variables. + + * gnus-sum.el (gnus-summary-refer-thread): New command and + keystroke. + (gnus-summary-limit-include-thread): New command and keystroke. + (gnus-summary-articles-in-thread): New function. + (gnus-articles-in-thread): Renamed. + +Sun Sep 21 23:54:50 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.9 is released. + +Sun Sep 21 23:38:46 1997 Lars Magne Ingebrigtsen + + * gnus.el (gnus-splash-face): ForestGreen everywhere. + + * gnus-sum.el (gnus-simplify-subject-fully): Use new variable. + (gnus-general-simplify-subject): Ditto. + +Sun Sep 21 23:34:13 1997 Kurt Swanson + + * gnus-sum.el (gnus-simplify-subject-functions): New variable. + (gnus-simplify-whitespace): New function. + + * gnus-util.el (gnus-map-function): New function. + +Sun Sep 21 23:22:04 1997 Michelangelo Grigni + + * gnus-score.el (gnus-score-regexp-bad-p): New function. + +Sun Sep 21 00:14:40 1997 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-summary-lower-score): Use sym pref. + (gnus-summary-increase-score): Use it. + + * gnus.el (gnus-current-prefix-symbol): New variable. + (gnus-current-prefix-symbols): New variable. + + * gnus-score.el (gnus-summary-increase-score): Take symbolic + prefix. + + * gnus.el (gnus-interactive): Removed. + (gnus-interactive): Renamed from gnus-interactive-1. + (gnus-symbolic-argument): New command. + + * gnus-draft.el (gnus-draft-send-message): Disable message + checks. + (gnus-draft-send): Ditto. + (gnus-draft-setup): Don't save buffer. + + * dgnushack.el (dgnushack-compile): Warn people about Custom. + + * gnus-group.el (gnus-group-iterate): Use gensymmed variables. + + * pop3.el (pop3-md5): `with-temp-buffer' doesn't exist in Emacs + 19.34. + + * nneething.el (nneething-directory): Defvarred. + + * message.el: Autoloaded nndraft things. + (message-set-auto-save-file-name): Use it. + + * dgnushack.el (dgnushack-compile): Warn about things. + + * gnus-art.el: Autoload w3-region. + + * gnus-vm.el (gnus-summary-save-in-vm): Simplified. + + * gnus.el: Changed `compiled-function-p' to `byte-code-function-p' + throughout. + + * gnus-sum.el (gnus-summary-edit-article): Supply additional + param. + + * gnus-group.el (gnus-group-iterate): Undo bogus change. + + * gnus-agent.el (gnus-agentize): Just call gnus-open-agent + directly. + + * gnus.el (gnus-interactive): New macro. + (gnus-interactive-1): New function. + + * gnus-sum.el (gnus-fetch-old-headers): Allow `invisible'. + (gnus-cut-thread): Use it. + (gnus-cut-threads): Ditto. + (gnus-summary-initial-limit): Ditto. + (gnus-summary-limit-children): Ditto. + + * gnus-art.el (gnus-article-edit-done): Accept a prefix arg. + (gnus-boring-article-headers): Allow `long-to' param. + (article-hide-boring-headers): Use it. + + * gnus-sum.el (gnus-summary-edit-article-done): Accept a + no-highlight param. + + * nntp.el (nntp-rlogin-program): New variable. + (nntp-open-rlogin): Use it. + + * nnvirtual.el (nnvirtual-request-post): New function. + + * gnus-msg.el (gnus-message-group-art): New variable. + + * gnus-draft.el (gnus-draft-setup): Don't use message-setup. + + * nndraft.el (nndraft): Allow editing articles. + + * gnus-ems.el (gnus-x-splash): Ditto. + + * gnus.el (gnus-splash-face): Darker face. + + * gnus-draft.el (gnus-draft-setup): Clobbered variables. + +Sat Sep 20 23:23:49 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.8 is released. + +Sat Sep 20 20:41:16 1997 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-setup-news-hook): New hook. + + * gnus-agent.el (gnus-agentize): Really set up queue group. + (gnus-open-agent): Setup queue here. + +Sat Sep 20 20:23:07 1997 Matt Simmons + + * message.el (message-set-auto-save-file-name): Make things work + without drafts. + +Sat Sep 20 18:32:02 1997 Lars Magne Ingebrigtsen + + * nnmh.el (nnmh-request-list-1): Check for links to ".". + + * nndraft.el (nndraft-possibly-change-group): New function. + + * gnus-agent.el (gnus-agent-queue-setup): New function. + +Thu Sep 18 04:54:59 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.7 is released. + +Thu Sep 18 03:33:54 1997 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-setup-message): Slap a progn around forms. + + * nndraft.el (nndraft-articles): Make sure directory exists. + + * message.el (message-mode): Don't delete article. + + * nnmh.el (nnmh-request-accept-article): Don't save when + noinsert. + +Wed Sep 17 03:37:59 1997 Lars Magne Ingebrigtsen + + * nndraft.el (nndraft-directory): Changed defaults. + + * gnus-agent.el (gnus-agent-fetch-session): Bind command method. + +Wed Sep 17 03:28:36 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.6 is released. + +1997-08-17 SL Baur + + * dgnushack.el (dgnushack-compile): Ignore .el files beginning + with an `=' character. + +Wed Sep 17 02:30:04 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-build-sparse-threads): Allow display of looped + References. + + * gnus-agent.el (gnus-agent-fetch-group-1): Separated out into + function. + + * message.el (message-delete-not-region): New command and + keystroke. + +Tue Sep 16 00:58:26 1997 Lars Magne Ingebrigtsen + + * nndraft.el (nndraft-directory): Changed value. + + * message.el (message-kill-buffer): Disassociate draft. + (message-mode): Use kill hook to disassociate. + (message-disassociate-draft): Double-check. + + * gnus-agent.el (gnus-agentize): Don't set twice. + + * gnus-art.el (gnus-article-prepare): Go to the right line before + marking. + + * gnus-start.el: Renamed the drafts group. + + * gnus-agent.el (gnus-agent-lib-file): Changed name of directory. + + * gnus-draft.el (gnus-draft-mode): Simplify. + +Tue Sep 16 00:18:11 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.5 is released. + +Mon Sep 15 00:53:50 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-alter-header-function): New variable. + (gnus-nov-parse-line): Use it. + (gnus-get-newsgroup-headers): Ditto. + + * gnus-draft.el (gnus-group-send-drafts): Don't send when + unplugged. + + * gnus-sum.el (gnus-summary-read-group): Don't show-all when + skipping groups. + + * gnus-start.el (gnus-start-draft-setup): Changed name. + +Mon Sep 15 00:40:09 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.4 is released. + +Mon Sep 15 00:19:07 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-goto-article): Accept Message-ID's. + +Sun Sep 14 21:41:35 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-group-make-articles-read): No params. + + * nndraft.el (nndraft-status-string): Fix. + + * gnus-draft.el (gnus-group-send-drafts): New command. + + * gnus-sum.el (gnus-compute-read-articles): Separated. + (gnus-update-read-articles): Allow computation. + + * nndraft.el (nndraft-articles): New function. + + * message.el (message-send): Disabled test. + +Sun Sep 14 21:17:34 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.3 is released. + +Sun Sep 14 01:51:45 1997 Lars Magne Ingebrigtsen + + * gnus-agent.el (gnus-agent-short-article): New variables. + + * message.el (message-set-auto-save-file-name): Use drafts. + + * nndraft.el (nndraft-request-expire-articles): Use it. + + * nnmh.el (nnmh-deletable-article-p): Change. + (nnmh-allow-delete-final): New variable. + + * gnus-msg.el (gnus-summary-send-draft): Removed. + + * gnus.el (gnus-article-mark-lists): Save unsendable marks. + + * gnus-sum.el (gnus-newsgroup-unsendable): New variable. + + * gnus-draft.el: New file. + + * gnus-sum.el (gnus-unsendable-mark): New variable. + + * nndraft.el (nndraft-execute-nnmh-command): Cleanup. + + * message.el (message-send-news): Use `gnus-request-post'. + + * gnus-agent.el (gnus-agentize): New command. + + * gnus-bcklg.el (gnus-backlog-remove-article): Remove the ident + from the list. + +Sun Sep 14 00:26:47 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.2 is released. + +Sun Sep 14 00:24:52 1997 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-score-headers): Make sure the summary buffer + exists. + +Sat Sep 13 23:35:28 1997 Greg Stark + + * gnus-ems.el (gnus-x-splash): New function. + +Sat Sep 13 22:46:16 1997 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-1): Use it. + + * gnus-ems.el (gnus-decode-coding-string): New alias. + + * message.el (message-unix-mail-delimiter): Dox fox. + + * nnmh.el (nnmh-request-list-1): Don't use coding system. + + * gnus-sum.el (gnus-summary-catchup): Reverse logic. + +Sat Sep 13 21:21:38 1997 Lars Magne Ingebrigtsen + + * gnus.el: Quassia Gnus v0.1 is released. diff --git a/lisp/Makefile b/lisp/Makefile new file mode 100644 index 0000000..b949400 --- /dev/null +++ b/lisp/Makefile @@ -0,0 +1,40 @@ +SHELL = /bin/sh +EMACS=emacs +FLAGS=-batch -q -no-site-file -l ./dgnushack.el + +total: + rm -f *.elc ; $(EMACS) $(FLAGS) -f dgnushack-compile + +all: + rm -f *.elc ; $(EMACS) $(FLAGS) -f dgnushack-compile + +clever: + $(EMACS) $(FLAGS) -f dgnushack-compile + +some: + $(EMACS) $(FLAGS) -f dgnushack-compile + +tags: + etags *.el + +separately: + rm -f *.elc ; for i in *.el; do $(EMACS) $(FLAGS) -f batch-byte-compile $$i; done + +pot: + xpot -drgnus -r`cat ./version` *.el > rgnus.pot + +gnus-load.el: + echo ";;; gnus-load.el --- automatically extracted custom dependencies" > gnus-load.el + echo ";;" >> gnus-load.el + echo ";;; Code:" >> gnus-load.el + echo >> gnus-load.el + $(EMACS) $(FLAGS) -l ./dgnushack.el -l cus-edit.el *.el \ + -f custom-make-dependencies >> gnus-load.el + echo >> gnus-load.el + echo "(provide 'gnus-load)" >> gnus-load.el + echo >> gnus-load.el + echo ";;; gnus-load.el ends here" >> gnus-load.el + +distclean: + rm -f *.orig *.rej *.elc *~ + diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el new file mode 100644 index 0000000..ba6a73b --- /dev/null +++ b/lisp/dgnushack.el @@ -0,0 +1,88 @@ +;;; dgnushack.el --- a hack to set the load path for byte-compiling +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Version: 4.19 +;; Keywords: news, path + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(fset 'facep 'ignore) + +(require 'cl) +(require 'bytecomp) +(push "." load-path) +(push "~/lisp/custom" load-path) +(require 'lpath) + +(defalias 'device-sound-enabled-p 'ignore) +(defalias 'play-sound-file 'ignore) +(defalias 'nndb-request-article 'ignore) +(defalias 'efs-re-read-dir 'ignore) +(defalias 'ange-ftp-re-read-dir 'ignore) +(defalias 'define-mail-user-agent 'ignore) + +(eval-and-compile + (unless (string-match "XEmacs" emacs-version) + (fset 'get-popup-menu-response 'ignore) + (fset 'event-object 'ignore) + (fset 'x-defined-colors 'ignore) + (fset 'read-color 'ignore))) + +(setq byte-compile-warnings + '(free-vars unresolved callargs redefine)) + +(defun dgnushack-compile () + ;;(setq byte-compile-dynamic t) + (unless (locate-library "cus-edit") + (error "You do not seem to have Custom installed. +Fetch it from . +You also then need to add the following to the lisp/dgnushack.el file: + + (push \"~/lisp/custom\" load-path) + +Modify to suit your needs.")) + (let ((files (directory-files "." nil "^[^=].*\\.el$")) + (xemacs (string-match "XEmacs" emacs-version)) + ;;(byte-compile-generate-call-tree t) + file elc) + (condition-case () + (require 'w3-forms) + (error (setq files (delete "nnweb.el" files)))) + (while (setq file (pop files)) + (when (or (and (not xemacs) + (not (member file '("gnus-xmas.el" "gnus-picon.el" + "messagexmas.el" "nnheaderxm.el" + "smiley.el" "x-overlay.el")))) + (and xemacs + (not (member file '("md5.el"))))) + (when (or (not (file-exists-p (setq elc (concat file "c")))) + (file-newer-than-file-p file elc)) + (ignore-errors + (byte-compile-file file))))))) + +(defun dgnushack-recompile () + (require 'gnus) + (byte-recompile-directory "." 0)) + +;;; dgnushack.el ends here + diff --git a/lisp/earcon.el b/lisp/earcon.el new file mode 100644 index 0000000..ee2b041 --- /dev/null +++ b/lisp/earcon.el @@ -0,0 +1,245 @@ +;;; earcon.el --- Sound effects for messages +;; Copyright (C) 1996 Free Software Foundation + +;; Author: Steven L. Baur +;; Keywords: news fun sound + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; This file provides access to sound effects in Gnus. + +;;; Code: + +(if (null (boundp 'running-xemacs)) + (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) + +(eval-when-compile (require 'cl)) +(require 'gnus) +(require 'gnus-audio) +(require 'gnus-art) + +(defgroup earcon nil + "Turn ** sounds ** into noise." + :group 'gnus-visual) + +(defcustom earcon-auto-play nil + "When True, automatically play sounds as well as buttonize them." + :type 'boolean + :group 'earcon) + +(defcustom earcon-prefix "**" + "String denoting the start of an earcon." + :type 'string + :group 'earcon) + +(defcustom earcon-suffix "**" + "String denoting the end of an earcon." + :type 'string + :group 'earcon) + +(defcustom earcon-regexp-alist + '(("boring" 1 "Boring.au") + ("evil[ \t]+laugh" 1 "Evil_Laugh.au") + ("gag\\|puke" 1 "Puke.au") + ("snicker" 1 "Snicker.au") + ("meow" 1 "catmeow.au") + ("sob\\|boohoo" 1 "cry.wav") + ("drum[ \t]*roll" 1 "drumroll.au") + ("blast" 1 "explosion.au") + ("flush\\|plonk!*" 1 "flush.au") + ("kiss" 1 "kiss.wav") + ("tee[ \t]*hee" 1 "laugh.au") + ("shoot" 1 "shotgun.wav") + ("yawn" 1 "snore.wav") + ("cackle" 1 "witch.au") + ("yell\\|roar" 1 "yell2.au") + ("whoop-de-doo" 1 "whistle.au")) + "A list of regexps to map earcons to real sounds." + :type '(repeat (list regexp + (integer :tag "Match") + (string :tag "Sound"))) + :group 'earcon) + +(defvar earcon-button-marker-list nil) +(make-variable-buffer-local 'earcon-button-marker-list) + + + +;;; FIXME!! clone of code from gnus-vis.el FIXME!! +(defun earcon-article-push-button (event) + "Check text under the mouse pointer for a callback function. +If the text under the mouse pointer has a `earcon-callback' property, +call it with the value of the `earcon-data' text property." + (interactive "e") + (set-buffer (window-buffer (posn-window (event-start event)))) + (let* ((pos (posn-point (event-start event))) + (data (get-text-property pos 'earcon-data)) + (fun (get-text-property pos 'earcon-callback))) + (if fun (funcall fun data)))) + +(defun earcon-article-press-button () + "Check text at point for a callback function. +If the text at point has a `earcon-callback' property, +call it with the value of the `earcon-data' text property." + (interactive) + (let* ((data (get-text-property (point) 'earcon-data)) + (fun (get-text-property (point) 'earcon-callback))) + (if fun (funcall fun data)))) + +(defun earcon-article-prev-button (n) + "Move point to N buttons backward. +If N is negative, move forward instead." + (interactive "p") + (earcon-article-next-button (- n))) + +(defun earcon-article-next-button (n) + "Move point to N buttons forward. +If N is negative, move backward instead." + (interactive "p") + (let ((function (if (< n 0) 'previous-single-property-change + 'next-single-property-change)) + (inhibit-point-motion-hooks t) + (backward (< n 0)) + (limit (if (< n 0) (point-min) (point-max)))) + (setq n (abs n)) + (while (and (not (= limit (point))) + (> n 0)) + ;; Skip past the current button. + (when (get-text-property (point) 'earcon-callback) + (goto-char (funcall function (point) 'earcon-callback nil limit))) + ;; Go to the next (or previous) button. + (gnus-goto-char (funcall function (point) 'earcon-callback nil limit)) + ;; Put point at the start of the button. + (when (and backward (not (get-text-property (point) 'earcon-callback))) + (goto-char (funcall function (point) 'earcon-callback nil limit))) + ;; Skip past intangible buttons. + (when (get-text-property (point) 'intangible) + (incf n)) + (decf n)) + (unless (zerop n) + (gnus-message 5 "No more buttons")) + n)) + +(defun earcon-article-add-button (from to fun &optional data) + "Create a button between FROM and TO with callback FUN and data DATA." + (and (boundp gnus-article-button-face) + gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay from to) + 'face gnus-article-button-face)) + (gnus-add-text-properties + from to + (nconc (and gnus-article-mouse-face + (list gnus-mouse-face-prop gnus-article-mouse-face)) + (list 'gnus-callback fun) + (and data (list 'gnus-data data))))) + +(defun earcon-button-entry () + ;; Return the first entry in `gnus-button-alist' matching this place. + (let ((alist earcon-regexp-alist) + (case-fold-search t) + (entry nil)) + (while alist + (setq entry (pop alist)) + (if (looking-at (car entry)) + (setq alist nil) + (setq entry nil))) + entry)) + + +(defun earcon-button-push (marker) + ;; Push button starting at MARKER. + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char marker) + (let* ((entry (earcon-button-entry)) + (inhibit-point-motion-hooks t) + (fun 'gnus-audio-play) + (args (list (nth 2 entry)))) + (cond + ((fboundp fun) + (apply fun args)) + ((and (boundp fun) + (fboundp (symbol-value fun))) + (apply (symbol-value fun) args)) + (t + (gnus-message 1 "You must define `%S' to use this button" + (cons fun args))))))) + +;;; FIXME!! clone of code from gnus-vis.el FIXME!! + +;;;###interactive +(defun earcon-region (beg end) + "Play Sounds in the region between point and mark." + (interactive "r") + (earcon-buffer (current-buffer) beg end)) + +;;;###interactive +(defun earcon-buffer (&optional buffer st nd) + (interactive) + (save-excursion + ;; clear old markers. + (if (boundp 'earcon-button-marker-list) + (while earcon-button-marker-list + (set-marker (pop earcon-button-marker-list) nil)) + (setq earcon-button-marker-list nil)) + (and buffer (set-buffer buffer)) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist earcon-regexp-alist) + beg entry regexp) + (goto-char (point-min)) + (setq beg (point)) + (while (setq entry (pop alist)) + (setq regexp (concat (regexp-quote earcon-prefix) + ".*\\(" + (car entry) + "\\).*" + (regexp-quote earcon-suffix))) + (goto-char beg) + (while (re-search-forward regexp nil t) + (let* ((start (and entry (match-beginning 1))) + (end (and entry (match-end 1))) + (from (match-beginning 1))) + (earcon-article-add-button + start end 'earcon-button-push + (car (push (set-marker (make-marker) from) + earcon-button-marker-list))) + (gnus-audio-play (caddr entry)))))))) + +;;;###autoload +(defun gnus-earcon-display () + "Play sounds in message buffers." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + ;; Skip headers + (unless (search-forward "\n\n" nil t) + (goto-char (point-max))) + (sit-for 0) + (earcon-buffer (current-buffer) (point)))) + +;;;*** + +(provide 'earcon) + +(run-hooks 'earcon-load-hook) + +;;; earcon.el ends here diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el new file mode 100644 index 0000000..721b92b --- /dev/null +++ b/lisp/gnus-agent.el @@ -0,0 +1,1244 @@ +;;; gnus-agent.el --- unplugged support for Gnus +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-cache) +(require 'nnvirtual) +(require 'gnus-sum) +(eval-when-compile (require 'cl)) + +(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") + "Where the Gnus agent will store its files." + :group 'gnus-agent + :type 'directory) + +(defcustom gnus-agent-plugged-hook nil + "Hook run when plugging into the network." + :group 'gnus-agent + :type 'hook) + +(defcustom gnus-agent-unplugged-hook nil + "Hook run when unplugging from the network." + :group 'gnus-agent + :type 'hook) + +;;; Internal variables + +(defvar gnus-agent-history-buffers nil) +(defvar gnus-agent-buffer-alist nil) +(defvar gnus-agent-article-alist nil) +(defvar gnus-agent-group-alist nil) +(defvar gnus-agent-covered-methods nil) +(defvar gnus-category-alist nil) +(defvar gnus-agent-current-history nil) +(defvar gnus-agent-overview-buffer nil) +(defvar gnus-category-predicate-cache nil) +(defvar gnus-category-group-cache nil) +(defvar gnus-agent-spam-hashtb nil) +(defvar gnus-agent-file-name nil) +(defvar gnus-agent-send-mail-function nil) + +(defvar gnus-plugged t + "Whether Gnus is plugged or not.") + +;; Dynamic variables +(defvar gnus-headers) +(defvar gnus-score) + +;;; +;;; Setup +;;; + +(defun gnus-open-agent () + (setq gnus-agent t) + (gnus-agent-read-servers) + (gnus-category-read) + (setq gnus-agent-overview-buffer + (get-buffer-create " *Gnus agent overview*")) + (add-hook 'gnus-group-mode-hook 'gnus-agent-mode) + (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode) + (add-hook 'gnus-server-mode-hook 'gnus-agent-mode)) + +(gnus-add-shutdown 'gnus-close-agent 'gnus) + +(defun gnus-close-agent () + (setq gnus-agent-covered-methods nil + gnus-category-predicate-cache nil + gnus-category-group-cache nil + gnus-agent-spam-hashtb nil) + (gnus-kill-buffer gnus-agent-overview-buffer)) + +;;; +;;; Utility functions +;;; + +(defun gnus-agent-read-file (file) + "Load FILE and do a `read' there." + (nnheader-temp-write nil + (ignore-errors + (insert-file-contents file) + (goto-char (point-min)) + (read (current-buffer))))) + +(defsubst gnus-agent-method () + (concat (symbol-name (car gnus-command-method)) "/" + (if (equal (cadr gnus-command-method) "") + "unnamed" + (cadr gnus-command-method)))) + +(defsubst gnus-agent-directory () + "Path of the Gnus agent directory." + (nnheader-concat gnus-agent-directory (gnus-agent-method) "/")) + +(defun gnus-agent-lib-file (file) + "The full path of the Gnus agent library FILE." + (concat (gnus-agent-directory) "agent.lib/" file)) + +;;; +;;; Mode infestation +;;; + +(defvar gnus-agent-mode-hook nil + "Hook run when installing agent mode.") + +(defvar gnus-agent-mode nil) +(defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged")) + +(defun gnus-agent-mode () + "Minor mode for providing a agent support in Gnus buffers." + (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$" + (symbol-name major-mode)) + (match-string 1 (symbol-name major-mode)))) + (mode (intern (format "gnus-agent-%s-mode" buffer)))) + (set (make-local-variable 'gnus-agent-mode) t) + (set mode nil) + (set (make-local-variable mode) t) + ;; Set up the menu. + (when (gnus-visual-p 'agent-menu 'menu) + (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer)))) + (unless (assq 'gnus-agent-mode minor-mode-alist) + (push gnus-agent-mode-status minor-mode-alist)) + (unless (assq mode minor-mode-map-alist) + (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" + buffer)))) + minor-mode-map-alist)) + (gnus-agent-toggle-plugged gnus-plugged) + (run-hooks 'gnus-agent-mode-hook))) + +(defvar gnus-agent-group-mode-map (make-sparse-keymap)) +(gnus-define-keys gnus-agent-group-mode-map + "Ju" gnus-agent-fetch-group + "Jc" gnus-enter-category-buffer + "Jj" gnus-agent-toggle-plugged + "Js" gnus-agent-fetch-session + "JS" gnus-group-send-drafts + "Ja" gnus-agent-add-group) + +(defun gnus-agent-group-make-menu-bar () + (unless (boundp 'gnus-agent-group-menu) + (easy-menu-define + gnus-agent-group-menu gnus-agent-group-mode-map "" + '("Agent" + ["Toggle plugged" gnus-agent-toggle-plugged t] + ["List categories" gnus-enter-category-buffer t] + ["Send drafts" gnus-group-send-drafts gnus-plugged] + ("Fetch" + ["All" gnus-agent-fetch-session gnus-plugged] + ["Group" gnus-agent-fetch-group gnus-plugged]))))) + +(defvar gnus-agent-summary-mode-map (make-sparse-keymap)) +(gnus-define-keys gnus-agent-summary-mode-map + "Jj" gnus-agent-toggle-plugged + "J#" gnus-agent-mark-article + "J\M-#" gnus-agent-unmark-article + "@" gnus-agent-toggle-mark + "Jc" gnus-agent-catchup) + +(defun gnus-agent-summary-make-menu-bar () + (unless (boundp 'gnus-agent-summary-menu) + (easy-menu-define + gnus-agent-summary-menu gnus-agent-summary-mode-map "" + '("Agent" + ["Toggle plugged" gnus-agent-toggle-plugged t] + ["Mark as downloadable" gnus-agent-mark-article t] + ["Unmark as downloadable" gnus-agent-unmark-article t] + ["Toggle mark" gnus-agent-toggle-mark t] + ["Catchup undownloaded" gnus-agent-catchup t])))) + +(defvar gnus-agent-server-mode-map (make-sparse-keymap)) +(gnus-define-keys gnus-agent-server-mode-map + "Jj" gnus-agent-toggle-plugged + "Ja" gnus-agent-add-server + "Jr" gnus-agent-remove-server) + +(defun gnus-agent-server-make-menu-bar () + (unless (boundp 'gnus-agent-server-menu) + (easy-menu-define + gnus-agent-server-menu gnus-agent-server-mode-map "" + '("Agent" + ["Toggle plugged" gnus-agent-toggle-plugged t] + ["Add" gnus-agent-add-server t] + ["Remove" gnus-agent-remove-server t])))) + +(defun gnus-agent-toggle-plugged (plugged) + "Toggle whether Gnus is unplugged or not." + (interactive (list (not gnus-plugged))) + (if plugged + (progn + (run-hooks 'gnus-agent-plugged-hook) + (setcar (cdr gnus-agent-mode-status) " Plugged")) + (gnus-agent-close-connections) + (run-hooks 'gnus-agent-unplugged-hook) + (setcar (cdr gnus-agent-mode-status) " Unplugged")) + (setq gnus-plugged plugged) + (set-buffer-modified-p t)) + +(defun gnus-agent-close-connections () + "Close all methods covered by the Gnus agent." + (let ((methods gnus-agent-covered-methods)) + (while methods + (gnus-close-server (pop methods))))) + +;;;###autoload +(defun gnus-unplugged () + "Start Gnus unplugged." + (interactive) + (setq gnus-plugged nil) + (gnus)) + +;;;###autoload +(defun gnus-agentize () + "Allow Gnus to be an offline newsreader. +The normal usage of this command is to put the following as the +last form in your `.gnus.el' file: + +\(gnus-agentize) + +This will modify the `gnus-before-startup-hook', `gnus-post-method', +and `message-send-mail-function' variables, and install the Gnus +agent minor mode in all Gnus buffers." + (interactive) + (gnus-open-agent) + (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) + (unless gnus-agent-send-mail-function + (setq gnus-agent-send-mail-function message-send-mail-function + message-send-mail-function 'gnus-agent-send-mail)) + (unless gnus-agent-covered-methods + (setq gnus-agent-covered-methods (list gnus-select-method)))) + +(defun gnus-agent-queue-setup () + "Make sure the queue group exists." + (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb) + (gnus-request-create-group "queue" '(nndraft "")) + (let ((gnus-level-default-subscribed 1)) + (gnus-subscribe-group "nndraft:queue" nil '(nndraft ""))) + (gnus-group-set-parameter + "nndraft:queue" 'gnus-dummy '((gnus-draft-mode))))) + +(defun gnus-agent-send-mail () + (if gnus-plugged + (funcall gnus-agent-send-mail-function) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (gnus-request-accept-article "nndraft:queue"))) + +;;; +;;; Group mode commands +;;; + +(defun gnus-agent-fetch-group (group) + "Put all new articles in GROUP into the agent." + (interactive (list (gnus-group-group-name))) + (unless group + (error "No group on the current line")) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-with-fetch + (gnus-agent-fetch-group-1 group gnus-command-method)))) + +(defun gnus-agent-add-group (category arg) + "Add the current group to an agent category." + (interactive + (list + (intern + (completing-read + "Add to category: " + (mapcar (lambda (cat) (list (symbol-name (car cat)))) + gnus-category-alist) + nil t)) + current-prefix-arg)) + (let ((cat (assq category gnus-category-alist)) + c groups) + (gnus-group-iterate arg + (lambda (group) + (when (cadddr (setq c (gnus-group-category group))) + (setf (cadddr c) (delete group (cadddr c)))) + (push group groups))) + (setf (cadddr cat) (nconc (cadddr cat) groups)) + (gnus-category-write))) + +;;; +;;; Server mode commands +;;; + +(defun gnus-agent-add-server (server) + "Enroll SERVER in the agent program." + (interactive (list (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) + (when (member method gnus-agent-covered-methods) + (error "Server already in the agent program")) + (push method gnus-agent-covered-methods) + (gnus-agent-write-servers) + (message "Entered %s into the agent" server))) + +(defun gnus-agent-remove-server (server) + "Remove SERVER from the agent program." + (interactive (list (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) + (unless (member method gnus-agent-covered-methods) + (error "Server not in the agent program")) + (setq gnus-agent-covered-methods + (delete method gnus-agent-covered-methods)) + (gnus-agent-write-servers) + (message "Removed %s from the agent" server))) + +(defun gnus-agent-read-servers () + "Read the alist of covered servers." + (setq gnus-agent-covered-methods + (gnus-agent-read-file + (nnheader-concat gnus-agent-directory "lib/servers")))) + +(defun gnus-agent-write-servers () + "Write the alist of covered servers." + (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/servers") + (prin1 gnus-agent-covered-methods (current-buffer)))) + +;;; +;;; Summary commands +;;; + +(defun gnus-agent-mark-article (n &optional unmark) + "Mark the next N articles as downloadable. +If N is negative, mark backward instead. If UNMARK is non-nil, remove +the mark instead. The difference between N and the actual number of +articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (n (abs n))) + (while (and + (> n 0) + (progn + (gnus-summary-set-agent-mark + (gnus-summary-article-number) unmark) + (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more articles")) + (gnus-summary-recenter) + (gnus-summary-position-point) + n)) + +(defun gnus-agent-unmark-article (n) + "Remove the downloadable mark from the next N articles. +If N is negative, unmark backward instead. The difference between N and +the actual number of articles unmarked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-agent-mark-article n t)) + +(defun gnus-agent-toggle-mark (n) + "Toggle the downloadable mark from the next N articles. +If N is negative, toggle backward instead. The difference between N and +the actual number of articles toggled is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-agent-mark-article n 'toggle)) + +(defun gnus-summary-set-agent-mark (article &optional unmark) + "Mark ARTICLE as downloadable." + (let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) + (memq article gnus-newsgroup-downloadable) + unmark))) + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + (unless unmark + (push article gnus-newsgroup-downloadable)) + (gnus-summary-update-mark + (if unmark gnus-undownloaded-mark gnus-downloadable-mark) + 'unread))) + +(defun gnus-agent-get-undownloaded-list () + "Mark all unfetched articles as read." + (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) + (when (and (not gnus-plugged) + (gnus-agent-method-p gnus-command-method)) + (gnus-agent-load-alist gnus-newsgroup-name) + (let ((articles gnus-newsgroup-unreads) + article) + (while (setq article (pop articles)) + (unless (or (cdr (assq article gnus-agent-article-alist)) + (memq article gnus-newsgroup-downloadable)) + (push article gnus-newsgroup-undownloaded))))))) + +(defun gnus-agent-catchup () + "Mark all undownloaded articles as read." + (interactive) + (save-excursion + (while gnus-newsgroup-undownloaded + (gnus-summary-mark-article + (pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) + (gnus-summary-position-point)) + +;;; +;;; Internal functions +;;; + +(defun gnus-agent-save-active (method) + (when (gnus-agent-method-p method) + (let* ((gnus-command-method method) + (file (gnus-agent-lib-file "active"))) + (gnus-make-directory (file-name-directory file)) + (write-region (point-min) (point-max) file nil 'silent) + (when (file-exists-p (gnus-agent-lib-file "groups")) + (delete-file (gnus-agent-lib-file "groups")))))) + +(defun gnus-agent-save-groups (method) + (let* ((gnus-command-method method) + (file (gnus-agent-lib-file "groups"))) + (gnus-make-directory (file-name-directory file)) + (write-region (point-min) (point-max) file nil 'silent)) + (when (file-exists-p (gnus-agent-lib-file "active")) + (delete-file (gnus-agent-lib-file "active")))) + +(defun gnus-agent-group-path (group) + "Translate GROUP into a path." + (nnheader-replace-chars-in-string group ?. ?/)) + + + +(defun gnus-agent-method-p (method) + "Say whether METHOD is covered by the agent." + (member method gnus-agent-covered-methods)) + +(defun gnus-agent-get-function (method) + (if (and (not gnus-plugged) + (gnus-agent-method-p method)) + (progn + (require 'nnagent) + 'nnagent) + (car method))) + +;;; History functions + +(defun gnus-agent-history-buffer () + (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers))) + +(defun gnus-agent-open-history () + (save-excursion + (push (cons (gnus-agent-method) + (set-buffer (get-buffer-create + (format " *Gnus agent %s history*" + (gnus-agent-method))))) + gnus-agent-history-buffers) + (erase-buffer) + (insert "\n") + (let ((file (gnus-agent-lib-file "history"))) + (when (file-exists-p file) + (insert-file file)) + (set (make-local-variable 'gnus-agent-file-name) file)))) + +(defun gnus-agent-save-history () + (save-excursion + (set-buffer gnus-agent-current-history) + (gnus-make-directory (file-name-directory gnus-agent-file-name)) + (write-region (1+ (point-min)) (point-max) + gnus-agent-file-name nil 'silent))) + +(defun gnus-agent-close-history () + (when (gnus-buffer-live-p gnus-agent-current-history) + (kill-buffer gnus-agent-current-history) + (setq gnus-agent-history-buffers + (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) + gnus-agent-history-buffers)))) + +(defun gnus-agent-enter-history (id group-arts date) + (save-excursion + (set-buffer gnus-agent-current-history) + (goto-char (point-max)) + (insert id "\t" (number-to-string date) "\t") + (while group-arts + (insert (caar group-arts) "/" (number-to-string (cdr (pop group-arts))) + " ")) + (insert "\n"))) + +(defun gnus-agent-article-in-history-p (id) + (save-excursion + (set-buffer (gnus-agent-history-buffer)) + (goto-char (point-min)) + (search-forward (concat "\n" id "\t") nil t))) + +(defun gnus-agent-history-path (id) + (save-excursion + (set-buffer (gnus-agent-history-buffer)) + (goto-char (point-min)) + (when (search-forward (concat "\n" id "\t") nil t) + (let ((method (gnus-agent-method))) + (let (paths group) + (while (not (numberp (setq group (read (current-buffer))))) + (push (concat method "/" group) paths)) + (nreverse paths)))))) + +;;; +;;; Fetching +;;; + +(defun gnus-agent-start-fetch () + "Initialize data structures for efficient fetching." + (gnus-agent-open-history) + (setq gnus-agent-current-history (gnus-agent-history-buffer))) + +(defun gnus-agent-stop-fetch () + "Save all data structures and clean up." + (gnus-agent-save-history) + (gnus-agent-close-history) + (setq gnus-agent-spam-hashtb nil) + (save-excursion + (set-buffer nntp-server-buffer) + (widen))) + +(defmacro gnus-agent-with-fetch (&rest forms) + "Do FORMS safely." + `(unwind-protect + (progn + (gnus-agent-start-fetch) + ,@forms) + (gnus-agent-stop-fetch))) + +(put 'gnus-agent-with-fetch 'lisp-indent-function 0) +(put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) + +(defun gnus-agent-fetch-articles (group articles) + "Fetch ARTICLES from GROUP and put them into the agent." + (when articles + ;; Prune off articles that we have already fetched. + (while (and articles + (cdr (assq (car articles) gnus-agent-article-alist))) + (pop articles)) + (let ((arts articles)) + (while (cdr arts) + (if (cdr (assq (cadr arts) gnus-agent-article-alist)) + (setcdr arts (cddr arts)) + (setq arts (cdr arts))))) + (when articles + (let ((dir (concat + (gnus-agent-directory) + (gnus-agent-group-path group) "/")) + (date (gnus-time-to-day (current-time))) + (case-fold-search t) + pos alists crosses id elem) + (gnus-make-directory dir) + (gnus-message 7 "Fetching articles for %s..." group) + ;; Fetch the articles from the backend. + (if (gnus-check-backend-function 'retrieve-articles group) + (setq pos (gnus-retrieve-articles articles group)) + (nnheader-temp-write nil + (let ((buf (current-buffer)) + article) + (while (setq article (pop articles)) + (when (gnus-request-article article group) + (goto-char (point-max)) + (push (cons article (point)) pos) + (insert-buffer-substring nntp-server-buffer))) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (setq pos (nreverse pos))))) + ;; Then save these articles into the agent. + (save-excursion + (set-buffer nntp-server-buffer) + (while pos + (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (when (search-backward "\nXrefs: " nil t) + ;; Handle crossposting. + (skip-chars-forward "^ ") + (skip-chars-forward " ") + (setq crosses nil) + (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") + (push (cons (buffer-substring (match-beginning 1) + (match-end 1)) + (buffer-substring (match-beginning 2) + (match-end 2))) + crosses) + (goto-char (match-end 0))) + (gnus-agent-crosspost crosses (caar pos)))) + (goto-char (point-min)) + (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) + (setq id "No-Message-ID-in-article") + (setq id (buffer-substring (match-beginning 1) (match-end 1)))) + (write-region (point-min) (point-max) + (concat dir (number-to-string (caar pos))) + nil 'silent) + (when (setq elem (assq (caar pos) gnus-agent-article-alist)) + (setcdr elem t)) + (gnus-agent-enter-history + id (or crosses (list (cons group (caar pos)))) date) + (widen) + (pop pos))) + (gnus-agent-save-alist group))))) + +(defun gnus-agent-crosspost (crosses article) + (let (gnus-agent-article-alist group alist beg end) + (save-excursion + (set-buffer gnus-agent-overview-buffer) + (when (nnheader-find-nov-line article) + (forward-word 1) + (setq beg (point)) + (setq end (progn (forward-line 1) (point))))) + (while crosses + (setq group (caar crosses)) + (unless (setq alist (assoc group gnus-agent-group-alist)) + (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) + gnus-agent-group-alist)) + (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) + (save-excursion + (set-buffer (get-buffer-create (format " *Gnus agent overview %s*" + group))) + (when (= (point-max) (point-min)) + (push (cons group (current-buffer)) gnus-agent-buffer-alist) + (ignore-errors + (insert-file-contents + (gnus-agent-article-name ".overview" group)))) + (nnheader-find-nov-line (string-to-number (cdar crosses))) + (insert (string-to-number (cdar crosses))) + (insert-buffer-substring gnus-agent-overview-buffer beg end)) + (pop crosses)))) + +(defun gnus-agent-flush-cache () + (save-excursion + (while gnus-agent-buffer-alist + (set-buffer (cdar gnus-agent-buffer-alist)) + (write-region (point-min) (point-max) + (gnus-agent-article-name ".overview" + (caar gnus-agent-buffer-alist)) + nil 'silent) + (pop gnus-agent-buffer-alist)) + (while gnus-agent-group-alist + (nnheader-temp-write (caar gnus-agent-group-alist) + (princ (cdar gnus-agent-group-alist)) + (insert "\n")) + (pop gnus-agent-group-alist)))) + +(defun gnus-agent-fetch-headers (group articles &optional force) + (gnus-agent-load-alist group) + ;; Find out what headers we need to retrieve. + (when articles + (while (and articles + (assq (car articles) gnus-agent-article-alist)) + (pop articles)) + (let ((arts articles)) + (while (cdr arts) + (if (assq (cadr arts) gnus-agent-article-alist) + (setcdr arts (cddr arts)) + (setq arts (cdr arts))))) + ;; Fetch them. + (when articles + (gnus-message 7 "Fetching headers for %s..." group) + (save-excursion + (set-buffer nntp-server-buffer) + (unless (eq 'nov (gnus-retrieve-headers articles group)) + (nnvirtual-convert-headers)) + ;; Save these headers for later processing. + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + (let (file) + (when (file-exists-p + (setq file (gnus-agent-article-name ".overview" group))) + (gnus-agent-braid-nov group articles file)) + (gnus-make-directory (file-name-directory file)) + (write-region (point-min) (point-max) file nil 'silent) + (gnus-agent-save-alist group articles nil)) + t)))) + +(defsubst gnus-agent-copy-nov-line (article) + (let (b e) + (set-buffer gnus-agent-overview-buffer) + (setq b (point)) + (if (eq article (read (current-buffer))) + (setq e (progn (forward-line 1) (point))) + (setq e b)) + (set-buffer nntp-server-buffer) + (insert-buffer-substring gnus-agent-overview-buffer b e))) + +(defun gnus-agent-braid-nov (group articles file) + (let (beg end) + (set-buffer gnus-agent-overview-buffer) + (goto-char (point-min)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-file-contents file) + (goto-char (point-min)) + (if (or (= (point-min) (point-max)) + (progn + (forward-line -1) + (< (read (current-buffer)) (car articles)))) + ;; We have only headers that are after the older headers, + ;; so we just append them. + (progn + (goto-char (point-max)) + (insert-buffer-substring gnus-agent-overview-buffer)) + ;; We do it the hard way. + (nnheader-find-nov-line (car articles)) + (gnus-agent-copy-nov-line (car articles)) + (pop articles) + (while (and articles + (not (eobp))) + (while (and (not (eobp)) + (< (read (current-buffer)) (car articles))) + (forward-line 1)) + (beginning-of-line) + (unless (eobp) + (gnus-agent-copy-nov-line (car articles)) + (setq articles (cdr articles)))) + (when articles + (let (b e) + (set-buffer gnus-agent-overview-buffer) + (setq b (point) + e (point-max)) + (set-buffer nntp-server-buffer) + (insert-buffer-substring gnus-agent-overview-buffer b e)))))) + +(defun gnus-agent-load-alist (group &optional dir) + "Load the article-state alist for GROUP." + (setq gnus-agent-article-alist + (gnus-agent-read-file + (if dir + (concat dir ".agentview") + (gnus-agent-article-name ".agentview" group))))) + +(defun gnus-agent-save-alist (group &optional articles state dir) + "Load the article-state alist for GROUP." + (nnheader-temp-write (if dir + (concat dir ".agentview") + (gnus-agent-article-name ".agentview" group)) + (princ (setq gnus-agent-article-alist + (nconc gnus-agent-article-alist + (mapcar (lambda (article) (cons article state)) + articles))) + (current-buffer)) + (insert "\n"))) + +(defun gnus-agent-article-name (article group) + (concat (gnus-agent-directory) (gnus-agent-group-path group) "/" + (if (stringp article) article (string-to-number article)))) + +(defun gnus-agent-fetch-session () + "Fetch all articles and headers that are eligible for fetching." + (interactive) + (unless gnus-agent-covered-methods + (error "No servers are covered by the Gnus agent")) + (unless gnus-plugged + (error "Can't fetch articles while Gnus is unplugged")) + (let ((methods gnus-agent-covered-methods) + groups group gnus-command-method) + (save-excursion + (while methods + (setq gnus-command-method (car methods) + groups (gnus-groups-from-server (pop methods))) + (gnus-agent-with-fetch + (while (setq group (pop groups)) + (gnus-agent-fetch-group-1 group gnus-command-method)))) + (gnus-message 6 "Finished fetching articles into the Gnus agent")))) + +(defun gnus-agent-fetch-group-1 (group method) + "Fetch GROUP." + (let ((gnus-command-method method) + gnus-newsgroup-dependencies gnus-newsgroup-headers + gnus-newsgroup-scored gnus-headers gnus-score + gnus-use-cache articles score arts + category predicate info marks score-param) + ;; Fetch headers. + (when (and (setq articles (gnus-list-of-unread-articles group)) + (gnus-agent-fetch-headers group articles)) + ;; Parse them and see which articles we want to fetch. + (setq gnus-newsgroup-dependencies + (make-vector (length articles) 0)) + (setq gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil group)) + (setq category (gnus-group-category group)) + (setq predicate + (gnus-get-predicate + (or (gnus-group-get-parameter group 'agent-predicate) + (cadr category)))) + (setq score-param + (or (gnus-group-get-parameter group 'agent-score) + (caddr category))) + (when score-param + (gnus-score-headers (list (list score-param)))) + (setq arts nil) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (setq gnus-score + (or (cdr (assq (mail-header-number gnus-headers) + gnus-newsgroup-scored)) + gnus-summary-default-score)) + (when (funcall predicate) + (push (mail-header-number gnus-headers) + arts))) + ;; Fetch the articles. + (when arts + (gnus-agent-fetch-articles group arts))) + ;; Perhaps we have some additional articles to fetch. + (setq arts (assq 'download (gnus-info-marks + (setq info (gnus-get-info group))))) + (when (cdr arts) + (gnus-agent-fetch-articles + group (gnus-uncompress-range (cdr arts))) + (setq marks (delq arts (gnus-info-marks info))) + (gnus-info-set-marks info marks)))) + +;;; +;;; Agent Category Mode +;;; + +(defvar gnus-category-mode-hook nil + "Hook run in `gnus-category-mode' buffers.") + +(defvar gnus-category-line-format " %(%20c%): %g\n" + "Format of category lines.") + +(defvar gnus-category-mode-line-format "Gnus: %%b" + "The format specification for the category mode line.") + +(defvar gnus-agent-short-article 100 + "Articles that have fewer lines than this are short.") + +(defvar gnus-agent-long-article 200 + "Articles that have more lines than this are long.") + +(defvar gnus-agent-low-score 0 + "Articles that have a score lower than this have a low score.") + +(defvar gnus-agent-high-score 0 + "Articles that have a score higher than this have a high score.") + + +;;; Internal variables. + +(defvar gnus-category-buffer "*Agent Category*") + +(defvar gnus-category-line-format-alist + `((?c name ?s) + (?g groups ?d))) + +(defvar gnus-category-mode-line-format-alist + `((?u user-defined ?s))) + +(defvar gnus-category-line-format-spec nil) +(defvar gnus-category-mode-line-format-spec nil) + +(defvar gnus-category-mode-map nil) +(put 'gnus-category-mode 'mode-class 'special) + +(unless gnus-category-mode-map + (setq gnus-category-mode-map (make-sparse-keymap)) + (suppress-keymap gnus-category-mode-map) + + (gnus-define-keys gnus-category-mode-map + "q" gnus-category-exit + "k" gnus-category-kill + "c" gnus-category-copy + "a" gnus-category-add + "p" gnus-category-edit-predicate + "g" gnus-category-edit-groups + "s" gnus-category-edit-score + "l" gnus-category-list + + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) + +(defvar gnus-category-menu-hook nil + "*Hook run after the creation of the menu.") + +(defun gnus-category-make-menu-bar () + (gnus-turn-off-edit-menu 'category) + (unless (boundp 'gnus-category-menu) + (easy-menu-define + gnus-category-menu gnus-category-mode-map "" + '("Categories" + ["Add" gnus-category-add t] + ["Kill" gnus-category-kill t] + ["Copy" gnus-category-copy t] + ["Edit predicate" gnus-category-edit-predicate t] + ["Edit score" gnus-category-edit-score t] + ["Edit groups" gnus-category-edit-groups t] + ["Exit" gnus-category-exit t])) + + (run-hooks 'gnus-category-menu-hook))) + +(defun gnus-category-mode () + "Major mode for listing and editing agent categories. + +All normal editing commands are switched off. +\\ +For more in-depth information on this mode, read the manual +(`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-category-mode-map}" + (interactive) + (when (gnus-visual-p 'category-menu 'menu) + (gnus-category-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-category-mode) + (setq mode-name "Category") + (gnus-set-default-directory) + (setq mode-line-process nil) + (use-local-map gnus-category-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (setq buffer-read-only t) + (run-hooks 'gnus-category-mode-hook)) + +(defalias 'gnus-category-position-point 'gnus-goto-colon) + +(defun gnus-category-insert-line (category) + (let* ((name (car category)) + (groups (length (cadddr category)))) + (beginning-of-line) + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + ;; Insert the text. + (eval gnus-category-line-format-spec)) + (list 'gnus-category name)))) + +(defun gnus-enter-category-buffer () + "Go to the Category buffer." + (interactive) + (gnus-category-setup-buffer) + (gnus-configure-windows 'category) + (gnus-category-prepare)) + +(defun gnus-category-setup-buffer () + (unless (get-buffer gnus-category-buffer) + (save-excursion + (set-buffer (get-buffer-create gnus-category-buffer)) + (gnus-add-current-to-buffer-list) + (gnus-category-mode)))) + +(defun gnus-category-prepare () + (gnus-set-format 'category-mode) + (gnus-set-format 'category t) + (let ((alist gnus-category-alist) + (buffer-read-only nil)) + (erase-buffer) + (while alist + (gnus-category-insert-line (pop alist))) + (goto-char (point-min)) + (gnus-category-position-point))) + +(defun gnus-category-name () + (or (get-text-property (gnus-point-at-bol) 'gnus-category) + (error "No category on the current line"))) + +(defun gnus-category-read () + "Read the category alist." + (setq gnus-category-alist + (or (gnus-agent-read-file + (nnheader-concat gnus-agent-directory "lib/categories")) + (list (list 'default 'true nil nil))))) + +(defun gnus-category-write () + "Write the category alist." + (setq gnus-category-predicate-cache nil + gnus-category-group-cache nil) + (nnheader-temp-write (nnheader-concat gnus-agent-directory "lib/categories") + (prin1 gnus-category-alist (current-buffer)))) + +(defun gnus-category-edit-predicate (category) + "Edit the predicate for CATEGORY." + (interactive (list (gnus-category-name))) + (let ((info (assq category gnus-category-alist))) + (gnus-edit-form + (cadr info) (format "Editing the predicate for category %s" category) + `(lambda (predicate) + (setf (cadr (assq ',category gnus-category-alist)) predicate) + (gnus-category-write) + (gnus-category-list))))) + +(defun gnus-category-edit-score (category) + "Edit the score expression for CATEGORY." + (interactive (list (gnus-category-name))) + (let ((info (assq category gnus-category-alist))) + (gnus-edit-form + (caddr info) + (format "Editing the score expression for category %s" category) + `(lambda (groups) + (setf (caddr (assq ',category gnus-category-alist)) groups) + (gnus-category-write) + (gnus-category-list))))) + +(defun gnus-category-edit-groups (category) + "Edit the group list for CATEGORY." + (interactive (list (gnus-category-name))) + (let ((info (assq category gnus-category-alist))) + (gnus-edit-form + (cadddr info) (format "Editing the group list for category %s" category) + `(lambda (groups) + (setf (cadddr (assq ',category gnus-category-alist)) groups) + (gnus-category-write) + (gnus-category-list))))) + +(defun gnus-category-kill (category) + "Kill the current category." + (interactive (list (gnus-category-name))) + (let ((info (assq category gnus-category-alist)) + (buffer-read-only nil)) + (gnus-delete-line) + (gnus-category-write) + (setq gnus-category-alist (delq info gnus-category-alist)))) + +(defun gnus-category-copy (category to) + "Copy the current category." + (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) + (let ((info (assq category gnus-category-alist))) + (push (list to (gnus-copy-sequence (cadr info)) + (gnus-copy-sequence (caddr info)) nil) + gnus-category-alist) + (gnus-category-write) + (gnus-category-list))) + +(defun gnus-category-add (category) + "Create a new category." + (interactive "SCategory name: ") + (when (assq category gnus-category-alist) + (error "Category %s already exists" category)) + (push (list category 'true nil nil) + gnus-category-alist) + (gnus-category-write) + (gnus-category-list)) + +(defun gnus-category-list () + "List all categories." + (interactive) + (gnus-category-prepare)) + +(defun gnus-category-exit () + "Return to the group buffer." + (interactive) + (kill-buffer (current-buffer)) + (gnus-configure-windows 'group t)) + +;; To avoid having 8-bit characters in the source file. +(defvar gnus-category-not (list '! 'not (intern (format "%c" 172)))) + +(defvar gnus-category-predicate-alist + '((spam . gnus-agent-spam-p) + (short . gnus-agent-short-p) + (long . gnus-agent-long-p) + (low . gnus-agent-low-scored-p) + (high . gnus-agent-high-scored-p) + (true . gnus-agent-true) + (false . gnus-agent-false)) + "Mapping from short score predicate symbols to predicate functions.") + +(defun gnus-agent-spam-p () + "Say whether an article is spam or not." + (unless gnus-agent-spam-hashtb + (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000))) + (if (not (equal (mail-header-references gnus-headers) "")) + nil + (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) + (prog1 + (gnus-gethash string gnus-agent-spam-hashtb) + (gnus-sethash string t gnus-agent-spam-hashtb))))) + +(defun gnus-agent-short-p () + "Say whether an article is short or not." + (< (mail-header-lines gnus-headers) gnus-agent-short-article)) + +(defun gnus-agent-long-p () + "Say whether an article is long or not." + (> (mail-header-lines gnus-headers) gnus-agent-long-article)) + +(defun gnus-agent-low-scored-p () + "Say whether an article has a low score or not." + (< gnus-score gnus-agent-low-score)) + +(defun gnus-agent-high-scored-p () + "Say whether an article has a high score or not." + (> gnus-score gnus-agent-low-score)) + +(defun gnus-category-make-function (cat) + "Make a function from category CAT." + `(lambda () ,(gnus-category-make-function-1 cat))) + +(defun gnus-agent-true () + "Return t." + t) + +(defun gnus-agent-false () + "Return nil." + nil) + +(defun gnus-category-make-function-1 (cat) + "Make a function from category CAT." + (cond + ;; Functions are just returned as is. + ((or (symbolp cat) + (gnus-functionp cat)) + `(,(or (cdr (assq cat gnus-category-predicate-alist)) + cat))) + ;; More complex category. + ((consp cat) + `(,(cond + ((memq (car cat) '(& and)) + 'and) + ((memq (car cat) '(| or)) + 'or) + ((memq (car cat) gnus-category-not) + 'not)) + ,@(mapcar 'gnus-category-make-function-1 (cdr cat)))) + (t + (error "Unknown category type: %s" cat)))) + +(defun gnus-get-predicate (predicate) + "Return the predicate for CATEGORY." + (or (cdr (assoc predicate gnus-category-predicate-cache)) + (cdar (push (cons predicate + (gnus-category-make-function predicate)) + gnus-category-predicate-cache)))) + +(defun gnus-group-category (group) + "Return the category GROUP belongs to." + (unless gnus-category-group-cache + (setq gnus-category-group-cache (gnus-make-hashtable 1000)) + (let ((cs gnus-category-alist) + groups cat) + (while (setq cat (pop cs)) + (setq groups (cadddr cat)) + (while groups + (gnus-sethash (pop groups) cat gnus-category-group-cache))))) + (or (gnus-gethash group gnus-category-group-cache) + (assq 'default gnus-category-alist))) + +(defun gnus-agent-expire () + "Expire all old articles." + (interactive) + (let ((methods gnus-agent-covered-methods) + (alist (cdr gnus-newsrc-alist)) + gnus-command-method ofiles info method file group) + (while (setq gnus-command-method (pop methods)) + (setq ofiles (nconc ofiles (gnus-agent-expire-directory + (gnus-agent-directory))))) + (while (setq info (pop alist)) + (when (and (gnus-agent-method-p + (setq gnus-command-method + (gnus-find-method-for-group + (setq group (gnus-info-group info))))) + (member + (setq file + (concat + (gnus-agent-directory) + (gnus-agent-group-path group) "/.overview")) + ofiles)) + (setq ofiles (delete file ofiles)) + (gnus-agent-expire-group file group))) + (while ofiles + (gnus-agent-expire-group (pop ofiles))))) + +(defun gnus-agent-expire-directory (dir) + "Expire all groups in DIR recursively." + (when (file-directory-p dir) + (let ((files (directory-files dir t)) + file ofiles) + (while (setq file (pop files)) + (cond + ((member (file-name-nondirectory file) '("." "..")) + ;; Do nothing. + ) + ((file-directory-p file) + ;; Recurse. + (setq ofiles (nconc ofiles (gnus-agent-expire-directory file)))) + ((string-match "\\.overview$" file) + ;; Expire group. + (push file ofiles)))) + ofiles))) + +(defun gnus-agent-expire-group (overview &optional group) + "Expire articles in OVERVIEW." + (gnus-message 5 "Expiring %s..." overview) + (let ((odate (- (gnus-time-to-day (current-time)) 4)) + (dir (file-name-directory overview)) + (info (when group (gnus-get-info group))) + headers article file point unreads) + (gnus-agent-load-alist nil dir) + (when info + (setq unreads + (nconc + (gnus-list-of-unread-articles group) + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant (gnus-info-marks info))))))) + (nnheader-temp-write overview + (insert-file-contents overview) + (goto-char (point-min)) + (while (not (eobp)) + (setq point (point)) + (condition-case () + (setq headers (inline (nnheader-parse-nov))) + (error + (goto-char point) + (gnus-delete-line) + (setq headers nil))) + (when headers + (unless (memq (setq article (mail-header-number headers)) unreads) + (if (not (< (inline + (gnus-time-to-day + (inline (nnmail-date-to-time + (mail-header-date headers))))) + odate)) + (forward-line 1) + (gnus-delete-line) + (setq gnus-agent-article-alist + (delq (assq article gnus-agent-article-alist) + gnus-agent-article-alist)) + (when (file-exists-p + (setq file (concat dir (number-to-string article)))) + (delete-file file)))))) + (gnus-agent-save-alist nil nil nil dir)))) + +(provide 'gnus-agent) + +;;; gnus-agent.el ends here diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el new file mode 100644 index 0000000..db13b3d --- /dev/null +++ b/lisp/gnus-art.el @@ -0,0 +1,3129 @@ +;;; gnus-art.el --- article mode commands for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'custom) +(require 'gnus) +(require 'gnus-sum) +(require 'gnus-spec) +(require 'gnus-int) +(require 'browse-url) + +(defgroup gnus-article nil + "Article display." + :link '(custom-manual "(gnus)The Article Buffer") + :group 'gnus) + +(defgroup gnus-article-hiding nil + "Hiding article parts." + :link '(custom-manual "(gnus)Article Hiding") + :group 'gnus-article) + +(defgroup gnus-article-highlight nil + "Article highlighting." + :link '(custom-manual "(gnus)Article Highlighting") + :group 'gnus-article + :group 'gnus-visual) + +(defgroup gnus-article-signature nil + "Article signatures." + :link '(custom-manual "(gnus)Article Signature") + :group 'gnus-article) + +(defgroup gnus-article-headers nil + "Article headers." + :link '(custom-manual "(gnus)Hiding Headers") + :group 'gnus-article) + +(defgroup gnus-article-washing nil + "Special commands on articles." + :link '(custom-manual "(gnus)Article Washing") + :group 'gnus-article) + +(defgroup gnus-article-emphasis nil + "Fontisizing articles." + :link '(custom-manual "(gnus)Article Fontisizing") + :group 'gnus-article) + +(defgroup gnus-article-saving nil + "Saving articles." + :link '(custom-manual "(gnus)Saving Articles") + :group 'gnus-article) + +(defgroup gnus-article-mime nil + "Worshiping the MIME wonder." + :link '(custom-manual "(gnus)Using MIME") + :group 'gnus-article) + +(defgroup gnus-article-buttons nil + "Pushable buttons in the article buffer." + :link '(custom-manual "(gnus)Article Buttons") + :group 'gnus-article) + +(defgroup gnus-article-various nil + "Other article options." + :link '(custom-manual "(gnus)Misc Article") + :group 'gnus-article) + +(defcustom gnus-ignored-headers + '("^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:") + "All headers that match this regexp will be hidden. +This variable can also be a list of regexps of headers to be ignored. +If `gnus-visible-headers' is non-nil, this variable will be ignored." + :type '(choice :custom-show nil + regexp + (repeat regexp)) + :group 'gnus-article-hiding) + +(defcustom gnus-visible-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" + "All headers that do not match this regexp will be hidden. +This variable can also be a list of regexp of headers to remain visible. +If this variable is non-nil, `gnus-ignored-headers' will be ignored." + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp) + :group 'gnus-article-hiding) + +(defcustom gnus-sorted-header-list + '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" + "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") + "This variable is a list of regular expressions. +If it is non-nil, headers that match the regular expressions will +be placed first in the article buffer in the sequence specified by +this list." + :type '(repeat regexp) + :group 'gnus-article-hiding) + +(defcustom gnus-boring-article-headers '(empty followup-to reply-to) + "Headers that are only to be displayed if they have interesting data. +Possible values in this list are `empty', `newsgroups', `followup-to', +`reply-to', and `date'." + :type '(set (const :tag "Headers with no content." empty) + (const :tag "Newsgroups with only one group." newsgroups) + (const :tag "Followup-to identical to newsgroups." followup-to) + (const :tag "Reply-to identical to from." reply-to) + (const :tag "Date less than four days old." date) + (const :tag "Very long To header." long-to)) + :group 'gnus-article-hiding) + +(defcustom gnus-signature-separator '("^-- $" "^-- *$") + "Regexp matching signature separator. +This can also be a list of regexps. In that case, it will be checked +from head to tail looking for a separator. Searches will be done from +the end of the buffer." + :type '(repeat string) + :group 'gnus-article-signature) + +(defcustom gnus-signature-limit nil + "Provide a limit to what is considered a signature. +If it is a number, no signature may not be longer (in characters) than +that number. If it is a floating point number, no signature may be +longer (in lines) than that number. If it is a function, the function +will be called without any parameters, and if it returns nil, there is +no signature in the buffer. If it is a string, it will be used as a +regexp. If it matches, the text in question is not a signature." + :type '(choice integer number function regexp) + :group 'gnus-article-signature) + +(defcustom gnus-hidden-properties '(invisible t intangible t) + "Property list to use for hiding text." + :type 'sexp + :group 'gnus-article-hiding) + +(defcustom gnus-article-x-face-command + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" + "String or function to be executed to display an X-Face header. +If it is a string, the command will be executed in a sub-shell +asynchronously. The compressed face will be piped to this command." + :type 'string ;Leave function case to Lisp. + :group 'gnus-article-washing) + +(defcustom gnus-article-x-face-too-ugly nil + "Regexp matching posters whose face shouldn't be shown automatically." + :type '(choice regexp (const nil)) + :group 'gnus-article-washing) + +(defcustom gnus-emphasis-alist + (let ((format + "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") + (types + '(("_" "_" underline) + ("/" "/" italic) + ("\\*" "\\*" bold) + ("_/" "/_" underline-italic) + ("_\\*" "\\*_" underline-bold) + ("\\*/" "/\\*" bold-italic) + ("_\\*/" "/\\*_" underline-bold-italic)))) + `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-underline) + ,@(mapcar + (lambda (spec) + (list + (format format (car spec) (cadr spec)) + 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) + types))) + "Alist that says how to fontify certain phrases. +Each item looks like this: + + (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) + +The first element is a regular expression to be matched. The second +is a number that says what regular expression grouping used to find +the entire emphasized word. The third is a number that says what +regexp grouping should be displayed and highlighted. The fourth +is the face used for highlighting." + :type '(repeat (list :value ("" 0 0 default) + regexp + (integer :tag "Match group") + (integer :tag "Emphasize group") + face)) + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-bold '((t (:bold t))) + "Face used for displaying strong emphasized text (*word*)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-italic '((t (:italic t))) + "Face used for displaying italic emphasized text (/word/)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline '((t (:underline t))) + "Face used for displaying underlined emphasized text (_word_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) + "Face used for displaying underlined bold emphasized text (_*word*_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) + "Face used for displaying underlined italic emphasized text (_*word*_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) + "Face used for displaying bold italic emphasized text (/*word*/)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-bold-italic + '((t (:bold t :italic t :underline t))) + "Face used for displaying underlined bold italic emphasized text. +Esample: (_/*word*/_)." + :group 'gnus-article-emphasis) + +(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" + "Format for display of Date headers in article bodies. +See `format-time-string' for the possible values." + :type 'string + :link '(custom-manual "(gnus)Article Date") + :group 'gnus-article-washing) + +(eval-and-compile + (autoload 'hexl-hex-string-to-integer "hexl") + (autoload 'timezone-make-date-arpa-standard "timezone") + (autoload 'mail-extract-address-components "mail-extr")) + +(defcustom gnus-save-all-headers t + "*If non-nil, don't remove any headers before saving." + :group 'gnus-article-saving + :type 'boolean) + +(defcustom gnus-prompt-before-saving 'always + "*This variable says how much prompting is to be done when saving articles. +If it is nil, no prompting will be done, and the articles will be +saved to the default files. If this variable is `always', each and +every article that is saved will be preceded by a prompt, even when +saving large batches of articles. If this variable is neither nil not +`always', there the user will be prompted once for a file name for +each invocation of the saving commands." + :group 'gnus-article-saving + :type '(choice (item always) + (item :tag "never" nil) + (sexp :tag "once" :format "%t"))) + +(defcustom gnus-saved-headers gnus-visible-headers + "Headers to keep if `gnus-save-all-headers' is nil. +If `gnus-save-all-headers' is non-nil, this variable will be ignored. +If that variable is nil, however, all headers that match this regexp +will be kept while the rest will be deleted before saving." + :group 'gnus-article-saving + :type 'regexp) + +(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail + "A function to save articles in your favourite format. +The function must be interactively callable (in other words, it must +be an Emacs command). + +Gnus provides the following functions: + +* gnus-summary-save-in-rmail (Rmail format) +* gnus-summary-save-in-mail (Unix mail format) +* gnus-summary-save-in-folder (MH folder) +* gnus-summary-save-in-file (article format) +* gnus-summary-save-in-vm (use VM's folder format) +* gnus-summary-write-to-file (article format -- overwrite)." + :group 'gnus-article-saving + :type '(radio (function-item gnus-summary-save-in-rmail) + (function-item gnus-summary-save-in-mail) + (function-item gnus-summary-save-in-folder) + (function-item gnus-summary-save-in-file) + (function-item gnus-summary-save-in-vm) + (function-item gnus-summary-write-to-file))) + +(defcustom gnus-rmail-save-name 'gnus-plain-save-name + "A function generating a file name to save articles in Rmail format. +The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-mail-save-name 'gnus-plain-save-name + "A function generating a file name to save articles in Unix mail format. +The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-folder-save-name 'gnus-folder-save-name + "A function generating a file name to save articles in MH folder. +The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-file-save-name 'gnus-numeric-save-name + "A function generating a file name to save articles in article format. +The function is called with NEWSGROUP, HEADERS, and optional +LAST-FILE." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-split-methods + '((gnus-article-archive-name) + (gnus-article-nndoc-name)) + "Variable used to suggest where articles are to be saved. +For instance, if you would like to save articles related to Gnus in +the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", +you could set this variable to something like: + + '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") + (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) + +This variable is an alist where the where the key is the match and the +value is a list of possible files to save in if the match is non-nil. + +If the match is a string, it is used as a regexp match on the +article. If the match is a symbol, that symbol will be funcalled +from the buffer of the article to be saved with the newsgroup as the +parameter. If it is a list, it will be evaled in the same buffer. + +If this form or function returns a string, this string will be used as +a possible file name; and if it returns a non-nil list, that list will +be used as possible file names." + :group 'gnus-article-saving + :type '(repeat (choice (list function) + (cons regexp (repeat string)) + sexp))) + +(defcustom gnus-strict-mime t + "*If nil, MIME-decode even if there is no Mime-Version header." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-show-mime-method 'metamail-buffer + "Function to process a MIME message. +The function is called from the article buffer." + :group 'gnus-article-mime + :type 'function) + +(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable + "*Function to decode MIME encoded words. +The function is called from the article buffer." + :group 'gnus-article-mime + :type 'function) + +(defcustom gnus-page-delimiter "^\^L" + "*Regexp describing what to use as article page delimiters. +The default value is \"^\^L\", which is a form linefeed at the +beginning of a line." + :type 'regexp + :group 'gnus-article-various) + +(defcustom gnus-article-mode-line-format "Gnus: %%b %S" + "*The format specification for the article mode line. +See `gnus-summary-mode-line-format' for a closer description." + :type 'string + :group 'gnus-article-various) + +(defcustom gnus-article-mode-hook nil + "*A hook for Gnus article mode." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-menu-hook nil + "*Hook run after the creation of the article mode menu." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-prepare-hook nil + "*A hook called after an article has been prepared in the article buffer. +If you want to run a special decoding program like nkf, use this hook." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-hide-pgp-hook nil + "*A hook called after successfully hiding a PGP signature." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-button-face 'bold + "Face used for highlighting buttons in the article buffer. + +An article button is a piece of text that you can activate by pressing +`RET' or `mouse-2' above it." + :type 'face + :group 'gnus-article-buttons) + +(defcustom gnus-article-mouse-face 'highlight + "Face used for mouse highlighting in the article buffer. + +Article buttons will be displayed in this face when the cursor is +above them." + :type 'face + :group 'gnus-article-buttons) + +(defcustom gnus-signature-face 'gnus-signature-face + "Face used for highlighting a signature in the article buffer. +Obsolete; use the face `gnus-signature-face' for customizations instead." + :type 'face + :group 'gnus-article-highlight + :group 'gnus-article-signature) + +(defface gnus-signature-face + '((((type x)) + (:italic t))) + "Face used for highlighting a signature in the article buffer." + :group 'gnus-article-highlight + :group 'gnus-article-signature) + +(defface gnus-header-from-face + '((((class color) + (background dark)) + (:foreground "spring green" :bold t)) + (((class color) + (background light)) + (:foreground "red3" :bold t)) + (t + (:bold t :italic t))) + "Face used for displaying from headers." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-subject-face + '((((class color) + (background dark)) + (:foreground "SeaGreen3" :bold t)) + (((class color) + (background light)) + (:foreground "red4" :bold t)) + (t + (:bold t :italic t))) + "Face used for displaying subject headers." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-newsgroups-face + '((((class color) + (background dark)) + (:foreground "yellow" :bold t :italic t)) + (((class color) + (background light)) + (:foreground "MidnightBlue" :bold t :italic t)) + (t + (:bold t :italic t))) + "Face used for displaying newsgroups headers." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-name-face + '((((class color) + (background dark)) + (:foreground "SeaGreen")) + (((class color) + (background light)) + (:foreground "maroon")) + (t + (:bold t))) + "Face used for displaying header names." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-content-face + '((((class color) + (background dark)) + (:foreground "forest green" :italic t)) + (((class color) + (background light)) + (:foreground "indianred4" :italic t)) + (t + (:italic t))) "Face used for displaying header content." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defcustom gnus-header-face-alist + '(("From" nil gnus-header-from-face) + ("Subject" nil gnus-header-subject-face) + ("Newsgroups:.*," nil gnus-header-newsgroups-face) + ("" gnus-header-name-face gnus-header-content-face)) + "Controls highlighting of article header. + +An alist of the form (HEADER NAME CONTENT). + +HEADER is a regular expression which should match the name of an +header header and NAME and CONTENT are either face names or nil. + +The name of each header field will be displayed using the face +specified by the first element in the list where HEADER match the +header name and NAME is non-nil. Similarly, the content will be +displayed by the first non-nil matching CONTENT face." + :group 'gnus-article-headers + :group 'gnus-article-highlight + :type '(repeat (list (regexp :tag "Header") + (choice :tag "Name" + (item :tag "skip" nil) + (face :value default)) + (choice :tag "Content" + (item :tag "skip" nil) + (face :value default))))) + +;;; Internal variables + +(defvar gnus-article-mode-syntax-table + (let ((table (copy-syntax-table text-mode-syntax-table))) + (modify-syntax-entry ?- "w" table) + (modify-syntax-entry ?> ")" table) + (modify-syntax-entry ?< "(" table) + table) + "Syntax table used in article mode buffers. +Initialized from `text-mode-syntax-table.") + +(defvar gnus-save-article-buffer nil) + +(defvar gnus-article-mode-line-format-alist + (nconc '((?w (gnus-article-wash-status) ?s)) + gnus-summary-mode-line-format-alist)) + +(defvar gnus-number-of-articles-to-be-saved nil) + +(defvar gnus-inhibit-hiding nil) + +(defsubst gnus-article-hide-text (b e props) + "Set text PROPS on the B to E region, extending `intangible' 1 past B." + (add-text-properties b e props) + (when (memq 'intangible props) + (put-text-property + (max (1- b) (point-min)) + b 'intangible (cddr (memq 'intangible props))))) + +(defsubst gnus-article-unhide-text (b e) + "Remove hidden text properties from region between B and E." + (remove-text-properties b e gnus-hidden-properties) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-type (b e type) + "Hide text of TYPE between B and E." + (gnus-article-hide-text + b e (cons 'article-type (cons type gnus-hidden-properties)))) + +(defun gnus-article-unhide-text-type (b e type) + "Hide text of TYPE between B and E." + (remove-text-properties + b e (cons 'article-type (cons type gnus-hidden-properties))) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-of-type (type) + "Hide text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min)) + (e (point-max))) + (while (setq b (text-property-any b e 'article-type type)) + (add-text-properties b (incf b) gnus-hidden-properties))))) + +(defun gnus-article-delete-text-of-type (type) + "Delete text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'article-type type)) + (delete-region + b (or (text-property-not-all b (point-max) 'article-type type) + (point-max))))))) + +(defun gnus-article-delete-invisible-text () + "Delete all invisible text in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'invisible t)) + (delete-region + b (or (text-property-not-all b (point-max) 'invisible t) + (point-max))))))) + +(defun gnus-article-text-type-exists-p (type) + "Say whether any text of type TYPE exists in the buffer." + (text-property-any (point-min) (point-max) 'article-type type)) + +(defsubst gnus-article-header-rank () + "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." + (let ((list gnus-sorted-header-list) + (i 0)) + (while list + (when (looking-at (car list)) + (setq list nil)) + (setq list (cdr list)) + (incf i)) + i)) + +(defun article-hide-headers (&optional arg delete) + "Toggle whether to hide unwanted headers and possibly sort them as well. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (if (gnus-article-check-hidden-text 'headers arg) + ;; Show boring headers as well. + (gnus-article-show-hidden-text 'boring-headers) + ;; This function might be inhibited. + (unless gnus-inhibit-hiding + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (props (nconc (list 'article-type 'headers) + gnus-hidden-properties)) + (max (1+ (length gnus-sorted-header-list))) + (ignored (when (not gnus-visible-headers) + (cond ((stringp gnus-ignored-headers) + gnus-ignored-headers) + ((listp gnus-ignored-headers) + (mapconcat 'identity gnus-ignored-headers + "\\|"))))) + (visible + (cond ((stringp gnus-visible-headers) + gnus-visible-headers) + ((and gnus-visible-headers + (listp gnus-visible-headers)) + (mapconcat 'identity gnus-visible-headers "\\|")))) + (inhibit-point-motion-hooks t) + want-list beg) + ;; First we narrow to just the headers. + (widen) + (goto-char (point-min)) + ;; Hide any "From " lines at the beginning of (mail) articles. + (while (looking-at "From ") + (forward-line 1)) + (unless (bobp) + (if delete + (delete-region (point-min) (point)) + (gnus-article-hide-text (point-min) (point) props))) + ;; Then treat the rest of the header lines. + (narrow-to-region + (point) + (if (search-forward "\n\n" nil t) ; if there's a body + (progn (forward-line -1) (point)) + (point-max))) + ;; Then we use the two regular expressions + ;; `gnus-ignored-headers' and `gnus-visible-headers' to + ;; select which header lines is to remain visible in the + ;; article buffer. + (goto-char (point-min)) + (while (re-search-forward "^[^ \t]*:" nil t) + (beginning-of-line) + ;; Mark the rank of the header. + (put-text-property + (point) (1+ (point)) 'message-rank + (if (or (and visible (looking-at visible)) + (and ignored + (not (looking-at ignored)))) + (gnus-article-header-rank) + (+ 2 max))) + (forward-line 1)) + (message-sort-headers-1) + (when (setq beg (text-property-any + (point-min) (point-max) 'message-rank (+ 2 max))) + ;; We make the unwanted headers invisible. + (if delete + (delete-region beg (point-max)) + ;; Suggested by Sudish Joseph . + (gnus-article-hide-text-type beg (point-max) 'headers)) + ;; Work around XEmacs lossage. + (put-text-property (point-min) beg 'invisible nil)))))))) + +(defun article-hide-boring-headers (&optional arg) + "Toggle hiding of headers that aren't very interesting. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) + (not gnus-show-all-headers)) + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (list gnus-boring-article-headers) + (inhibit-point-motion-hooks t) + elem) + (nnheader-narrow-to-headers) + (while list + (setq elem (pop list)) + (goto-char (point-min)) + (cond + ;; Hide empty headers. + ((eq elem 'empty) + (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) + (forward-line -1) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers))) + ;; Hide boring Newsgroups header. + ((eq elem 'newsgroups) + (when (equal (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) + (gnus-article-hide-header "newsgroups"))) + ((eq elem 'followup-to) + (when (equal (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) + (gnus-article-hide-header "followup-to"))) + ((eq elem 'reply-to) + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when (and + from reply-to + (ignore-errors + (equal + (nth 1 (mail-extract-address-components from)) + (nth 1 (mail-extract-address-components reply-to))))) + (gnus-article-hide-header "reply-to")))) + ((eq elem 'date) + (let ((date (message-fetch-field "date"))) + (when (and date + (< (gnus-days-between (current-time-string) date) + 4)) + (gnus-article-hide-header "date")))) + ((eq elem 'long-to) + (let ((to (message-fetch-field "to"))) + (when (> (length to) 1024) + (gnus-article-hide-header "to"))))))))))) + +(defun gnus-article-hide-header (header) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^" header ":") nil t) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers)))) + +;; Written by Per Abrahamsen . +(defun article-treat-overstrike () + "Translate overstrikes into bold text." + (interactive) + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (let ((buffer-read-only nil)) + (while (search-forward "\b" nil t) + (let ((next (following-char)) + (previous (char-after (- (point) 2)))) + ;; We do the boldification/underlining by hiding the + ;; overstrikes and putting the proper text property + ;; on the letters. + (cond + ((eq next previous) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property (point) (1+ (point)) 'face 'bold)) + ((eq next ?_) + (gnus-article-hide-text-type + (1- (point)) (1+ (point)) 'overstrike) + (put-text-property + (- (point) 2) (1- (point)) 'face 'underline)) + ((eq previous ?_) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property + (point) (1+ (point)) 'face 'underline))))))))) + +(defun article-fill () + "Format too long lines." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (end-of-line 1) + (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") + (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") + (adaptive-fill-mode t)) + (while (not (eobp)) + (and (>= (current-column) (min fill-column (window-width))) + (/= (preceding-char) ?:) + (fill-paragraph nil)) + (end-of-line 2)))))) + +(defun article-remove-cr () + "Remove carriage returns from an article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (replace-match "" t t))))) + +(defun article-remove-trailing-blank-lines () + "Remove all trailing blank lines from the article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (delete-region + (point) + (progn + (while (and (not (bobp)) + (looking-at "^[ \t]*$")) + (forward-line -1)) + (forward-line 1) + (point)))))) + +(defun article-display-x-face (&optional force) + "Look for an X-Face header and display it if present." + (interactive (list 'force)) + (save-excursion + ;; Delete the old process, if any. + (when (process-status "article-x-face") + (delete-process "article-x-face")) + (let ((inhibit-point-motion-hooks t) + (case-fold-search nil) + from) + (save-restriction + (nnheader-narrow-to-headers) + (setq from (message-fetch-field "from")) + (goto-char (point-min)) + (while (and gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and gnus-article-x-face-too-ugly from + (not (string-match gnus-article-x-face-too-ugly + from)))) + ;; Has to be present. + (re-search-forward "^X-Face: " nil t)) + ;; We now have the area of the buffer where the X-Face is stored. + (save-excursion + (let ((beg (point)) + (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) + ;; We display the face. + (if (symbolp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (if (gnus-functionp gnus-article-x-face-command) + (funcall gnus-article-x-face-command beg end) + (error "%s is not a function" gnus-article-x-face-command)) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name shell-command-switch + gnus-article-x-face-command)) + (process-send-region "article-x-face" beg end) + (process-send-eof "article-x-face")))))))))) + +(defun gnus-hack-decode-rfc1522 () + "Emergency hack function for avoiding problems when decoding." + (let ((buffer-read-only nil)) + (goto-char (point-min)) + ;; Remove encoded TABs. + (while (search-forward "=09" nil t) + (replace-match " " t t)) + ;; Remove encoded newlines. + (goto-char (point-min)) + (while (search-forward "=10" nil t) + (replace-match " " t t)))) + +(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) +(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) +(defun article-decode-rfc1522 () + "Hack to remove QP encoding from headers." + (let ((case-fold-search t) + (inhibit-point-motion-hooks t) + (buffer-read-only nil) + string) + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point-max))) + (goto-char (point-min)) + (while (re-search-forward + "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) + (setq string (match-string 1)) + (save-restriction + (narrow-to-region (match-beginning 0) (match-end 0)) + (delete-region (point-min) (point-max)) + (insert string) + (article-mime-decode-quoted-printable + (goto-char (point-min)) (point-max)) + (subst-char-in-region (point-min) (point-max) ?_ ? ) + (goto-char (point-max))) + (goto-char (point-min)))))) + +(defun article-de-quoted-unreadable (&optional force) + "Do a naive translation of a quoted-printable-encoded article. +This is in no way, shape or form meant as a replacement for real MIME +processing, but is simply a stop-gap measure until MIME support is +written. +If FORCE, decode the article whether it is marked as quoted-printable +or not." + (interactive (list 'force)) + (save-excursion + (let ((case-fold-search t) + (buffer-read-only nil) + (type (gnus-fetch-field "content-transfer-encoding"))) + (gnus-article-decode-rfc1522) + (when (or force + (and type (string-match "quoted-printable" (downcase type)))) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (article-mime-decode-quoted-printable (point) (point-max)))))) + +(defun article-mime-decode-quoted-printable-buffer () + "Decode Quoted-Printable in the current buffer." + (article-mime-decode-quoted-printable (point-min) (point-max))) + +(defun article-mime-decode-quoted-printable (from to) + "Decode Quoted-Printable in the region between FROM and TO." + (interactive "r") + (goto-char from) + (while (search-forward "=" to t) + (cond ((eq (following-char) ?\n) + (delete-char -1) + (delete-char 1)) + ((looking-at "[0-9A-F][0-9A-F]") + (subst-char-in-region + (1- (point)) (point) ?= + (hexl-hex-string-to-integer + (buffer-substring (point) (+ 2 (point))))) + (delete-char 2)) + ((looking-at "=") + (delete-char 1)) + ((gnus-message 3 "Malformed MIME quoted-printable message"))))) + +(defun article-hide-pgp (&optional arg) + "Toggle hiding of any PGP headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'pgp arg) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only beg end) + (widen) + (goto-char (point-min)) + ;; Hide the "header". + (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) + (gnus-article-hide-text-type (1+ (match-beginning 0)) + (match-end 0) 'pgp) + (setq beg (point)) + ;; Hide the actual signature. + (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) + (match-end 0) + ;; Perhaps we shouldn't hide to the end of the buffer + ;; if there is no end to the signature? + (point-max)) + 'pgp)) + ;; Hide "- " PGP quotation markers. + (when (and beg end) + (narrow-to-region beg end) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pgp)) + (widen)) + (run-hooks 'gnus-article-hide-pgp-hook)))))) + +(defun article-hide-pem (&optional arg) + "Toggle hiding of any PEM headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'pem arg) + (save-excursion + (let (buffer-read-only end) + (widen) + (goto-char (point-min)) + ;; hide the horrendously ugly "header". + (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" + nil + t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-max)) + 'pem)) + ;; hide the trailer as well + (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" + nil + t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pem)))))) + +(defun article-hide-signature (&optional arg) + "Hide the signature in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'signature arg) + (save-excursion + (save-restriction + (let ((buffer-read-only nil)) + (when (gnus-article-narrow-to-signature) + (gnus-article-hide-text-type + (point-min) (point-max) 'signature))))))) + +(defun article-strip-leading-blank-lines () + "Remove all blank lines from the beginning of the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (while (and (not (eobp)) + (looking-at "[ \t]*$")) + (gnus-delete-line)))))) + +(defun article-strip-multiple-blank-lines () + "Replace consecutive blank lines with one empty line." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + ;; First make all blank lines empty. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]+$" nil t) + (replace-match "" nil t)) + ;; Then replace multiple empty lines with a single empty line. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "\n\n\n+" nil t) + (replace-match "\n\n" t t))))) + +(defun article-strip-leading-space () + "Remove all white space from the beginning of the lines in the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]+" nil t) + (replace-match "" t t))))) + +(defun article-strip-blank-lines () + "Strip leading, trailing and multiple blank lines." + (interactive) + (article-strip-leading-blank-lines) + (article-remove-trailing-blank-lines) + (article-strip-multiple-blank-lines)) + +(defvar mime::preview/content-list) +(defvar mime::preview-content-info/point-min) +(defun gnus-article-narrow-to-signature () + "Narrow to the signature; return t if a signature is found, else nil." + (widen) + (when (and (boundp 'mime::preview/content-list) + mime::preview/content-list) + ;; We have a MIMEish article, so we use the MIME data to narrow. + (let ((pcinfo (car (last mime::preview/content-list)))) + (ignore-errors + (narrow-to-region + (funcall (intern "mime::preview-content-info/point-min") pcinfo) + (point-max))))) + + (when (gnus-article-search-signature) + (forward-line 1) + ;; Check whether we have some limits to what we consider + ;; to be a signature. + (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit + (list gnus-signature-limit))) + limit limited) + (while (setq limit (pop limits)) + (if (or (and (integerp limit) + (< (- (point-max) (point)) limit)) + (and (floatp limit) + (< (count-lines (point) (point-max)) limit)) + (and (gnus-functionp limit) + (funcall limit)) + (and (stringp limit) + (not (re-search-forward limit nil t)))) + () ; This limit did not succeed. + (setq limited t + limits nil))) + (unless limited + (narrow-to-region (point) (point-max)) + t)))) + +(defun gnus-article-search-signature () + "Search the current buffer for the signature separator. +Put point at the beginning of the signature separator." + (let ((cur (point))) + (goto-char (point-max)) + (if (if (stringp gnus-signature-separator) + (re-search-backward gnus-signature-separator nil t) + (let ((seps gnus-signature-separator)) + (while (and seps + (not (re-search-backward (car seps) nil t))) + (pop seps)) + seps)) + t + (goto-char cur) + nil))) + +(eval-and-compile + (autoload 'w3-display "w3-parse") + (autoload 'w3-do-setup "w3" "" t) + (autoload 'w3-region "w3-display" "" t)) + +(defun gnus-article-treat-html () + "Render HTML." + (interactive) + (let ((cbuf (current-buffer))) + (set-buffer gnus-article-buffer) + (let (buf buffer-read-only b e) + (w3-do-setup) + (goto-char (point-min)) + (narrow-to-region + (if (search-forward "\n\n" nil t) + (setq b (point)) + (point-max)) + (setq e (point-max))) + (nnheader-temp-write nil + (insert-buffer-substring gnus-article-buffer b e) + (require 'url) + (save-window-excursion + (w3-region (point-min) (point-max)) + (setq buf (buffer-substring-no-properties (point-min) (point-max))))) + (when buf + (delete-region (point-min) (point-max)) + (insert buf)) + (widen) + (goto-char (point-min)) + (set-window-start (get-buffer-window (current-buffer)) (point-min)) + (set-buffer cbuf)))) + +(defun gnus-article-hidden-arg () + "Return the current prefix arg as a number, or 0 if no prefix." + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 0))) + +(defun gnus-article-check-hidden-text (type arg) + "Return nil if hiding is necessary. +Arg can be nil or a number. Nil and positive means hide, negative +means show, 0 means toggle." + (save-excursion + (save-restriction + (widen) + (let ((hide (gnus-article-hidden-text-p type))) + (cond + ((or (null arg) + (> arg 0)) + nil) + ((< arg 0) + (gnus-article-show-hidden-text type)) + (t + (if (eq hide 'hidden) + (gnus-article-show-hidden-text type) + nil))))))) + +(defun gnus-article-hidden-text-p (type) + "Say whether the current buffer contains hidden text of type TYPE." + (let ((start (point-min)) + (pos (text-property-any (point-min) (point-max) 'article-type type))) + (while (and pos + (not (get-text-property pos 'invisible))) + (setq pos + (text-property-any (1+ pos) (point-max) 'article-type type))) + (if pos + 'hidden + 'shown))) + +(defun gnus-article-show-hidden-text (type &optional hide) + "Show all hidden text of type TYPE. +If HIDE, hide the text instead." + (save-excursion + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (end (point-min)) + beg) + (while (setq beg (text-property-any end (point-max) 'article-type type)) + (goto-char beg) + (setq end (or + (text-property-not-all beg (point-max) 'article-type type) + (point-max))) + (if hide + (gnus-article-hide-text beg end gnus-hidden-properties) + (gnus-article-unhide-text beg end)) + (goto-char end)) + t))) + +(defconst article-time-units + `((year . ,(* 365.25 24 60 60)) + (week . ,(* 7 24 60 60)) + (day . ,(* 24 60 60)) + (hour . ,(* 60 60)) + (minute . 60) + (second . 1)) + "Mapping from time units to seconds.") + +(defun article-date-ut (&optional type highlight header) + "Convert DATE date to universal time in the current article. +If TYPE is `local', convert to local time; if it is `lapsed', output +how much time has lapsed since DATE." + (interactive (list 'ut t)) + (let* ((header (or header + (mail-header-date gnus-current-headers) + (message-fetch-field "date") + "")) + (date (if (vectorp header) (mail-header-date header) + header)) + (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") + (inhibit-point-motion-hooks t) + bface eface) + (when (and date (not (string= date ""))) + (save-excursion + (save-restriction + (nnheader-narrow-to-headers) + (let ((buffer-read-only nil)) + ;; Delete any old Date headers. + (if (re-search-forward date-regexp nil t) + (progn + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) + 'face)) + (message-remove-header date-regexp t) + (beginning-of-line)) + (goto-char (point-max))) + (insert (article-make-date-line date type)) + ;; Do highlighting. + (forward-line -1) + (when (looking-at "\\([^:]+\\): *\\(.*\\)$") + (put-text-property (match-beginning 1) (match-end 1) + 'face bface) + (put-text-property (match-beginning 2) (match-end 2) + 'face eface)))))))) + +(defun article-make-date-line (date type) + "Return a DATE line of TYPE." + (cond + ;; Convert to the local timezone. We have to slap a + ;; `condition-case' round the calls to the timezone + ;; functions since they aren't particularly resistant to + ;; buggy dates. + ((eq type 'local) + (concat "Date: " (condition-case () + (timezone-make-date-arpa-standard date) + (error date)) + "\n")) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (condition-case () + (timezone-make-date-arpa-standard date nil "UT") + (error date)) + "\n")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " date "\n")) + ;; Let the user define the format. + ((eq type 'user) + (concat + "Date: " + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT")))) + "\n")) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time + (ignore-errors + (gnus-time-minus + (gnus-encode-date + (timezone-make-date-arpa-standard + (current-time-string now) + (current-time-zone now) "UT")) + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown\n") + ((zerop sec) + "X-Sent: Now\n") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago\n" + " in the future\n")))))) + (t + (error "Unknown conversion type: %s" type)))) + +(defun article-date-local (&optional highlight) + "Convert the current article date to the local timezone." + (interactive (list t)) + (article-date-ut 'local highlight)) + +(defun article-date-original (&optional highlight) + "Convert the current article date to what it was originally. +This is only useful if you have used some other date conversion +function and want to see what the date was before converting." + (interactive (list t)) + (article-date-ut 'original highlight)) + +(defun article-date-lapsed (&optional highlight) + "Convert the current article date to time lapsed since it was sent." + (interactive (list t)) + (article-date-ut 'lapsed highlight)) + +(defun article-date-user (&optional highlight) + "Convert the current article date to the user-defined format. +This format is defined by the `gnus-article-time-format' variable." + (interactive (list t)) + (article-date-ut 'user highlight)) + +(defun article-show-all () + "Show all hidden text in the article buffer." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (gnus-article-unhide-text (point-min) (point-max))))) + +(defun article-emphasize (&optional arg) + "Emphasize text according to `gnus-emphasis-alist'." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'emphasis arg) + (save-excursion + (let ((alist gnus-emphasis-alist) + (buffer-read-only nil) + (props (append '(article-type emphasis) + gnus-hidden-properties)) + regexp elem beg invisible visible face) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq beg (point)) + (while (setq elem (pop alist)) + (goto-char beg) + (setq regexp (car elem) + invisible (nth 1 elem) + visible (nth 2 elem) + face (nth 3 elem)) + (while (re-search-forward regexp nil t) + (when (and (match-beginning visible) (match-beginning invisible)) + (gnus-article-hide-text + (match-beginning invisible) (match-end invisible) props) + (gnus-article-unhide-text-type + (match-beginning visible) (match-end visible) 'emphasis) + (gnus-put-text-property-excluding-newlines + (match-beginning visible) (match-end visible) 'face face) + (goto-char (match-end invisible))))))))) + +(defvar gnus-summary-article-menu) +(defvar gnus-summary-post-menu) + +;;; Saving functions. + +(defun gnus-article-save (save-buffer file &optional num) + "Save the currently selected article." + (unless gnus-save-all-headers + ;; Remove headers according to `gnus-saved-headers'. + (let ((gnus-visible-headers + (or gnus-saved-headers gnus-visible-headers)) + (gnus-article-buffer save-buffer)) + (gnus-article-hide-headers 1 t))) + (save-window-excursion + (if (not gnus-default-article-saver) + (error "No default saver is defined") + ;; !!! Magic! The saving functions all save + ;; `gnus-original-article-buffer' (or so they think), but we + ;; bind that variable to our save-buffer. + (set-buffer gnus-article-buffer) + (let* ((gnus-save-article-buffer save-buffer) + (filename + (cond + ((not gnus-prompt-before-saving) 'default) + ((eq gnus-prompt-before-saving 'always) nil) + (t file))) + (gnus-number-of-articles-to-be-saved + (when (eq gnus-prompt-before-saving t) + num))) ; Magic + (set-buffer gnus-summary-buffer) + (funcall gnus-default-article-saver filename))))) + +(defun gnus-read-save-file-name (prompt &optional filename + function group headers variable) + (let ((default-name + (funcall function group headers (symbol-value variable))) + result) + (setq + result + (cond + ((eq filename 'default) + default-name) + ((eq filename t) + default-name) + (filename filename) + (t + (let* ((split-name (gnus-get-split-value gnus-split-methods)) + (prompt + (format prompt + (if (and gnus-number-of-articles-to-be-saved + (> gnus-number-of-articles-to-be-saved 1)) + (format "these %d articles" + gnus-number-of-articles-to-be-saved) + "this article"))) + (file + ;; Let the split methods have their say. + (cond + ;; No split name was found. + ((null split-name) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single group name is returned. + ((stringp split-name) + (setq default-name + (funcall function split-name headers + (symbol-value variable))) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single split name was found + ((= 1 (length split-name)) + (let* ((name (expand-file-name + (car split-name) gnus-article-save-directory)) + (dir (cond ((file-directory-p name) + (file-name-as-directory name)) + ((file-exists-p name) name) + (t gnus-article-save-directory)))) + (read-file-name + (concat prompt " (default " name ") ") + dir name))) + ;; A list of splits was found. + (t + (setq split-name (nreverse split-name)) + (let (result) + (let ((file-name-history + (nconc split-name file-name-history))) + (setq result + (expand-file-name + (read-file-name + (concat prompt " (`M-p' for defaults) ") + gnus-article-save-directory + (car split-name)) + gnus-article-save-directory))) + (car (push result file-name-history))))))) + ;; Create the directory. + (gnus-make-directory (file-name-directory file)) + ;; If we have read a directory, we append the default file name. + (when (file-directory-p file) + (setq file (concat (file-name-as-directory file) + (file-name-nondirectory default-name)))) + ;; Possibly translate some characters. + (nnheader-translate-file-chars file))))) + (gnus-make-directory (file-name-directory result)) + (set variable result))) + +(defun gnus-article-archive-name (group) + "Return the first instance of an \"Archive-name\" in the current buffer." + (let ((case-fold-search t)) + (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t) + (nnheader-concat gnus-article-save-directory + (match-string 1))))) + +(defun gnus-article-nndoc-name (group) + "If GROUP is an nndoc group, return the name of the parent group." + (when (eq (car (gnus-find-method-for-group group)) 'nndoc) + (gnus-group-get-parameter group 'save-article-group))) + +(defun gnus-summary-save-in-rmail (&optional filename) + "Append this article to Rmail file. +Optional argument FILENAME specifies file name. +Directory to save to is default to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (setq filename (gnus-read-save-file-name + "Save %s in rmail file:" filename + gnus-rmail-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-rmail)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (gnus-output-to-rmail filename))))) + +(defun gnus-summary-save-in-mail (&optional filename) + "Append this article to Unix mail file. +Optional argument FILENAME specifies file name. +Directory to save to is default to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (setq filename (gnus-read-save-file-name + "Save %s in Unix mail file:" filename + gnus-mail-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-mail)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (if (and (file-readable-p filename) + (mail-file-babyl-p filename)) + (gnus-output-to-rmail filename t) + (gnus-output-to-mail filename)))))) + +(defun gnus-summary-save-in-file (&optional filename overwrite) + "Append this article to file. +Optional argument FILENAME specifies file name. +Directory to save to is default to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (setq filename (gnus-read-save-file-name + "Save %s in file:" filename + gnus-file-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-file)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (when (and overwrite + (file-exists-p filename)) + (delete-file filename)) + (gnus-output-to-file filename))))) + +(defun gnus-summary-write-to-file (&optional filename) + "Write this article to a file. +Optional argument FILENAME specifies file name. +The directory to save in defaults to `gnus-article-save-directory'." + (interactive) + (gnus-summary-save-in-file nil t)) + +(defun gnus-summary-save-body-in-file (&optional filename) + "Append this article body to a file. +Optional argument FILENAME specifies file name. +The directory to save in defaults to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (setq filename (gnus-read-save-file-name + "Save %s body in file:" filename + gnus-file-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-file)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (narrow-to-region (point) (point-max))) + (gnus-output-to-file filename))))) + +(defun gnus-summary-save-in-pipe (&optional command) + "Pipe this article to subprocess." + (interactive) + (gnus-set-global-variables) + (setq command + (cond ((eq command 'default) + gnus-last-shell-command) + (command command) + (t (read-string + (format + "Shell command on %s: " + (if (and gnus-number-of-articles-to-be-saved + (> gnus-number-of-articles-to-be-saved 1)) + (format "these %d articles" + gnus-number-of-articles-to-be-saved) + "this article")) + gnus-last-shell-command)))) + (when (string-equal command "") + (setq command gnus-last-shell-command)) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (shell-command-on-region (point-min) (point-max) command nil))) + (setq gnus-last-shell-command command)) + +;;; Article file names when saving. + +(defun gnus-capitalize-newsgroup (newsgroup) + "Capitalize NEWSGROUP name." + (when (not (zerop (length newsgroup))) + (concat (char-to-string (upcase (aref newsgroup 0))) + (substring newsgroup 1)))) + +(defun gnus-Numeric-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num. +Otherwise, it is like ~/News/news/group/num." + (let ((default + (expand-file-name + (concat (if (gnus-use-long-file-name 'not-save) + (gnus-capitalize-newsgroup newsgroup) + (gnus-newsgroup-directory-form newsgroup)) + "/" (int-to-string (mail-header-number headers))) + gnus-article-save-directory))) + (if (and last-file + (string-equal (file-name-directory default) + (file-name-directory last-file)) + (string-match "^[0-9]+$" (file-name-nondirectory last-file))) + default + (or last-file default)))) + +(defun gnus-numeric-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is +~/News/news.group/num. Otherwise, it is like ~/News/news/group/num." + (let ((default + (expand-file-name + (concat (if (gnus-use-long-file-name 'not-save) + newsgroup + (gnus-newsgroup-directory-form newsgroup)) + "/" (int-to-string (mail-header-number headers))) + gnus-article-save-directory))) + (if (and last-file + (string-equal (file-name-directory default) + (file-name-directory last-file)) + (string-match "^[0-9]+$" (file-name-nondirectory last-file))) + default + (or last-file default)))) + +(defun gnus-Plain-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is +~/News/News.group. Otherwise, it is like ~/News/news/group/news." + (or last-file + (expand-file-name + (if (gnus-use-long-file-name 'not-save) + (gnus-capitalize-newsgroup newsgroup) + (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + gnus-article-save-directory))) + +(defun gnus-plain-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is +~/News/news.group. Otherwise, it is like ~/News/news/group/news." + (or last-file + (expand-file-name + (if (gnus-use-long-file-name 'not-save) + newsgroup + (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + gnus-article-save-directory))) + +(eval-and-compile + (mapcar + (lambda (func) + (let (afunc gfunc) + (if (consp func) + (setq afunc (car func) + gfunc (cdr func)) + (setq afunc func + gfunc (intern (format "gnus-%s" func)))) + (fset gfunc + (if (not (fboundp afunc)) + nil + `(lambda (&optional interactive &rest args) + ,(documentation afunc t) + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively ',afunc) + (apply ',afunc args)))))))) + '(article-hide-headers + article-hide-boring-headers + article-treat-overstrike + (article-fill . gnus-article-word-wrap) + article-remove-cr + article-display-x-face + article-de-quoted-unreadable + article-mime-decode-quoted-printable + article-hide-pgp + article-hide-pem + article-hide-signature + article-remove-trailing-blank-lines + article-strip-leading-blank-lines + article-strip-multiple-blank-lines + article-strip-leading-space + article-strip-blank-lines + article-date-local + article-date-original + article-date-ut + article-date-user + article-date-lapsed + article-emphasize + (article-show-all . gnus-article-show-all-headers)))) + +;;; +;;; Gnus article mode +;;; + +(put 'gnus-article-mode 'mode-class 'special) + +(gnus-define-keys gnus-article-mode-map + " " gnus-article-goto-next-page + "\177" gnus-article-goto-prev-page + [delete] gnus-article-goto-prev-page + "\C-c^" gnus-article-refer-article + "h" gnus-article-show-summary + "s" gnus-article-show-summary + "\C-c\C-m" gnus-article-mail + "?" gnus-article-describe-briefly + gnus-mouse-2 gnus-article-push-button + "\r" gnus-article-press-button + "\t" gnus-article-next-button + "\M-\t" gnus-article-prev-button + "e" gnus-article-edit + "<" beginning-of-buffer + ">" end-of-buffer + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug + + "\C-d" gnus-article-read-summary-keys + "\M-*" gnus-article-read-summary-keys + "\M-#" gnus-article-read-summary-keys + "\M-^" gnus-article-read-summary-keys + "\M-g" gnus-article-read-summary-keys) + +(substitute-key-definition + 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) + +(defun gnus-article-make-menu-bar () + (gnus-turn-off-edit-menu 'article) + (unless (boundp 'gnus-article-article-menu) + (easy-menu-define + gnus-article-article-menu gnus-article-mode-map "" + '("Article" + ["Scroll forwards" gnus-article-goto-next-page t] + ["Scroll backwards" gnus-article-goto-prev-page t] + ["Show summary" gnus-article-show-summary t] + ["Fetch Message-ID at point" gnus-article-refer-article t] + ["Mail to address at point" gnus-article-mail t])) + + (easy-menu-define + gnus-article-treatment-menu gnus-article-mode-map "" + '("Treatment" + ["Hide headers" gnus-article-hide-headers t] + ["Hide signature" gnus-article-hide-signature t] + ["Hide citation" gnus-article-hide-citation t] + ["Treat overstrike" gnus-article-treat-overstrike t] + ["Remove carriage return" gnus-article-remove-cr t] + ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) + + (when nil + (when (boundp 'gnus-summary-article-menu) + (define-key gnus-article-mode-map [menu-bar commands] + (cons "Commands" gnus-summary-article-menu)))) + + (when (boundp 'gnus-summary-post-menu) + (define-key gnus-article-mode-map [menu-bar post] + (cons "Post" gnus-summary-post-menu))) + + (run-hooks 'gnus-article-menu-hook))) + +(defun gnus-article-mode () + "Major mode for displaying an article. + +All normal editing commands are switched off. + +The following commands are available in addition to all summary mode +commands: +\\ +\\[gnus-article-next-page]\t Scroll the article one page forwards +\\[gnus-article-prev-page]\t Scroll the article one page backwards +\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point +\\[gnus-article-show-summary]\t Display the summary buffer +\\[gnus-article-mail]\t Send a reply to the address near point +\\[gnus-article-describe-briefly]\t Describe the current mode briefly +\\[gnus-info-find-node]\t Go to the Gnus info node" + (interactive) + (when (gnus-visual-p 'article-menu 'menu) + (gnus-article-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq mode-name "Article") + (setq major-mode 'gnus-article-mode) + (make-local-variable 'minor-mode-alist) + (unless (assq 'gnus-show-mime minor-mode-alist) + (push (list 'gnus-show-mime " MIME") minor-mode-alist)) + (use-local-map gnus-article-mode-map) + (gnus-update-format-specifications nil 'article-mode) + (set (make-local-variable 'page-delimiter) gnus-page-delimiter) + (set (make-local-variable 'gnus-page-broken) nil) + (set (make-local-variable 'gnus-button-marker-list) nil) + (gnus-set-default-directory) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (set-syntax-table gnus-article-mode-syntax-table) + (run-hooks 'gnus-article-mode-hook)) + +(defun gnus-article-setup-buffer () + "Initialize the article buffer." + (let* ((name (if gnus-single-article-buffer "*Article*" + (concat "*Article " gnus-newsgroup-name "*"))) + (original + (progn (string-match "\\*Article" name) + (concat " *Original Article" + (substring name (match-end 0)))))) + (setq gnus-article-buffer name) + (setq gnus-original-article-buffer original) + ;; This might be a variable local to the summary buffer. + (unless gnus-single-article-buffer + (save-excursion + (set-buffer gnus-summary-buffer) + (setq gnus-article-buffer name) + (setq gnus-original-article-buffer original) + (gnus-set-global-variables))) + ;; Init original article buffer. + (save-excursion + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (buffer-disable-undo (current-buffer)) + (setq major-mode 'gnus-original-article-mode) + (gnus-add-current-to-buffer-list) + (make-local-variable 'gnus-original-article)) + (if (get-buffer name) + (save-excursion + (set-buffer name) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (gnus-add-current-to-buffer-list) + (unless (eq major-mode 'gnus-article-mode) + (gnus-article-mode)) + (current-buffer)) + (save-excursion + (set-buffer (get-buffer-create name)) + (gnus-add-current-to-buffer-list) + (gnus-article-mode) + (make-local-variable 'gnus-summary-buffer) + (current-buffer))))) + +;; Set article window start at LINE, where LINE is the number of lines +;; from the head of the article. +(defun gnus-article-set-window-start (&optional line) + (set-window-start + (get-buffer-window gnus-article-buffer t) + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (if (not line) + (point-min) + (gnus-message 6 "Moved to bookmark") + (search-forward "\n\n" nil t) + (forward-line line) + (point))))) + +(defun gnus-article-prepare (article &optional all-headers header) + "Prepare ARTICLE in article mode buffer. +ARTICLE should either be an article number or a Message-ID. +If ARTICLE is an id, HEADER should be the article headers. +If ALL-HEADERS is non-nil, no headers are hidden." + (save-excursion + ;; Make sure we start in a summary buffer. + (unless (eq major-mode 'gnus-summary-mode) + (set-buffer gnus-summary-buffer)) + (setq gnus-summary-buffer (current-buffer)) + ;; Make sure the connection to the server is alive. + (unless (gnus-server-opened + (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-request-group gnus-newsgroup-name t)) + (let* ((gnus-article (if header (mail-header-number header) article)) + (summary-buffer (current-buffer)) + (internal-hook gnus-article-internal-prepare-hook) + (group gnus-newsgroup-name) + result) + (save-excursion + (gnus-article-setup-buffer) + (set-buffer gnus-article-buffer) + ;; Deactivate active regions. + (when (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active nil)) + (if (not (setq result (let ((buffer-read-only nil)) + (gnus-request-article-this-buffer + article group)))) + ;; There is no such article. + (save-excursion + (when (and (numberp article) + (not (memq article gnus-newsgroup-sparse))) + (setq gnus-article-current + (cons gnus-newsgroup-name article)) + (set-buffer gnus-summary-buffer) + (setq gnus-current-article article) + (gnus-summary-mark-article article gnus-canceled-mark)) + (unless (memq article gnus-newsgroup-sparse) + (gnus-error + 1 "No such article (may have expired or been canceled)"))) + (if (or (eq result 'pseudo) (eq result 'nneething)) + (progn + (save-excursion + (set-buffer summary-buffer) + (setq gnus-last-article gnus-current-article + gnus-newsgroup-history (cons gnus-current-article + gnus-newsgroup-history) + gnus-current-article 0 + gnus-current-headers nil + gnus-article-current nil) + (if (eq result 'nneething) + (gnus-configure-windows 'summary) + (gnus-configure-windows 'article)) + (gnus-set-global-variables)) + (gnus-set-mode-line 'article)) + ;; The result from the `request' was an actual article - + ;; or at least some text that is now displayed in the + ;; article buffer. + (when (and (numberp article) + (not (eq article gnus-current-article))) + ;; Seems like a new article has been selected. + ;; `gnus-current-article' must be an article number. + (save-excursion + (set-buffer summary-buffer) + (setq gnus-last-article gnus-current-article + gnus-newsgroup-history (cons gnus-current-article + gnus-newsgroup-history) + gnus-current-article article + gnus-current-headers + (gnus-summary-article-header gnus-current-article) + gnus-article-current + (cons gnus-newsgroup-name gnus-current-article)) + (unless (vectorp gnus-current-headers) + (setq gnus-current-headers nil)) + (gnus-summary-goto-subject gnus-current-article) + (gnus-summary-show-thread) + (run-hooks 'gnus-mark-article-hook) + (gnus-set-mode-line 'summary) + (when (gnus-visual-p 'article-highlight 'highlight) + (run-hooks 'gnus-visual-mark-article-hook)) + ;; Set the global newsgroup variables here. + ;; Suggested by Jim Sisolak + ;; . + (gnus-set-global-variables) + (setq gnus-have-all-headers + (or all-headers gnus-show-all-headers)) + (and gnus-use-cache + (vectorp (gnus-summary-article-header article)) + (gnus-cache-possibly-enter-article + group article + (gnus-summary-article-header article) + (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-unreads))))) + (when (or (numberp article) + (stringp article)) + ;; Hooks for getting information from the article. + ;; This hook must be called before being narrowed. + (let (buffer-read-only) + (run-hooks 'internal-hook) + (run-hooks 'gnus-article-prepare-hook) + ;; Decode MIME message. + (when gnus-show-mime + (if (or (not gnus-strict-mime) + (gnus-fetch-field "Mime-Version")) + (funcall gnus-show-mime-method) + (funcall gnus-decode-encoded-word-method))) + ;; Perform the article display hooks. + (run-hooks 'gnus-article-display-hook)) + ;; Do page break. + (goto-char (point-min)) + (setq gnus-page-broken + (when gnus-break-pages + (gnus-narrow-to-page) + t))) + (gnus-set-mode-line 'article) + (gnus-configure-windows 'article) + (goto-char (point-min)) + t)))))) + +(defun gnus-article-wash-status () + "Return a string which display status of article washing." + (save-excursion + (set-buffer gnus-article-buffer) + (let ((cite (gnus-article-hidden-text-p 'cite)) + (headers (gnus-article-hidden-text-p 'headers)) + (boring (gnus-article-hidden-text-p 'boring-headers)) + (pgp (gnus-article-hidden-text-p 'pgp)) + (pem (gnus-article-hidden-text-p 'pem)) + (signature (gnus-article-hidden-text-p 'signature)) + (overstrike (gnus-article-hidden-text-p 'overstrike)) + (emphasis (gnus-article-hidden-text-p 'emphasis)) + (mime gnus-show-mime)) + (format "%c%c%c%c%c%c%c" + (if cite ?c ? ) + (if (or headers boring) ?h ? ) + (if (or pgp pem) ?p ? ) + (if signature ?s ? ) + (if overstrike ?o ? ) + (if mime ?m ? ) + (if emphasis ?e ? ))))) + +(defun gnus-article-hide-headers-if-wanted () + "Hide unwanted headers if `gnus-have-all-headers' is nil. +Provided for backwards compatibility." + (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) + gnus-inhibit-hiding + (gnus-article-hide-headers))) + +;;; Article savers. + +(defun gnus-output-to-file (file-name) + "Append the current article to a file named FILE-NAME." + (let ((artbuf (current-buffer))) + (nnheader-temp-write nil + (insert-buffer-substring artbuf) + ;; Append newline at end of the buffer as separator, and then + ;; save it to file. + (goto-char (point-max)) + (insert "\n") + (append-to-file (point-min) (point-max) file-name) + t))) + +(defun gnus-narrow-to-page (&optional arg) + "Narrow the article buffer to a page. +If given a numerical ARG, move forward ARG pages." + (interactive "P") + (setq arg (if arg (prefix-numeric-value arg) 0)) + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (widen) + ;; Remove any old next/prev buttons. + (when (gnus-visual-p 'page-marker) + (let ((buffer-read-only nil)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next))) + (when + (cond ((< arg 0) + (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) + ((> arg 0) + (re-search-forward page-delimiter nil 'move arg))) + (goto-char (match-end 0))) + (narrow-to-region + (point) + (if (re-search-forward page-delimiter nil 'move) + (match-beginning 0) + (point))) + (when (and (gnus-visual-p 'page-marker) + (not (= (point-min) 1))) + (save-excursion + (goto-char (point-min)) + (gnus-insert-prev-page-button))) + (when (and (gnus-visual-p 'page-marker) + (< (+ (point-max) 2) (buffer-size))) + (save-excursion + (goto-char (point-max)) + (gnus-insert-next-page-button))))) + +;; Article mode commands + +(defun gnus-article-goto-next-page () + "Show the next page of the article." + (interactive) + (when (gnus-article-next-page) + (goto-char (point-min)) + (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) + +(defun gnus-article-goto-prev-page () + "Show the next page of the article." + (interactive) + (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) + (gnus-article-prev-page nil))) + +(defun gnus-article-next-page (&optional lines) + "Show the next page of the current article. +If end of article, return non-nil. Otherwise return nil. +Argument LINES specifies lines to be scrolled up." + (interactive "p") + (move-to-window-line -1) + (if (save-excursion + (end-of-line) + (and (pos-visible-in-window-p) ;Not continuation line. + (eobp))) + ;; Nothing in this page. + (if (or (not gnus-page-broken) + (save-excursion + (save-restriction + (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? + t ;Nothing more. + (gnus-narrow-to-page 1) ;Go to next page. + nil) + ;; More in this page. + (let ((scroll-in-place nil)) + (condition-case () + (scroll-up lines) + (end-of-buffer + ;; Long lines may cause an end-of-buffer error. + (goto-char (point-max))))) + (move-to-window-line 0) + nil)) + +(defun gnus-article-prev-page (&optional lines) + "Show previous page of current article. +Argument LINES specifies lines to be scrolled down." + (interactive "p") + (move-to-window-line 0) + (if (and gnus-page-broken + (bobp) + (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? + (progn + (gnus-narrow-to-page -1) ;Go to previous page. + (goto-char (point-max)) + (recenter -1)) + (let ((scroll-in-place nil)) + (prog1 + (condition-case () + (scroll-down lines) + (beginning-of-buffer + (goto-char (point-min)))) + (move-to-window-line 0))))) + +(defun gnus-article-refer-article () + "Read article specified by message-id around point." + (interactive) + (let ((point (point))) + (search-forward ">" nil t) ;Move point to end of "<....>". + (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) + (let ((message-id (match-string 1))) + (goto-char point) + (set-buffer gnus-summary-buffer) + (gnus-summary-refer-article message-id)) + (goto-char (point)) + (error "No references around point")))) + +(defun gnus-article-show-summary () + "Reconfigure windows to show summary buffer." + (interactive) + (if (not (gnus-buffer-live-p gnus-summary-buffer)) + (error "There is no summary buffer for this article buffer") + (gnus-article-set-globals) + (gnus-configure-windows 'article) + (gnus-summary-goto-subject gnus-current-article))) + +(defun gnus-article-describe-briefly () + "Describe article mode commands briefly." + (interactive) + (gnus-message 6 + (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) + +(defun gnus-article-summary-command () + "Execute the last keystroke in the summary buffer." + (interactive) + (let ((obuf (current-buffer)) + (owin (current-window-configuration)) + func) + (switch-to-buffer gnus-summary-buffer 'norecord) + (setq func (lookup-key (current-local-map) (this-command-keys))) + (call-interactively func) + (set-buffer obuf) + (set-window-configuration owin) + (set-window-point (get-buffer-window (current-buffer)) (point)))) + +(defun gnus-article-summary-command-nosave () + "Execute the last keystroke in the summary buffer." + (interactive) + (let (func) + (pop-to-buffer gnus-summary-buffer 'norecord) + (setq func (lookup-key (current-local-map) (this-command-keys))) + (call-interactively func))) + +(defun gnus-article-read-summary-keys (&optional arg key not-restore-window) + "Read a summary buffer key sequence and execute it from the article buffer." + (interactive "P") + (let ((nosaves + '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" + "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "=" "^" "\M-^" "|")) + (nosave-but-article + '("A\r")) + (nosave-in-article + '("\C-d")) + keys) + (save-excursion + (set-buffer gnus-summary-buffer) + (let (gnus-pick-mode) + (push (or key last-command-event) unread-command-events) + (setq keys (read-key-sequence nil)))) + (message "") + + (if (or (member keys nosaves) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-summary-buffer 'norecord) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (not func) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-summary-buffer)) + (call-interactively func)) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer 'norecord))) + ;; These commands should restore window configuration. + (let ((obuf (current-buffer)) + (owin (current-window-configuration)) + (opoint (point)) + func in-buffer) + (if not-restore-window + (pop-to-buffer gnus-summary-buffer 'norecord) + (switch-to-buffer gnus-summary-buffer 'norecord)) + (setq in-buffer (current-buffer)) + ;; We disable the pick minor mode commands. + (if (setq func (let (gnus-pick-mode) + (lookup-key (current-local-map) keys))) + (call-interactively func) + (ding)) + (when (eq in-buffer (current-buffer)) + (set-buffer obuf) + (unless not-restore-window + (set-window-configuration owin)) + (set-window-point (get-buffer-window (current-buffer)) opoint)))))) + +(defun gnus-article-hide (&optional arg force) + "Hide all the gruft in the current article. +This means that PGP stuff, signatures, cited text and (some) +headers will be hidden. +If given a prefix, show the hidden text instead." + (interactive (list current-prefix-arg 'force)) + (gnus-article-hide-headers arg) + (gnus-article-hide-pgp arg) + (gnus-article-hide-citation-maybe arg force) + (gnus-article-hide-signature arg)) + +(defun gnus-article-maybe-highlight () + "Do some article highlighting if `article-visual' is non-nil." + (when (gnus-visual-p 'article-highlight 'highlight) + (gnus-article-highlight-some))) + +(defun gnus-request-article-this-buffer (article group) + "Get an article and insert it into this buffer." + (let (do-update-line) + (prog1 + (save-excursion + (erase-buffer) + (gnus-kill-all-overlays) + (setq group (or group gnus-newsgroup-name)) + + ;; Open server if it has closed. + (gnus-check-server (gnus-find-method-for-group group)) + + ;; Using `gnus-request-article' directly will insert the article into + ;; `nntp-server-buffer' - so we'll save some time by not having to + ;; copy it from the server buffer into the article buffer. + + ;; We only request an article by message-id when we do not have the + ;; headers for it, so we'll have to get those. + (when (stringp article) + (let ((gnus-override-method gnus-refer-article-method)) + (gnus-read-header article))) + + ;; If the article number is negative, that means that this article + ;; doesn't belong in this newsgroup (possibly), so we find its + ;; message-id and request it by id instead of number. + (when (and (numberp article) + gnus-summary-buffer + (get-buffer gnus-summary-buffer) + (buffer-name (get-buffer gnus-summary-buffer))) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((header (gnus-summary-article-header article))) + (when (< article 0) + (cond + ((memq article gnus-newsgroup-sparse) + ;; This is a sparse gap article. + (setq do-update-line article) + (setq article (mail-header-id header)) + (let ((gnus-override-method gnus-refer-article-method)) + (gnus-read-header article)) + (setq gnus-newsgroup-sparse + (delq article gnus-newsgroup-sparse))) + ((vectorp header) + ;; It's a real article. + (setq article (mail-header-id header))) + (t + ;; It is an extracted pseudo-article. + (setq article 'pseudo) + (gnus-request-pseudo-article header)))) + + (let ((method (gnus-find-method-for-group + gnus-newsgroup-name))) + (if (not (eq (car method) 'nneething)) + () + (let ((dir (concat (file-name-as-directory (nth 1 method)) + (mail-header-subject header)))) + (when (file-directory-p dir) + (setq article 'nneething) + (gnus-group-enter-directory dir)))))))) + + (cond + ;; Refuse to select canceled articles. + ((and (numberp article) + gnus-summary-buffer + (get-buffer gnus-summary-buffer) + (buffer-name (get-buffer gnus-summary-buffer)) + (eq (cdr (save-excursion + (set-buffer gnus-summary-buffer) + (assq article gnus-newsgroup-reads))) + gnus-canceled-mark)) + nil) + ;; We first check `gnus-original-article-buffer'. + ((and (get-buffer gnus-original-article-buffer) + (numberp article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (and (equal (car gnus-original-article) group) + (eq (cdr gnus-original-article) article)))) + (insert-buffer-substring gnus-original-article-buffer) + 'article) + ;; Check the backlog. + ((and gnus-keep-backlog + (gnus-backlog-request-article group article (current-buffer))) + 'article) + ;; Check asynchronous pre-fetch. + ((gnus-async-request-fetched-article group article (current-buffer)) + (gnus-async-prefetch-next group article gnus-summary-buffer) + 'article) + ;; Check the cache. + ((and gnus-use-cache + (numberp article) + (gnus-cache-request-article article group)) + 'article) + ;; Get the article and put into the article buffer. + ((or (stringp article) (numberp article)) + (let ((gnus-override-method + (and (stringp article) gnus-refer-article-method)) + (buffer-read-only nil)) + (erase-buffer) + (gnus-kill-all-overlays) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + 'article))) + ;; It was a pseudo. + (t article))) + + ;; Take the article from the original article buffer + ;; and place it in the buffer it's supposed to be in. + (when (and (get-buffer gnus-article-buffer) + ;;(numberp article) + (equal (buffer-name (current-buffer)) + (buffer-name (get-buffer gnus-article-buffer)))) + (save-excursion + (if (get-buffer gnus-original-article-buffer) + (set-buffer (get-buffer gnus-original-article-buffer)) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (buffer-disable-undo (current-buffer)) + (setq major-mode 'gnus-original-article-mode) + (setq buffer-read-only t) + (gnus-add-current-to-buffer-list)) + (let (buffer-read-only) + (erase-buffer) + (insert-buffer-substring gnus-article-buffer)) + (setq gnus-original-article (cons group article)))) + + ;; Update sparse articles. + (when (and do-update-line + (or (numberp article) + (stringp article))) + (let ((buf (current-buffer))) + (set-buffer gnus-summary-buffer) + (gnus-summary-update-article do-update-line) + (gnus-summary-goto-subject do-update-line nil t) + (set-window-point (get-buffer-window (current-buffer) t) + (point)) + (set-buffer buf)))))) + +;;; +;;; Article editing +;;; + +(defcustom gnus-article-edit-mode-hook nil + "Hook run in article edit mode buffers." + :group 'gnus-article-various + :type 'hook) + +(defvar gnus-article-edit-done-function nil) + +(defvar gnus-article-edit-mode-map nil) + +(unless gnus-article-edit-mode-map + (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) + + (gnus-define-keys gnus-article-edit-mode-map + "\C-c\C-c" gnus-article-edit-done + "\C-c\C-k" gnus-article-edit-exit) + + (gnus-define-keys (gnus-article-edit-wash-map + "\C-c\C-w" gnus-article-edit-mode-map) + "f" gnus-article-edit-full-stops)) + +(defun gnus-article-edit-mode () + "Major mode for editing articles. +This is an extended text-mode. + +\\{gnus-article-edit-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'gnus-article-edit-mode) + (setq mode-name "Article Edit") + (use-local-map gnus-article-edit-mode-map) + (make-local-variable 'gnus-article-edit-done-function) + (make-local-variable 'gnus-prev-winconf) + (setq buffer-read-only nil) + (buffer-enable-undo) + (widen) + (run-hooks 'text-mode 'gnus-article-edit-mode-hook)) + +(defun gnus-article-edit (&optional force) + "Edit the current article. +This will have permanent effect only in mail groups. +If FORCE is non-nil, allow editing of articles even in read-only +groups." + (interactive "P") + (when (and (not force) + (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing")) + (gnus-article-edit-article + `(lambda (no-highlight) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)))) + +(defun gnus-article-edit-article (exit-func) + "Start editing the contents of the current article buffer." + (let ((winconf (current-window-configuration))) + (set-buffer gnus-article-buffer) + (gnus-article-edit-mode) + (gnus-set-text-properties (point-min) (point-max) nil) + (gnus-configure-windows 'edit-article) + (setq gnus-article-edit-done-function exit-func) + (setq gnus-prev-winconf winconf) + (gnus-message 6 "C-c C-c to end edits"))) + +(defun gnus-article-edit-done (&optional arg) + "Update the article edits and exit." + (interactive "P") + (let ((func gnus-article-edit-done-function) + (buf (current-buffer)) + (start (window-start))) + (gnus-article-edit-exit) + (save-excursion + (set-buffer buf) + (let ((buffer-read-only nil)) + (funcall func arg))) + (set-buffer buf) + (set-window-start (get-buffer-window buf) start) + (set-window-point (get-buffer-window buf) (point)))) + +(defun gnus-article-edit-exit () + "Exit the article editing without updating." + (interactive) + ;; We remove all text props from the article buffer. + (let ((buf (format "%s" (buffer-string))) + (curbuf (current-buffer)) + (p (point)) + (window-start (window-start))) + (erase-buffer) + (insert buf) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + ;; The cache and backlog have to be flushed somewhat. + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current))) + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + ;; Flush original article as well. + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (let ((buf (current-buffer))) + (set-buffer curbuf) + (set-window-start (get-buffer-window (current-buffer)) window-start) + (goto-char p) + (set-buffer buf))))) + +(defun gnus-article-edit-full-stops () + "Interactively repair spacing at end of sentences." + (interactive) + (save-excursion + (goto-char (point-min)) + (search-forward-regexp "^$" nil t) + (let ((case-fold-search nil)) + (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) + +;;; +;;; Article highlights +;;; + +;; Written by Per Abrahamsen . + +;;; Internal Variables: + +(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" + "Regular expression that matches URLs." + :group 'gnus-article-buttons + :type 'regexp) + +(defcustom gnus-button-alist + `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t + gnus-button-message-id 2) + ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) + ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t + gnus-button-fetch-group 4) + ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) + ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 + t gnus-button-message-id 3) + ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) + ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) + ;; This is how URLs _should_ be embedded in text... + ("]*\\)>" 0 t gnus-button-embedded-url 1) + ;; Raw URLs. + (,gnus-button-url-regexp 0 t gnus-button-url 0)) + "Alist of regexps matching buttons in article bodies. + +Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where +REGEXP: is the string matching text around the button, +BUTTON: is the number of the regexp grouping actually matching the button, +FORM: is a lisp expression which must eval to true for the button to +be added, +CALLBACK: is the function to call when the user push this button, and each +PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. + +CALLBACK can also be a variable, in that case the value of that +variable it the real callback function." + :group 'gnus-article-buttons + :type '(repeat (list regexp + (integer :tag "Button") + (sexp :tag "Form") + (function :tag "Callback") + (repeat :tag "Par" + :inline t + (integer :tag "Regexp group"))))) + +(defcustom gnus-header-button-alist + `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" + 0 t gnus-button-message-id 0) + ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) + ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" + 0 t gnus-button-mailto 0) + ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t + gnus-button-message-id 3)) + "Alist of headers and regexps to match buttons in article heads. + +This alist is very similar to `gnus-button-alist', except that each +alist has an additional HEADER element first in each entry: + +\(HEADER REGEXP BUTTON FORM CALLBACK PAR) + +HEADER is a regexp to match a header. For a fuller explanation, see +`gnus-button-alist'." + :group 'gnus-article-buttons + :group 'gnus-article-headers + :type '(repeat (list (regexp :tag "Header") + regexp + (integer :tag "Button") + (sexp :tag "Form") + (function :tag "Callback") + (repeat :tag "Par" + :inline t + (integer :tag "Regexp group"))))) + +(defvar gnus-button-regexp nil) +(defvar gnus-button-marker-list nil) +;; Regexp matching any of the regexps from `gnus-button-alist'. + +(defvar gnus-button-last nil) +;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. + +;;; Commands: + +(defun gnus-article-push-button (event) + "Check text under the mouse pointer for a callback function. +If the text under the mouse pointer has a `gnus-callback' property, +call it with the value of the `gnus-data' text property." + (interactive "e") + (set-buffer (window-buffer (posn-window (event-start event)))) + (let* ((pos (posn-point (event-start event))) + (data (get-text-property pos 'gnus-data)) + (fun (get-text-property pos 'gnus-callback))) + (when fun + (funcall fun data)))) + +(defun gnus-article-press-button () + "Check text at point for a callback function. +If the text at point has a `gnus-callback' property, +call it with the value of the `gnus-data' text property." + (interactive) + (let* ((data (get-text-property (point) 'gnus-data)) + (fun (get-text-property (point) 'gnus-callback))) + (when fun + (funcall fun data)))) + +(defun gnus-article-prev-button (n) + "Move point to N buttons backward. +If N is negative, move forward instead." + (interactive "p") + (gnus-article-next-button (- n))) + +(defun gnus-article-next-button (n) + "Move point to N buttons forward. +If N is negative, move backward instead." + (interactive "p") + (let ((function (if (< n 0) 'previous-single-property-change + 'next-single-property-change)) + (inhibit-point-motion-hooks t) + (backward (< n 0)) + (limit (if (< n 0) (point-min) (point-max)))) + (setq n (abs n)) + (while (and (not (= limit (point))) + (> n 0)) + ;; Skip past the current button. + (when (get-text-property (point) 'gnus-callback) + (goto-char (funcall function (point) 'gnus-callback nil limit))) + ;; Go to the next (or previous) button. + (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) + ;; Put point at the start of the button. + (when (and backward (not (get-text-property (point) 'gnus-callback))) + (goto-char (funcall function (point) 'gnus-callback nil limit))) + ;; Skip past intangible buttons. + (when (get-text-property (point) 'intangible) + (incf n)) + (decf n)) + (unless (zerop n) + (gnus-message 5 "No more buttons")) + n)) + +(defun gnus-article-highlight (&optional force) + "Highlight current article. +This function calls `gnus-article-highlight-headers', +`gnus-article-highlight-citation', +`gnus-article-highlight-signature', and `gnus-article-add-buttons' to +do the highlighting. See the documentation for those functions." + (interactive (list 'force)) + (gnus-article-highlight-headers) + (gnus-article-highlight-citation force) + (gnus-article-highlight-signature) + (gnus-article-add-buttons force) + (gnus-article-add-buttons-to-head)) + +(defun gnus-article-highlight-some (&optional force) + "Highlight current article. +This function calls `gnus-article-highlight-headers', +`gnus-article-highlight-signature', and `gnus-article-add-buttons' to +do the highlighting. See the documentation for those functions." + (interactive (list 'force)) + (gnus-article-highlight-headers) + (gnus-article-highlight-signature) + (gnus-article-add-buttons)) + +(defun gnus-article-highlight-headers () + "Highlight article headers as specified by `gnus-header-face-alist'." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (save-restriction + (let ((alist gnus-header-face-alist) + (buffer-read-only nil) + (case-fold-search t) + (inhibit-point-motion-hooks t) + entry regexp header-face field-face from hpoints fpoints) + (message-narrow-to-head) + (while (setq entry (pop alist)) + (goto-char (point-min)) + (setq regexp (concat "^\\(" + (if (string-equal "" (nth 0 entry)) + "[^\t ]" + (nth 0 entry)) + "\\)") + header-face (nth 1 entry) + field-face (nth 2 entry)) + (while (and (re-search-forward regexp nil t) + (not (eobp))) + (beginning-of-line) + (setq from (point)) + (unless (search-forward ":" nil t) + (forward-char 1)) + (when (and header-face + (not (memq (point) hpoints))) + (push (point) hpoints) + (gnus-put-text-property from (point) 'face header-face)) + (when (and field-face + (not (memq (setq from (point)) fpoints))) + (push from fpoints) + (if (re-search-forward "^[^ \t]" nil t) + (forward-char -2) + (goto-char (point-max))) + (gnus-put-text-property from (point) 'face field-face)))))))) + +(defun gnus-article-highlight-signature () + "Highlight the signature in an article. +It does this by highlighting everything after +`gnus-signature-separator' using `gnus-signature-face'." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (save-restriction + (when (and gnus-signature-face + (gnus-article-narrow-to-signature)) + (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) + 'face gnus-signature-face) + (widen) + (gnus-article-search-signature) + (let ((start (match-beginning 0)) + (end (set-marker (make-marker) (1+ (match-end 0))))) + (gnus-article-add-button start (1- end) 'gnus-signature-toggle + end))))))) + +(defun gnus-button-in-region-p (b e prop) + "Say whether PROP exists in the region." + (text-property-not-all b e prop nil)) + +(defun gnus-article-add-buttons (&optional force) + "Find external references in the article and make buttons of them. +\"External references\" are things like Message-IDs and URLs, as +specified by `gnus-button-alist'." + (interactive (list 'force)) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist gnus-button-alist) + beg entry regexp) + ;; Remove all old markers. + (let (marker entry) + (while (setq marker (pop gnus-button-marker-list)) + (goto-char marker) + (when (setq entry (gnus-button-entry)) + (put-text-property (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + 'gnus-callback nil)) + (set-marker marker nil))) + ;; We skip the headers. + (goto-char (point-min)) + (unless (search-forward "\n\n" nil t) + (goto-char (point-max))) + (setq beg (point)) + (while (setq entry (pop alist)) + (setq regexp (car entry)) + (goto-char beg) + (while (re-search-forward regexp nil t) + (let* ((start (and entry (match-beginning (nth 1 entry)))) + (end (and entry (match-end (nth 1 entry)))) + (from (match-beginning 0))) + (when (and (or (eq t (nth 2 entry)) + (eval (nth 2 entry))) + (not (gnus-button-in-region-p + start end 'gnus-callback))) + ;; That optional form returned non-nil, so we add the + ;; button. + (gnus-article-add-button + start end 'gnus-button-push + (car (push (set-marker (make-marker) from) + gnus-button-marker-list)))))))))) + +;; Add buttons to the head of an article. +(defun gnus-article-add-buttons-to-head () + "Add buttons to the head of the article." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist gnus-header-button-alist) + entry beg end) + (nnheader-narrow-to-headers) + (while alist + ;; Each alist entry. + (setq entry (car alist) + alist (cdr alist)) + (goto-char (point-min)) + (while (re-search-forward (car entry) nil t) + ;; Each header matching the entry. + (setq beg (match-beginning 0)) + (setq end (or (and (re-search-forward "^[^ \t]" nil t) + (match-beginning 0)) + (point-max))) + (goto-char beg) + (while (re-search-forward (nth 1 entry) end t) + ;; Each match within a header. + (let* ((entry (cdr entry)) + (start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (form (nth 2 entry))) + (goto-char (match-end 0)) + (when (eval form) + (gnus-article-add-button + start end (nth 3 entry) + (buffer-substring (match-beginning (nth 4 entry)) + (match-end (nth 4 entry))))))) + (goto-char end)))) + (widen))) + +;;; External functions: + +(defun gnus-article-add-button (from to fun &optional data) + "Create a button between FROM and TO with callback FUN and data DATA." + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay from to) + 'face gnus-article-button-face)) + (gnus-add-text-properties + from to + (nconc (and gnus-article-mouse-face + (list gnus-mouse-face-prop gnus-article-mouse-face)) + (list 'gnus-callback fun) + (and data (list 'gnus-data data))))) + +;;; Internal functions: + +(defun gnus-article-set-globals () + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables))) + +(defun gnus-signature-toggle (end) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (if (get-text-property end 'invisible) + (gnus-article-unhide-text end (point-max)) + (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) + +(defun gnus-button-entry () + ;; Return the first entry in `gnus-button-alist' matching this place. + (let ((alist gnus-button-alist) + (entry nil)) + (while alist + (setq entry (pop alist)) + (if (looking-at (car entry)) + (setq alist nil) + (setq entry nil))) + entry)) + +(defun gnus-button-push (marker) + ;; Push button starting at MARKER. + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char marker) + (let* ((entry (gnus-button-entry)) + (inhibit-point-motion-hooks t) + (fun (nth 3 entry)) + (args (mapcar (lambda (group) + (let ((string (match-string group))) + (gnus-set-text-properties + 0 (length string) nil string) + string)) + (nthcdr 4 entry)))) + (cond + ((fboundp fun) + (apply fun args)) + ((and (boundp fun) + (fboundp (symbol-value fun))) + (apply (symbol-value fun) args)) + (t + (gnus-message 1 "You must define `%S' to use this button" + (cons fun args))))))) + +(defun gnus-button-message-id (message-id) + "Fetch MESSAGE-ID." + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-refer-article message-id))) + +(defun gnus-button-fetch-group (address) + "Fetch GROUP specified by ADDRESS." + (if (not (string-match "[:/]" address)) + ;; This is just a simple group url. + (gnus-group-read-ephemeral-group address gnus-select-method) + (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$" + address)) + (error "Can't parse %s" address) + (gnus-group-read-ephemeral-group + (match-string 4 address) + `(nntp ,(match-string 1 address) + (nntp-address ,(match-string 1 address)) + (nntp-port-number ,(if (match-end 3) + (match-string 3 address) + "nntp"))))))) + +(defun gnus-split-string (string pattern) + "Return a list of substrings of STRING which are separated by PATTERN." + (let (parts (start 0)) + (while (string-match pattern string start) + (setq parts (cons (substring string start (match-beginning 0)) parts) + start (match-end 0))) + (nreverse (cons (substring string start) parts)))) + +(defun gnus-url-parse-query-string (query &optional downcase) + (let (retval pairs cur key val) + (setq pairs (gnus-split-string query "&")) + (while pairs + (setq cur (car pairs) + pairs (cdr pairs)) + (if (not (string-match "=" cur)) + nil ; Grace + (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil))) + (if downcase + (setq key (downcase key))) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) + retval)) + +(defun gnus-url-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun gnus-url-unhex-string (str &optional allow-newlines) + "Remove %XXX embedded spaces, etc in a url. +If optional second argument ALLOW-NEWLINES is non-nil, then allow the +decoding of carriage returns and line feeds in the string, which is normally +forbidden in URL encoding." + (setq str (or str "")) + (let ((tmp "") + (case-fold-search t)) + (while (string-match "%[0-9a-f][0-9a-f]" str) + (let* ((start (match-beginning 0)) + (ch1 (gnus-url-unhex (elt str (+ start 1)))) + (code (+ (* 16 ch1) + (gnus-url-unhex (elt str (+ start 2)))))) + (setq tmp (concat + tmp (substring str 0 start) + (cond + (allow-newlines + (char-to-string code)) + ((or (= code ?\n) (= code ?\r)) + " ") + (t (char-to-string code)))) + str (substring str (match-end 0))))) + (setq tmp (concat tmp str)) + tmp)) + +(defun gnus-url-mailto (url) + ;; Send mail to someone + (when (string-match "mailto:/*\\(.*\\)" url) + (setq url (substring url (match-beginning 1) nil))) + (let (to args source-url subject func) + (if (string-match (regexp-quote "?") url) + (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) + args (gnus-url-parse-query-string + (substring url (match-end 0) nil) t)) + (setq to (gnus-url-unhex-string url))) + (setq args (cons (list "to" to) args) + subject (cdr-safe (assoc "subject" args))) + (message-mail) + (while args + (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) + (if (fboundp func) + (funcall func) + (message-position-on-field (caar args))) + (insert (mapconcat 'identity (cdar args) ", ")) + (setq args (cdr args))) + (if subject + (message-goto-body) + (message-goto-subject)))) + +(defun gnus-button-mailto (address) + ;; Mail to ADDRESS. + (set-buffer (gnus-copy-article-buffer)) + (message-reply address)) + +(defun gnus-button-reply (address) + ;; Reply to ADDRESS. + (message-reply address)) + +(defun gnus-button-url (address) + "Browse ADDRESS." + (funcall browse-url-browser-function address)) + +(defun gnus-button-embedded-url (address) + "Browse ADDRESS." + (funcall browse-url-browser-function (gnus-strip-whitespace address))) + +;;; Next/prev buttons in the article buffer. + +(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") +(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") + +(defvar gnus-prev-page-map nil) +(unless gnus-prev-page-map + (setq gnus-prev-page-map (make-sparse-keymap)) + (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) + (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) + +(defun gnus-insert-prev-page-button () + (let ((buffer-read-only nil)) + (gnus-eval-format + gnus-prev-page-line-format nil + `(gnus-prev t local-map ,gnus-prev-page-map + gnus-callback gnus-article-button-prev-page)))) + +(defvar gnus-next-page-map nil) +(unless gnus-next-page-map + (setq gnus-next-page-map (make-keymap)) + (suppress-keymap gnus-prev-page-map) + (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) + (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) + +(defun gnus-button-next-page () + "Go to the next page." + (interactive) + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-next-page) + (select-window win))) + +(defun gnus-button-prev-page () + "Go to the prev page." + (interactive) + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-prev-page) + (select-window win))) + +(defun gnus-insert-next-page-button () + (let ((buffer-read-only nil)) + (gnus-eval-format gnus-next-page-line-format nil + `(gnus-next t local-map ,gnus-next-page-map + gnus-callback + gnus-article-button-next-page)))) + +(defun gnus-article-button-next-page (arg) + "Go to the next page." + (interactive "P") + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-next-page) + (select-window win))) + +(defun gnus-article-button-prev-page (arg) + "Go to the prev page." + (interactive "P") + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-prev-page) + (select-window win))) + +(gnus-ems-redefine) + +(provide 'gnus-art) + +(run-hooks 'gnus-art-load-hook) + +;;; gnus-art.el ends here diff --git a/lisp/gnus-async.el b/lisp/gnus-async.el new file mode 100644 index 0000000..b8d4d13 --- /dev/null +++ b/lisp/gnus-async.el @@ -0,0 +1,317 @@ +;;; gnus-async.el --- asynchronous support for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-sum) +(require 'nntp) + +(defgroup gnus-asynchronous nil + "Support for asynchronous operations." + :group 'gnus) + +(defcustom gnus-asynchronous t + "*If nil, inhibit all Gnus asynchronicity. +If non-nil, let the other asynch variables be heeded." + :group 'gnus-asynchronous + :type 'boolean) + +(defcustom gnus-use-article-prefetch 30 + "*If non-nil, prefetch articles in groups that allow this. +If a number, prefetch only that many articles forward; +if t, prefetch as many articles as possible." + :group 'gnus-asynchronous + :type '(choice (const :tag "off" nil) + (const :tag "all" t) + (integer :tag "some" 0))) + +(defcustom gnus-prefetched-article-deletion-strategy '(read exit) + "List of symbols that say when to remove articles from the prefetch buffer. +Possible values in this list are `read', which means that +articles are removed as they are read, and `exit', which means +that all articles belonging to a group are removed on exit +from that group." + :group 'gnus-asynchronous + :type '(set (const read) (const exit))) + +(defcustom gnus-use-header-prefetch nil + "*If non-nil, prefetch the headers to the next group." + :group 'gnus-asynchronous + :type 'boolean) + +(defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p + "Function called to say whether an article should be prefetched or not. +The function is called with one parameter -- the article data. +It should return non-nil if the article is to be prefetched." + :group 'gnus-asynchronous + :type 'function) + +;;; Internal variables. + +(defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") +(defvar gnus-async-article-alist nil) +(defvar gnus-async-article-semaphore '(nil)) +(defvar gnus-async-fetch-list nil) + +(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") +(defvar gnus-async-header-prefetched nil) + +;;; Utility functions. + +(defun gnus-group-asynchronous-p (group) + "Say whether GROUP is fetched from a server that supports asynchronicity." + (gnus-asynchronous-p (gnus-find-method-for-group group))) + +;;; Somewhat bogus semaphores. + +(defun gnus-async-get-semaphore (semaphore) + "Wait until SEMAPHORE is released." + (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2) + (sleep-for 1))) + +(defun gnus-async-release-semaphore (semaphore) + "Release SEMAPHORE." + (setcdr (symbol-value semaphore) nil)) + +(defmacro gnus-async-with-semaphore (&rest forms) + `(unwind-protect + (progn + (gnus-async-get-semaphore 'gnus-async-article-semaphore) + ,@forms) + (gnus-async-release-semaphore 'gnus-async-article-semaphore))) + +(put 'gnus-asynch-with-semaphore 'lisp-indent-function 0) +(put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body)) + +;;; +;;; Article prefetch +;;; + +(gnus-add-shutdown 'gnus-async-close 'gnus) +(defun gnus-async-close () + (gnus-kill-buffer gnus-async-prefetch-article-buffer) + (gnus-kill-buffer gnus-async-prefetch-headers-buffer) + (setq gnus-async-article-alist nil + gnus-async-header-prefetched nil)) + +(defun gnus-async-set-buffer () + (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)) + +(defun gnus-async-halt-prefetch () + "Stop prefetching." + (setq gnus-async-fetch-list nil)) + +(defun gnus-async-prefetch-next (group article summary) + "Possibly prefetch several articles starting with the article after ARTICLE." + (when (and (gnus-buffer-live-p summary) + gnus-asynchronous + (gnus-group-asynchronous-p group)) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((next (caadr (gnus-data-find-list article)))) + (when next + (if (not (fboundp 'run-with-idle-timer)) + ;; This is either an older Emacs or XEmacs, so we + ;; do this, which leads to slightly slower article + ;; buffer display. + (gnus-async-prefetch-article group next summary) + (run-with-idle-timer + 0.1 nil 'gnus-async-prefetch-article group next summary))))))) + +(defun gnus-async-prefetch-article (group article summary &optional next) + "Possibly prefetch several articles starting with ARTICLE." + (if (not (gnus-buffer-live-p summary)) + (gnus-async-with-semaphore + (setq gnus-async-fetch-list nil)) + (when (and gnus-asynchronous + (gnus-alive-p)) + (when next + (gnus-async-with-semaphore + (pop gnus-async-fetch-list))) + (let ((do-fetch next) + (do-message t)) ;(eq major-mode 'gnus-summary-mode))) + (when (and (gnus-group-asynchronous-p group) + (gnus-buffer-live-p summary) + (or (not next) + gnus-async-fetch-list)) + (gnus-async-with-semaphore + (unless next + (setq do-fetch (not gnus-async-fetch-list)) + ;; Nix out any outstanding requests. + (setq gnus-async-fetch-list nil) + ;; Fill in the new list. + (let ((n gnus-use-article-prefetch) + (data (gnus-data-find-list article)) + d) + (while (and (setq d (pop data)) + (if (numberp n) + (natnump (decf n)) + n)) + (unless (or (gnus-async-prefetched-article-entry + group (setq article (gnus-data-number d))) + (not (natnump article)) + (not (funcall gnus-async-prefetch-article-p d))) + ;; Not already fetched -- so we add it to the list. + (push article gnus-async-fetch-list))) + (setq gnus-async-fetch-list + (nreverse gnus-async-fetch-list)))) + + (when do-fetch + (setq article (car gnus-async-fetch-list)))) + + (when (and do-fetch article) + ;; We want to fetch some more articles. + (save-excursion + (set-buffer summary) + (let (mark) + (gnus-async-set-buffer) + (goto-char (point-max)) + (setq mark (point-marker)) + (let ((nnheader-callback-function + (gnus-make-async-article-function + group article mark summary next)) + (nntp-server-buffer + (get-buffer gnus-async-prefetch-article-buffer))) + (when do-message + (gnus-message 9 "Prefetching article %d in group %s" + article group)) + (gnus-request-article article group)))))))))) + +(defun gnus-make-async-article-function (group article mark summary next) + "Return a callback function." + `(lambda (arg) + (save-excursion + (when arg + (gnus-async-set-buffer) + (gnus-async-with-semaphore + (push (list ',(intern (format "%s-%d" group article)) + ,mark (set-marker (make-marker) (point-max)) + ,group ,article) + gnus-async-article-alist))) + (if (not (gnus-buffer-live-p ,summary)) + (gnus-async-with-semaphore + (setq gnus-async-fetch-list nil)) + (gnus-async-prefetch-article ,group ,next ,summary t))))) + +(defun gnus-async-unread-p (data) + "Return non-nil if DATA represents an unread article." + (gnus-data-unread-p data)) + +(defun gnus-async-request-fetched-article (group article buffer) + "See whether we have ARTICLE from GROUP and put it in BUFFER." + (when (numberp article) + (let ((entry (gnus-async-prefetched-article-entry group article))) + (when entry + (save-excursion + (gnus-async-set-buffer) + (copy-to-buffer buffer (cadr entry) (caddr entry)) + ;; Remove the read article from the prefetch buffer. + (when (memq 'read gnus-prefetched-article-deletion-strategy) + (gnus-async-delete-prefected-entry entry)) + t))))) + +(defun gnus-async-delete-prefected-entry (entry) + "Delete ENTRY from buffer and alist." + (ignore-errors + (delete-region (cadr entry) (caddr entry)) + (set-marker (cadr entry) nil) + (set-marker (caddr entry) nil)) + (gnus-async-with-semaphore + (setq gnus-async-article-alist + (delq entry gnus-async-article-alist)))) + +(defun gnus-async-prefetch-remove-group (group) + "Remove all articles belonging to GROUP from the prefetch buffer." + (when (and (gnus-group-asynchronous-p group) + (memq 'exit gnus-prefetched-article-deletion-strategy)) + (let ((alist gnus-async-article-alist)) + (save-excursion + (gnus-async-set-buffer) + (while alist + (when (equal group (nth 3 (car alist))) + (gnus-async-delete-prefected-entry (car alist))) + (pop alist)))))) + +(defun gnus-async-prefetched-article-entry (group article) + "Return the entry for ARTICLE in GROUP iff it has been prefetched." + (let ((entry (assq (intern (format "%s-%d" group article)) + gnus-async-article-alist))) + ;; Perhaps something has emptied the buffer? + (if (and entry + (= (cadr entry) (caddr entry))) + (progn + (ignore-errors + (set-marker (cadr entry) nil) + (set-marker (caddr entry) nil)) + (setq gnus-async-article-alist + (delq entry gnus-async-article-alist)) + nil) + entry))) + +;;; +;;; Header prefetch +;;; + +(defun gnus-async-prefetch-headers (group) + "Prefetch the headers for group GROUP." + (save-excursion + (let (unread) + (when (and gnus-use-header-prefetch + gnus-asynchronous + (gnus-group-asynchronous-p group) + (listp gnus-async-header-prefetched) + (setq unread (gnus-list-of-unread-articles group))) + ;; Mark that a fetch is in progress. + (setq gnus-async-header-prefetched t) + (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) + (erase-buffer) + (let ((nntp-server-buffer (current-buffer)) + (nnheader-callback-function + `(lambda (arg) + (setq gnus-async-header-prefetched + ,(cons group unread))))) + (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) + +(defun gnus-async-retrieve-fetched-headers (articles group) + "See whether we have prefetched headers." + (when (and gnus-use-header-prefetch + (gnus-group-asynchronous-p group) + (listp gnus-async-header-prefetched) + (equal group (car gnus-async-header-prefetched)) + (equal articles (cdr gnus-async-header-prefetched))) + (save-excursion + (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) + (nntp-decode-text) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (erase-buffer) + (setq gnus-async-header-prefetched nil) + t))) + +(provide 'gnus-async) + +;;; gnus-async.el ends here diff --git a/lisp/gnus-audio.el b/lisp/gnus-audio.el new file mode 100644 index 0000000..e72804a --- /dev/null +++ b/lisp/gnus-audio.el @@ -0,0 +1,132 @@ +;;; gnus-audio.el --- Sound effects for Gnus +;; Copyright (C) 1996 Free Software Foundation + +;; Author: Steven L. Baur +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; This file provides access to sound effects in Gnus. +;; Prerelease: This file is partially stripped to support earcons.el +;; You can safely ignore most of it until Red Gnus. **Evil Laugh** +;;; Code: + +(when (null (boundp 'running-xemacs)) + (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) + +(require 'nnheader) +(eval-when-compile (require 'cl)) + +(defvar gnus-audio-inline-sound + (and (fboundp 'device-sound-enabled-p) + (device-sound-enabled-p)) + "When t, we will not spawn a subprocess to play sounds.") + +(defvar gnus-audio-directory (nnheader-find-etc-directory "sounds") + "The directory containing the Sound Files.") + +(defvar gnus-audio-au-player "/usr/bin/showaudio" + "Executable program for playing sun AU format sound files") +(defvar gnus-audio-wav-player "/usr/local/bin/play" + "Executable program for playing WAV files") + + +;;; The following isn't implemented yet. Wait for Red Gnus. +;(defvar gnus-audio-effects-enabled t +; "When t, Gnus will use sound effects.") +;(defvar gnus-audio-enable-hooks nil +; "Functions run when enabling sound effects.") +;(defvar gnus-audio-disable-hooks nil +; "Functions run when disabling sound effects.") +;(defvar gnus-audio-theme-song nil +; "Theme song for Gnus.") +;(defvar gnus-audio-enter-group nil +; "Sound effect played when selecting a group.") +;(defvar gnus-audio-exit-group nil +; "Sound effect played when exiting a group.") +;(defvar gnus-audio-score-group nil +; "Sound effect played when scoring a group.") +;(defvar gnus-audio-busy-sound nil +; "Sound effect played when going into a ... sequence.") + + +;;;###autoload + ;(defun gnus-audio-enable-sound () +; "Enable Sound Effects for Gnus." +; (interactive) +; (setq gnus-audio-effects-enabled t) +; (run-hooks gnus-audio-enable-hooks)) + +;;;###autoload + ;(defun gnus-audio-disable-sound () +; "Disable Sound Effects for Gnus." +; (interactive) +; (setq gnus-audio-effects-enabled nil) +; (run-hooks gnus-audio-disable-hooks)) + +;;;###autoload +(defun gnus-audio-play (file) + "Play a sound through the speaker." + (interactive) + (let ((sound-file (if (file-exists-p file) + file + (concat gnus-audio-directory file)))) + (when (file-exists-p sound-file) + (if gnus-audio-inline-sound + (play-sound-file sound-file) + (cond ((string-match "\\.wav$" sound-file) + (call-process gnus-audio-wav-player + sound-file + 0 + nil + sound-file)) + ((string-match "\\.au$" sound-file) + (call-process gnus-audio-au-player + sound-file + 0 + nil + sound-file))))))) + + +;;; The following isn't implemented yet, wait for Red Gnus + ;(defun gnus-audio-startrek-sounds () +; "Enable sounds from Star Trek the original series." +; (interactive) +; (setq gnus-audio-busy-sound "working.au") +; (setq gnus-audio-enter-group "bulkhead_door.au") +; (setq gnus-audio-exit-group "bulkhead_door.au") +; (setq gnus-audio-score-group "ST_laser.au") +; (setq gnus-audio-theme-song "startrek.au") +; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group) +; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group)) +;;;*** + +(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au" + "Name of the Gnus startup jingle file.") + +(defun gnus-play-jingle () + "Play the Gnus startup jingle, unless that's inhibited." + (interactive) + (gnus-audio-play gnus-startup-jingle)) + +(provide 'gnus-audio) + +(run-hooks 'gnus-audio-load-hook) + +;;; gnus-audio.el ends here diff --git a/lisp/gnus-bcklg.el b/lisp/gnus-bcklg.el new file mode 100644 index 0000000..d3f2ac5 --- /dev/null +++ b/lisp/gnus-bcklg.el @@ -0,0 +1,155 @@ +;;; gnus-bcklg.el --- backlog functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) + +;;; +;;; Buffering of read articles. +;;; + +(defvar gnus-backlog-buffer " *Gnus Backlog*") +(defvar gnus-backlog-articles nil) +(defvar gnus-backlog-hashtb nil) + +(defun gnus-backlog-buffer () + "Return the backlog buffer." + (or (get-buffer gnus-backlog-buffer) + (save-excursion + (set-buffer (get-buffer-create gnus-backlog-buffer)) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (gnus-add-current-to-buffer-list) + (get-buffer gnus-backlog-buffer)))) + +(defun gnus-backlog-setup () + "Initialize backlog variables." + (unless gnus-backlog-hashtb + (setq gnus-backlog-hashtb (gnus-make-hashtable 1024)))) + +(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) + +(defun gnus-backlog-shutdown () + "Clear all backlog variables and buffers." + (when (get-buffer gnus-backlog-buffer) + (kill-buffer gnus-backlog-buffer)) + (setq gnus-backlog-hashtb nil + gnus-backlog-articles nil)) + +(defun gnus-backlog-enter-article (group number buffer) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + b) + (if (memq ident gnus-backlog-articles) + () ; It's already kept. + ;; Remove the oldest article, if necessary. + (and (numberp gnus-keep-backlog) + (>= (length gnus-backlog-articles) gnus-keep-backlog) + (gnus-backlog-remove-oldest-article)) + (push ident gnus-backlog-articles) + ;; Insert the new article. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (let (buffer-read-only) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (insert-buffer-substring buffer) + ;; Tag the beginning of the article with the ident. + (gnus-put-text-property b (1+ b) 'gnus-backlog ident)))))) + +(defun gnus-backlog-remove-oldest-article () + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (goto-char (point-min)) + (if (zerop (buffer-size)) + () ; The buffer is empty. + (let ((ident (get-text-property (point) 'gnus-backlog)) + buffer-read-only) + ;; Remove the ident from the list of articles. + (when ident + (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) + ;; Delete the article itself. + (delete-region + (point) (next-single-property-change + (1+ (point)) 'gnus-backlog nil (point-max))))))) + +(defun gnus-backlog-remove-article (group number) + "Remove article NUMBER in GROUP from the backlog." + (when (numberp number) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + beg end) + (when (memq ident gnus-backlog-articles) + ;; It was in the backlog. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (let (buffer-read-only) + (when (setq beg (text-property-any + (point-min) (point-max) 'gnus-backlog + ident)) + ;; Find the end (i. e., the beginning of the next article). + (setq end + (next-single-property-change + (1+ beg) 'gnus-backlog (current-buffer) (point-max))) + (delete-region beg end) + ;; Return success. + t)) + (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) + +(defun gnus-backlog-request-article (group number buffer) + (when (numberp number) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + beg end) + (when (memq ident gnus-backlog-articles) + ;; It was in the backlog. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (if (not (setq beg (text-property-any + (point-min) (point-max) 'gnus-backlog + ident))) + ;; It wasn't in the backlog after all. + (ignore + (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) + ;; Find the end (i. e., the beginning of the next article). + (setq end + (next-single-property-change + (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-buffer-substring gnus-backlog-buffer beg end) + t))))) + +(provide 'gnus-bcklg) + +;;; gnus-bcklg.el ends here diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el new file mode 100644 index 0000000..3a7cd8d --- /dev/null +++ b/lisp/gnus-cache.el @@ -0,0 +1,664 @@ +;;; gnus-cache.el --- cache interface for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-int) +(require 'gnus-range) +(require 'gnus-start) +(eval-when-compile + (require 'gnus-sum)) + +(defgroup gnus-cache nil + "Cache interface." + :group 'gnus) + +(defcustom gnus-cache-directory + (nnheader-concat gnus-directory "cache/") + "*The directory where cached articles will be stored." + :group 'gnus-cache + :type 'directory) + +(defcustom gnus-cache-active-file + (concat (file-name-as-directory gnus-cache-directory) "active") + "*The cache active file." + :group 'gnus-cache + :type 'file) + +(defcustom gnus-cache-enter-articles '(ticked dormant) + "Classes of articles to enter into the cache." + :group 'gnus-cache + :type '(set (const ticked) (const dormant) (const unread) (const read))) + +(defcustom gnus-cache-remove-articles '(read) + "Classes of articles to remove from the cache." + :group 'gnus-cache + :type '(set (const ticked) (const dormant) (const unread) (const read))) + +(defcustom gnus-uncacheable-groups nil + "*Groups that match this regexp will not be cached. + +If you want to avoid caching your nnml groups, you could set this +variable to \"^nnml\"." + :group 'gnus-cache + :type '(choice (const :tag "off" nil) + regexp)) + + + +;;; Internal variables. + +(defvar gnus-cache-removable-articles nil) +(defvar gnus-cache-buffer nil) +(defvar gnus-cache-active-hashtb nil) +(defvar gnus-cache-active-altered nil) + +(eval-and-compile + (autoload 'nnml-generate-nov-databases-1 "nnml") + (autoload 'nnvirtual-find-group-art "nnvirtual")) + + + +;;; Functions called from Gnus. + +(defun gnus-cache-open () + "Initialize the cache." + (when (or (file-exists-p gnus-cache-directory) + (and gnus-use-cache + (not (eq gnus-use-cache 'passive)))) + (gnus-cache-read-active))) + +;; Complexities of byte-compiling make this kludge necessary. Eeek. +(ignore-errors + (gnus-add-shutdown 'gnus-cache-close 'gnus)) + +(defun gnus-cache-close () + "Shut down the cache." + (gnus-cache-write-active) + (gnus-cache-save-buffers) + (setq gnus-cache-active-hashtb nil)) + +(defun gnus-cache-save-buffers () + ;; save the overview buffer if it exists and has been modified + ;; delete empty cache subdirectories + (when gnus-cache-buffer + (let ((buffer (cdr gnus-cache-buffer)) + (overview-file (gnus-cache-file-name + (car gnus-cache-buffer) ".overview"))) + ;; write the overview only if it was modified + (when (buffer-modified-p buffer) + (save-excursion + (set-buffer buffer) + (if (> (buffer-size) 0) + ;; Non-empty overview, write it to a file. + (gnus-write-buffer overview-file) + ;; Empty overview file, remove it + (when (file-exists-p overview-file) + (delete-file overview-file)) + ;; If possible, remove group's cache subdirectory. + (condition-case nil + ;; FIXME: we can detect the error type and warn the user + ;; of any inconsistencies (articles w/o nov entries?). + ;; for now, just be conservative...delete only if safe -- sj + (delete-directory (file-name-directory overview-file)) + (error nil))))) + ;; Kill the buffer -- it's either unmodified or saved. + (gnus-kill-buffer buffer) + (setq gnus-cache-buffer nil)))) + +(defun gnus-cache-possibly-enter-article + (group article headers ticked dormant unread &optional force) + (when (and (or force (not (eq gnus-use-cache 'passive))) + (numberp article) + (> article 0) + (vectorp headers)) ; This might be a dummy article. + ;; If this is a virtual group, we find the real group. + (when (gnus-virtual-group-p group) + (let ((result (nnvirtual-find-group-art + (gnus-group-real-name group) article))) + (setq group (car result) + headers (copy-sequence headers)) + (mail-header-set-number headers (cdr result)))) + (let ((number (mail-header-number headers)) + file dir) + (when (and number + (> number 0) ; Reffed article. + (or force + (and (or (not gnus-uncacheable-groups) + (not (string-match + gnus-uncacheable-groups group))) + (gnus-cache-member-of-class + gnus-cache-enter-articles ticked dormant unread))) + (not (file-exists-p (setq file (gnus-cache-file-name + group number))))) + ;; Possibly create the cache directory. + (gnus-make-directory (setq dir (file-name-directory file))) + ;; Save the article in the cache. + (if (file-exists-p file) + t ; The article already is saved. + (save-excursion + (set-buffer nntp-server-buffer) + (let ((gnus-use-cache nil)) + (gnus-request-article-this-buffer number group)) + (when (> (buffer-size) 0) + (gnus-write-buffer file) + (gnus-cache-change-buffer group) + (set-buffer (cdr gnus-cache-buffer)) + (goto-char (point-max)) + (forward-line -1) + (while (condition-case () + (when (not (bobp)) + (> (read (current-buffer)) number)) + (error + ;; The line was malformed, so we just remove it!! + (gnus-delete-line) + t)) + (forward-line -1)) + (if (bobp) + (if (not (eobp)) + (progn + (beginning-of-line) + (when (< (read (current-buffer)) number) + (forward-line 1))) + (beginning-of-line)) + (forward-line 1)) + (beginning-of-line) + ;; [number subject from date id references chars lines xref] + (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n" + (mail-header-number headers) + (mail-header-subject headers) + (mail-header-from headers) + (mail-header-date headers) + (mail-header-id headers) + (or (mail-header-references headers) "") + (or (mail-header-chars headers) "") + (or (mail-header-lines headers) "") + (or (mail-header-xref headers) ""))) + ;; Update the active info. + (set-buffer gnus-summary-buffer) + (gnus-cache-update-active group number) + (push article gnus-newsgroup-cached) + (gnus-summary-update-secondary-mark article)) + t)))))) + +(defun gnus-cache-enter-remove-article (article) + "Mark ARTICLE for later possible removal." + (when article + (push article gnus-cache-removable-articles))) + +(defun gnus-cache-possibly-remove-articles () + "Possibly remove some of the removable articles." + (if (not (gnus-virtual-group-p gnus-newsgroup-name)) + (gnus-cache-possibly-remove-articles-1) + (let ((arts gnus-cache-removable-articles) + ga) + (while arts + (when (setq ga (nnvirtual-find-group-art + (gnus-group-real-name gnus-newsgroup-name) (pop arts))) + (let ((gnus-cache-removable-articles (list (cdr ga))) + (gnus-newsgroup-name (car ga))) + (gnus-cache-possibly-remove-articles-1))))) + (setq gnus-cache-removable-articles nil))) + +(defun gnus-cache-possibly-remove-articles-1 () + "Possibly remove some of the removable articles." + (unless (eq gnus-use-cache 'passive) + (let ((articles gnus-cache-removable-articles) + (cache-articles gnus-newsgroup-cached) + article) + (gnus-cache-change-buffer gnus-newsgroup-name) + (while articles + (when (memq (setq article (pop articles)) cache-articles) + ;; The article was in the cache, so we see whether we are + ;; supposed to remove it from the cache. + (gnus-cache-possibly-remove-article + article (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (or (memq article gnus-newsgroup-unreads) + (memq article gnus-newsgroup-unselected)))))) + ;; The overview file might have been modified, save it + ;; safe because we're only called at group exit anyway. + (gnus-cache-save-buffers))) + +(defun gnus-cache-request-article (article group) + "Retrieve ARTICLE in GROUP from the cache." + (let ((file (gnus-cache-file-name group article)) + (buffer-read-only nil)) + (when (file-exists-p file) + (erase-buffer) + (gnus-kill-all-overlays) + (insert-file-contents file) + t))) + +(defun gnus-cache-possibly-alter-active (group active) + "Alter the ACTIVE info for GROUP to reflect the articles in the cache." + (when gnus-cache-active-hashtb + (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (when cache-active + (when (< (car cache-active) (car active)) + (setcar active (car cache-active))) + (when (> (cdr cache-active) (cdr active)) + (setcdr active (cdr cache-active))))))) + +(defun gnus-cache-retrieve-headers (articles group &optional fetch-old) + "Retrieve the headers for ARTICLES in GROUP." + (let ((cached + (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) + (if (not cached) + ;; No cached articles here, so we just retrieve them + ;; the normal way. + (let ((gnus-use-cache nil)) + (gnus-retrieve-headers articles group fetch-old)) + (let ((uncached-articles (gnus-sorted-intersection + (gnus-sorted-complement articles cached) + articles)) + (cache-file (gnus-cache-file-name group ".overview")) + type) + ;; We first retrieve all the headers that we don't have in + ;; the cache. + (let ((gnus-use-cache nil)) + (when uncached-articles + (setq type (and articles + (gnus-retrieve-headers + uncached-articles group fetch-old))))) + (gnus-cache-save-buffers) + ;; Then we insert the cached headers. + (save-excursion + (cond + ((not (file-exists-p cache-file)) + ;; There are no cached headers. + type) + ((null type) + ;; There were no uncached headers (or retrieval was + ;; unsuccessful), so we use the cached headers exclusively. + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-file-contents cache-file) + 'nov) + ((eq type 'nov) + ;; We have both cached and uncached NOV headers, so we + ;; braid them. + (gnus-cache-braid-nov group cached) + type) + (t + ;; We braid HEADs. + (gnus-cache-braid-heads group (gnus-sorted-intersection + cached articles)) + type))))))) + +(defun gnus-cache-enter-article (&optional n) + "Enter the next N articles into the cache. +If not given a prefix, use the process marked articles instead. +Returns the list of articles entered." + (interactive "P") + (gnus-set-global-variables) + (let ((articles (gnus-summary-work-articles n)) + article out) + (while (setq article (pop articles)) + (if (natnump article) + (when (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + nil nil nil t) + (push article out)) + (gnus-message 2 "Can't cache article %d" article)) + (gnus-summary-remove-process-mark article) + (gnus-summary-update-secondary-mark article)) + (gnus-summary-next-subject 1) + (gnus-summary-position-point) + (nreverse out))) + +(defun gnus-cache-remove-article (n) + "Remove the next N articles from the cache. +If not given a prefix, use the process marked articles instead. +Returns the list of articles removed." + (interactive "P") + (gnus-set-global-variables) + (gnus-cache-change-buffer gnus-newsgroup-name) + (let ((articles (gnus-summary-work-articles n)) + article out) + (while articles + (setq article (pop articles)) + (when (gnus-cache-possibly-remove-article article nil nil nil t) + (push article out)) + (gnus-summary-remove-process-mark article) + (gnus-summary-update-secondary-mark article)) + (gnus-summary-next-subject 1) + (gnus-summary-position-point) + (nreverse out))) + +(defun gnus-cached-article-p (article) + "Say whether ARTICLE is cached in the current group." + (memq article gnus-newsgroup-cached)) + +(defun gnus-summary-insert-cached-articles () + "Insert all the articles cached for this group into the current buffer." + (interactive) + (let ((cached gnus-newsgroup-cached) + (gnus-verbose (max 6 gnus-verbose))) + (unless cached + (error "No cached articles for this group")) + (while cached + (gnus-summary-goto-subject (pop cached) t)))) + +;;; Internal functions. + +(defun gnus-cache-change-buffer (group) + (and gnus-cache-buffer + ;; See if the current group's overview cache has been loaded. + (or (string= group (car gnus-cache-buffer)) + ;; Another overview cache is current, save it. + (gnus-cache-save-buffers))) + ;; if gnus-cache buffer is nil, create it + (unless gnus-cache-buffer + ;; Create cache buffer + (save-excursion + (setq gnus-cache-buffer + (cons group + (set-buffer (get-buffer-create " *gnus-cache-overview*")))) + (buffer-disable-undo (current-buffer)) + ;; Insert the contents of this group's cache overview. + (erase-buffer) + (let ((file (gnus-cache-file-name group ".overview"))) + (when (file-exists-p file) + (nnheader-insert-file-contents file))) + ;; We have a fresh (empty/just loaded) buffer, + ;; mark it as unmodified to save a redundant write later. + (set-buffer-modified-p nil)))) + +;; Return whether an article is a member of a class. +(defun gnus-cache-member-of-class (class ticked dormant unread) + (or (and ticked (memq 'ticked class)) + (and dormant (memq 'dormant class)) + (and unread (memq 'unread class)) + (and (not unread) (not ticked) (not dormant) (memq 'read class)))) + +(defun gnus-cache-file-name (group article) + (concat (file-name-as-directory gnus-cache-directory) + (file-name-as-directory + (nnheader-translate-file-chars + (if (gnus-use-long-file-name 'not-cache) + group + (let ((group (nnheader-replace-chars-in-string group ?/ ?_))) + ;; Translate the first colon into a slash. + (when (string-match ":" group) + (aset group (match-beginning 0) ?/)) + (nnheader-replace-chars-in-string group ?. ?/))))) + (if (stringp article) article (int-to-string article)))) + +(defun gnus-cache-update-article (group article) + "If ARTICLE is in the cache, remove it and re-enter it." + (when (gnus-cache-possibly-remove-article article nil nil nil t) + (let ((gnus-use-cache nil)) + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article (gnus-summary-article-header article) + nil nil nil t)))) + +(defun gnus-cache-possibly-remove-article (article ticked dormant unread + &optional force) + "Possibly remove ARTICLE from the cache." + (let ((group gnus-newsgroup-name) + (number article) + file) + ;; If this is a virtual group, we find the real group. + (when (gnus-virtual-group-p group) + (let ((result (nnvirtual-find-group-art + (gnus-group-real-name group) article))) + (setq group (car result) + number (cdr result)))) + (setq file (gnus-cache-file-name group number)) + (when (and (file-exists-p file) + (or force + (gnus-cache-member-of-class + gnus-cache-remove-articles ticked dormant unread))) + (save-excursion + (delete-file file) + (set-buffer (cdr gnus-cache-buffer)) + (goto-char (point-min)) + (when (or (looking-at (concat (int-to-string number) "\t")) + (search-forward (concat "\n" (int-to-string number) "\t") + (point-max) t)) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))))) + (setq gnus-newsgroup-cached + (delq article gnus-newsgroup-cached)) + (gnus-summary-update-secondary-mark article) + t))) + +(defun gnus-cache-articles-in-group (group) + "Return a sorted list of cached articles in GROUP." + (let ((dir (file-name-directory (gnus-cache-file-name group 1))) + articles) + (when (file-exists-p dir) + (setq articles + (sort (mapcar (lambda (name) (string-to-int name)) + (directory-files dir nil "^[0-9]+$" t)) + '<)) + ;; Update the cache active file, just to synch more. + (when articles + (gnus-cache-update-active group (car articles) t) + (gnus-cache-update-active group (car (last articles)))) + articles))) + +(defun gnus-cache-braid-nov (group cached &optional file) + (let ((cache-buf (get-buffer-create " *gnus-cache*")) + beg end) + (gnus-cache-save-buffers) + (save-excursion + (set-buffer cache-buf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-file-contents (or file (gnus-cache-file-name group ".overview"))) + (goto-char (point-min)) + (insert "\n") + (goto-char (point-min))) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while cached + (while (and (not (eobp)) + (< (read (current-buffer)) (car cached))) + (forward-line 1)) + (beginning-of-line) + (save-excursion + (set-buffer cache-buf) + (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") + nil t) + (setq beg (progn (beginning-of-line) (point)) + end (progn (end-of-line) (point))) + (setq beg nil))) + (when beg + (insert-buffer-substring cache-buf beg end) + (insert "\n")) + (setq cached (cdr cached))) + (kill-buffer cache-buf))) + +(defun gnus-cache-braid-heads (group cached) + (let ((cache-buf (get-buffer-create " *gnus-cache*"))) + (save-excursion + (set-buffer cache-buf) + (buffer-disable-undo (current-buffer)) + (erase-buffer)) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while cached + (while (and (not (eobp)) + (looking-at "2.. +\\([0-9]+\\) ") + (< (progn (goto-char (match-beginning 1)) + (read (current-buffer))) + (car cached))) + (search-forward "\n.\n" nil 'move)) + (beginning-of-line) + (save-excursion + (set-buffer cache-buf) + (erase-buffer) + (insert-file-contents (gnus-cache-file-name group (car cached))) + (goto-char (point-min)) + (insert "220 ") + (princ (car cached) (current-buffer)) + (insert " Article retrieved.\n") + (search-forward "\n\n" nil 'move) + (delete-region (point) (point-max)) + (forward-char -1) + (insert ".")) + (insert-buffer-substring cache-buf) + (setq cached (cdr cached))) + (kill-buffer cache-buf))) + +;;;###autoload +(defun gnus-jog-cache () + "Go through all groups and put the articles into the cache. + +Usage: +$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" + (interactive) + (let ((gnus-mark-article-hook nil) + (gnus-expert-user t) + (nnmail-spool-file nil) + (gnus-use-dribble-file nil) + (gnus-novice-user nil) + (gnus-large-newsgroup nil)) + ;; Start Gnus. + (gnus) + ;; Go through all groups... + (gnus-group-mark-buffer) + (gnus-group-iterate nil + (lambda (group) + (let (gnus-auto-select-next) + (gnus-summary-read-group group nil t) + ;; ... and enter the articles into the cache. + (when (eq major-mode 'gnus-summary-mode) + (gnus-uu-mark-buffer) + (gnus-cache-enter-article) + (kill-buffer (current-buffer)))))))) + +(defun gnus-cache-read-active (&optional force) + "Read the cache active file." + (gnus-make-directory gnus-cache-directory) + (if (or (not (file-exists-p gnus-cache-active-file)) + force) + ;; There is no active file, so we generate one. + (gnus-cache-generate-active) + ;; We simply read the active file. + (save-excursion + (gnus-set-work-buffer) + (insert-file-contents gnus-cache-active-file) + (gnus-active-to-gnus-format + nil (setq gnus-cache-active-hashtb + (gnus-make-hashtable + (count-lines (point-min) (point-max))))) + (setq gnus-cache-active-altered nil)))) + +(defun gnus-cache-write-active (&optional force) + "Write the active hashtb to the active file." + (when (or force + (and gnus-cache-active-hashtb + gnus-cache-active-altered)) + (nnheader-temp-write gnus-cache-active-file + (mapatoms + (lambda (sym) + (when (and sym (boundp sym)) + (insert (format "%s %d %d y\n" + (symbol-name sym) (cdr (symbol-value sym)) + (car (symbol-value sym)))))) + gnus-cache-active-hashtb)) + ;; Mark the active hashtb as unaltered. + (setq gnus-cache-active-altered nil))) + +(defun gnus-cache-update-active (group number &optional low) + "Update the upper bound of the active info of GROUP to NUMBER. +If LOW, update the lower bound instead." + (let ((active (gnus-gethash group gnus-cache-active-hashtb))) + (if (null active) + ;; We just create a new active entry for this group. + (gnus-sethash group (cons number number) gnus-cache-active-hashtb) + ;; Update the lower or upper bound. + (if low + (setcar active number) + (setcdr active number))) + ;; Mark the active hashtb as altered. + (setq gnus-cache-active-altered t))) + +;;;###autoload +(defun gnus-cache-generate-active (&optional directory) + "Generate the cache active file." + (interactive) + (let* ((top (null directory)) + (directory (expand-file-name (or directory gnus-cache-directory))) + (files (directory-files directory 'full)) + (group + (if top + "" + (string-match + (concat "^" (file-name-as-directory + (expand-file-name gnus-cache-directory))) + (directory-file-name directory)) + (nnheader-replace-chars-in-string + (substring (directory-file-name directory) (match-end 0)) + ?/ ?.))) + nums alphs) + (when top + (gnus-message 5 "Generating the cache active file...") + (setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) + ;; Separate articles from all other files and directories. + (while files + (if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) + (push (string-to-int (file-name-nondirectory (pop files))) nums) + (push (pop files) alphs))) + ;; If we have nums, then this is probably a valid group. + (when (setq nums (sort nums '<)) + (gnus-sethash group (cons (car nums) (gnus-last-element nums)) + gnus-cache-active-hashtb)) + ;; Go through all the other files. + (while alphs + (when (and (file-directory-p (car alphs)) + (not (string-match "^\\.\\.?$" + (file-name-nondirectory (car alphs))))) + ;; We descend directories. + (gnus-cache-generate-active (car alphs))) + (setq alphs (cdr alphs))) + ;; Write the new active file. + (when top + (gnus-cache-write-active t) + (gnus-message 5 "Generating the cache active file...done")))) + +;;;###autoload +(defun gnus-cache-generate-nov-databases (dir) + "Generate NOV files recursively starting in DIR." + (interactive (list gnus-cache-directory)) + (gnus-cache-close) + (let ((nnml-generate-active-function 'identity)) + (nnml-generate-nov-databases-1 dir))) + +(defun gnus-cache-move-cache (dir) + "Move the cache tree to somewhere else." + (interactive "FMove the cache tree to: ") + (rename-file gnus-cache-directory dir)) + +(provide 'gnus-cache) + +;;; gnus-cache.el ends here diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el new file mode 100644 index 0000000..2a1eb4f --- /dev/null +++ b/lisp/gnus-cite.el @@ -0,0 +1,913 @@ +;;; gnus-cite.el --- parse citations in articles for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-art) +(require 'gnus-range) + +;;; Customization: + +(defgroup gnus-cite nil + "Citation." + :prefix "gnus-cite-" + :link '(custom-manual "(gnus)Article Highlighting") + :group 'gnus-article) + +(defcustom gnus-cite-reply-regexp + "^\\(Subject: Re\\|In-Reply-To\\|References\\):" + "If headers match this regexp it is reasonable to believe that +article has citations." + :group 'gnus-cite + :type 'string) + +(defcustom gnus-cite-always-check nil + "Check article always for citations. Set it t to check all articles." + :group 'gnus-cite + :type '(choice (const :tag "no" nil) + (const :tag "yes" t))) + +(defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n" + "Format of cited text buttons." + :group 'gnus-cite + :type 'string) + +(defcustom gnus-cited-lines-visible nil + "The number of lines of hidden cited text to remain visible." + :group 'gnus-cite + :type '(choice (const :tag "none" nil) + integer)) + +(defcustom gnus-cite-parse-max-size 25000 + "Maximum article size (in bytes) where parsing citations is allowed. +Set it to nil to parse all articles." + :group 'gnus-cite + :type '(choice (const :tag "all" nil) + integer)) + +(defcustom gnus-cite-prefix-regexp + "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" + "Regexp matching the longest possible citation prefix on a line." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-max-prefix 20 + "Maximum possible length for a citation prefix." + :group 'gnus-cite + :type 'integer) + +(defcustom gnus-supercite-regexp + (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" + ">>>>> +\"\\([^\"\n]+\\)\" +==") + "Regexp matching normal Supercite attribution lines. +The first grouping must match prefixes added by other packages." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" + "Regexp matching mangled Supercite attribution lines. +The first regexp group should match the Supercite attribution." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-minimum-match-count 2 + "Minimum number of identical prefixes before we believe it's a citation." + :group 'gnus-cite + :type 'integer) + +(defcustom gnus-cite-attribution-prefix + "in article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\)," + "Regexp matching the beginning of an attribution line." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-attribution-suffix + "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\)[ \t]*$" + "Regexp matching the end of an attribution line. +The text matching the first grouping will be used as a button." + :group 'gnus-cite + :type 'regexp) + +(defface gnus-cite-attribution-face '((t + (:underline t))) + "Face used for attribution lines.") + +(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face + "Face used for attribution lines. +It is merged with the face for the cited text belonging to the attribution." + :group 'gnus-cite + :type 'face) + +(defface gnus-cite-face-1 '((((class color) + (background dark)) + (:foreground "light blue")) + (((class color) + (background light)) + (:foreground "MidnightBlue")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-2 '((((class color) + (background dark)) + (:foreground "light cyan")) + (((class color) + (background light)) + (:foreground "firebrick")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-3 '((((class color) + (background dark)) + (:foreground "light yellow")) + (((class color) + (background light)) + (:foreground "dark green")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-4 '((((class color) + (background dark)) + (:foreground "light pink")) + (((class color) + (background light)) + (:foreground "OrangeRed")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-5 '((((class color) + (background dark)) + (:foreground "pale green")) + (((class color) + (background light)) + (:foreground "dark khaki")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-6 '((((class color) + (background dark)) + (:foreground "beige")) + (((class color) + (background light)) + (:foreground "dark violet")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-7 '((((class color) + (background dark)) + (:foreground "orange")) + (((class color) + (background light)) + (:foreground "SteelBlue4")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-8 '((((class color) + (background dark)) + (:foreground "magenta")) + (((class color) + (background light)) + (:foreground "magenta")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-9 '((((class color) + (background dark)) + (:foreground "violet")) + (((class color) + (background light)) + (:foreground "violet")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-10 '((((class color) + (background dark)) + (:foreground "medium purple")) + (((class color) + (background light)) + (:foreground "medium purple")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-11 '((((class color) + (background dark)) + (:foreground "turquoise")) + (((class color) + (background light)) + (:foreground "turquoise")) + (t + (:italic t))) + "Citation face.") + +(defcustom gnus-cite-face-list + '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4 + gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 + gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11) + "List of faces used for highlighting citations. + +When there are citations from multiple articles in the same message, +Gnus will try to give each citation from each article its own face. +This should make it easier to see who wrote what." + :group 'gnus-cite + :type '(repeat face)) + +(defcustom gnus-cite-hide-percentage 50 + "Only hide excess citation if above this percentage of the body." + :group 'gnus-cite + :type 'number) + +(defcustom gnus-cite-hide-absolute 10 + "Only hide excess citation if above this number of lines in the body." + :group 'gnus-cite + :type 'integer) + +;;; Internal Variables: + +(defvar gnus-cite-article nil) + +(defvar gnus-cite-prefix-alist nil) +;; Alist of citation prefixes. +;; The cdr is a list of lines with that prefix. + +(defvar gnus-cite-attribution-alist nil) +;; Alist of attribution lines. +;; The car is a line number. +;; The cdr is the prefix for the citation started by that line. + +(defvar gnus-cite-loose-prefix-alist nil) +;; Alist of citation prefixes that have no matching attribution. +;; The cdr is a list of lines with that prefix. + +(defvar gnus-cite-loose-attribution-alist nil) +;; Alist of attribution lines that have no matching citation. +;; Each member has the form (WROTE IN PREFIX TAG), where +;; WROTE: is the attribution line number +;; IN: is the line number of the previous line if part of the same attribution, +;; PREFIX: Is the citation prefix of the attribution line(s), and +;; TAG: Is a Supercite tag, if any. + +(defvar gnus-cited-text-button-line-format-alist + `((?b (marker-position beg) ?d) + (?e (marker-position end) ?d) + (?l (- end beg) ?d))) +(defvar gnus-cited-text-button-line-format-spec nil) + +;;; Commands: + +(defun gnus-article-highlight-citation (&optional force) + "Highlight cited text. +Each citation in the article will be highlighted with a different face. +The faces are taken from `gnus-cite-face-list'. +Attribution lines are highlighted with the same face as the +corresponding citation merged with `gnus-cite-attribution-face'. + +Text is considered cited if at least `gnus-cite-minimum-match-count' +lines matches `gnus-cite-prefix-regexp' with the same prefix. + +Lines matching `gnus-cite-attribution-suffix' and perhaps +`gnus-cite-attribution-prefix' are considered attribution lines." + (interactive (list 'force)) + (save-excursion + (set-buffer gnus-article-buffer) + (gnus-cite-parse-maybe force) + (let ((buffer-read-only nil) + (alist gnus-cite-prefix-alist) + (faces gnus-cite-face-list) + (inhibit-point-motion-hooks t) + face entry prefix skip numbers number face-alist) + ;; Loop through citation prefixes. + (while alist + (setq entry (car alist) + alist (cdr alist) + prefix (car entry) + numbers (cdr entry) + face (car faces) + faces (or (cdr faces) gnus-cite-face-list) + face-alist (cons (cons prefix face) face-alist)) + (while numbers + (setq number (car numbers) + numbers (cdr numbers)) + (and (not (assq number gnus-cite-attribution-alist)) + (not (assq number gnus-cite-loose-attribution-alist)) + (gnus-cite-add-face number prefix face)))) + ;; Loop through attribution lines. + (setq alist gnus-cite-attribution-alist) + (while alist + (setq entry (car alist) + alist (cdr alist) + number (car entry) + prefix (cdr entry) + skip (gnus-cite-find-prefix number) + face (cdr (assoc prefix face-alist))) + ;; Add attribution button. + (goto-line number) + (when (re-search-forward gnus-cite-attribution-suffix + (save-excursion (end-of-line 1) (point)) + t) + (gnus-article-add-button (match-beginning 1) (match-end 1) + 'gnus-cite-toggle prefix)) + ;; Highlight attribution line. + (gnus-cite-add-face number skip face) + (gnus-cite-add-face number skip gnus-cite-attribution-face)) + ;; Loop through attribution lines. + (setq alist gnus-cite-loose-attribution-alist) + (while alist + (setq entry (car alist) + alist (cdr alist) + number (car entry) + skip (gnus-cite-find-prefix number)) + (gnus-cite-add-face number skip gnus-cite-attribution-face))))) + +(defun gnus-dissect-cited-text () + "Dissect the article buffer looking for cited text." + (save-excursion + (set-buffer gnus-article-buffer) + (gnus-cite-parse-maybe) + (let ((alist gnus-cite-prefix-alist) + prefix numbers number marks m) + ;; Loop through citation prefixes. + (while alist + (setq numbers (pop alist) + prefix (pop numbers)) + (while numbers + (setq number (pop numbers)) + (goto-char (point-min)) + (forward-line number) + (push (cons (point-marker) "") marks) + (while (and numbers + (= (1- number) (car numbers))) + (setq number (pop numbers))) + (goto-char (point-min)) + (forward-line (1- number)) + (push (cons (point-marker) prefix) marks))) + ;; Skip to the beginning of the body. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (push (cons (point-marker) "") marks) + ;; Find the end of the body. + (goto-char (point-max)) + (gnus-article-search-signature) + (push (cons (point-marker) "") marks) + ;; Sort the marks. + (setq marks (sort marks 'car-less-than-car)) + (let ((omarks marks)) + (setq marks nil) + (while (cdr omarks) + (if (= (caar omarks) (caadr omarks)) + (progn + (unless (equal (cdar omarks) "") + (push (car omarks) marks)) + (unless (equal (cdadr omarks) "") + (push (cadr omarks) marks)) + (unless (and (equal (cdar omarks) "") + (equal (cdadr omarks) "") + (not (cddr omarks))) + (setq omarks (cdr omarks)))) + (push (car omarks) marks)) + (setq omarks (cdr omarks))) + (when (car omarks) + (push (car omarks) marks)) + (setq marks (setq m (nreverse marks))) + (while (cddr m) + (if (and (equal (cdadr m) "") + (equal (cdar m) (cdaddr m)) + (goto-char (caadr m)) + (forward-line 1) + (= (point) (caaddr m))) + (setcdr m (cdddr m)) + (setq m (cdr m)))) + marks)))) + +(defun gnus-article-fill-cited-article (&optional force width) + "Do word wrapping in the current article. +If WIDTH (the numerical prefix), use that text width when filling." + (interactive (list t current-prefix-arg)) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (marks (gnus-dissect-cited-text)) + (adaptive-fill-mode nil) + (filladapt-mode nil) + (fill-column (if width (prefix-numeric-value width) fill-column))) + (save-restriction + (while (cdr marks) + (widen) + (narrow-to-region (caar marks) (caadr marks)) + (let ((adaptive-fill-regexp + (concat "^" (regexp-quote (cdar marks)) " *")) + (fill-prefix (cdar marks))) + (fill-region (point-min) (point-max))) + (set-marker (caar marks) nil) + (setq marks (cdr marks))) + (when marks + (set-marker (caar marks) nil)) + ;; All this information is now incorrect. + (setq gnus-cite-prefix-alist nil + gnus-cite-attribution-alist nil + gnus-cite-loose-prefix-alist nil + gnus-cite-loose-attribution-alist nil + gnus-cite-article nil))))) + +(defun gnus-article-hide-citation (&optional arg force) + "Toggle hiding of all cited text except attribution lines. +See the documentation for `gnus-article-highlight-citation'. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (append (gnus-article-hidden-arg) (list 'force))) + (gnus-set-format 'cited-text-button t) + (save-excursion + (set-buffer gnus-article-buffer) + (cond + ((gnus-article-check-hidden-text 'cite arg) + t) + ((gnus-article-text-type-exists-p 'cite) + (let ((buffer-read-only nil)) + (gnus-article-hide-text-of-type 'cite))) + (t + (let ((buffer-read-only nil) + (marks (gnus-dissect-cited-text)) + (inhibit-point-motion-hooks t) + (props (nconc (list 'article-type 'cite) + gnus-hidden-properties)) + beg end) + (while marks + (setq beg nil + end nil) + (while (and marks (string= (cdar marks) "")) + (setq marks (cdr marks))) + (when marks + (setq beg (caar marks))) + (while (and marks (not (string= (cdar marks) ""))) + (setq marks (cdr marks))) + (when marks + (setq end (caar marks))) + ;; Skip past lines we want to leave visible. + (when (and beg end gnus-cited-lines-visible) + (goto-char beg) + (forward-line gnus-cited-lines-visible) + (if (>= (point) end) + (setq beg nil) + (setq beg (point-marker)))) + (when (and beg end) + (gnus-add-text-properties beg end props) + (goto-char beg) + (unless (save-excursion (search-backward "\n\n" nil t)) + (insert "\n")) + (put-text-property + (point) + (progn + (gnus-article-add-button + (point) + (progn (eval gnus-cited-text-button-line-format-spec) (point)) + `gnus-article-toggle-cited-text (cons beg end)) + (point)) + 'article-type 'annotation) + (set-marker beg (point))))))))) + +(defun gnus-article-toggle-cited-text (region) + "Toggle hiding the text in REGION." + (let (buffer-read-only) + (funcall + (if (text-property-any + (car region) (1- (cdr region)) + (car gnus-hidden-properties) (cadr gnus-hidden-properties)) + 'remove-text-properties 'gnus-add-text-properties) + (car region) (cdr region) gnus-hidden-properties))) + +(defun gnus-article-hide-citation-maybe (&optional arg force) + "Toggle hiding of cited text that has an attribution line. +If given a negative prefix, always show; if given a positive prefix, +always hide. +This will do nothing unless at least `gnus-cite-hide-percentage' +percent and at least `gnus-cite-hide-absolute' lines of the body is +cited text with attributions. When called interactively, these two +variables are ignored. +See also the documentation for `gnus-article-highlight-citation'." + (interactive (append (gnus-article-hidden-arg) (list 'force))) + (unless (gnus-article-check-hidden-text 'cite arg) + (save-excursion + (set-buffer gnus-article-buffer) + (gnus-cite-parse-maybe force) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (let ((start (point)) + (atts gnus-cite-attribution-alist) + (buffer-read-only nil) + (inhibit-point-motion-hooks t) + (hiden 0) + total) + (goto-char (point-max)) + (gnus-article-search-signature) + (setq total (count-lines start (point))) + (while atts + (setq hiden (+ hiden (length (cdr (assoc (cdar atts) + gnus-cite-prefix-alist)))) + atts (cdr atts))) + (when (or force + (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) + (> hiden gnus-cite-hide-absolute))) + (setq atts gnus-cite-attribution-alist) + (while atts + (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) + atts (cdr atts)) + (while total + (setq hiden (car total) + total (cdr total)) + (goto-line hiden) + (unless (assq hiden gnus-cite-attribution-alist) + (gnus-add-text-properties + (point) (progn (forward-line 1) (point)) + (nconc (list 'article-type 'cite) + gnus-hidden-properties)))))))))) + +(defun gnus-article-hide-citation-in-followups () + "Hide cited text in non-root articles." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((article (cdr gnus-article-current))) + (unless (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-article-displayed-root-p article)) + (gnus-article-hide-citation))))) + +;;; Internal functions: + +(defun gnus-cite-parse-maybe (&optional force) + ;; Parse if the buffer has changes since last time. + (if (equal gnus-cite-article gnus-article-current) + () + ;;Reset parser information. + (setq gnus-cite-prefix-alist nil + gnus-cite-attribution-alist nil + gnus-cite-loose-prefix-alist nil + gnus-cite-loose-attribution-alist nil) + ;; Parse if not too large. + (if (and (not force) + gnus-cite-parse-max-size + (> (buffer-size) gnus-cite-parse-max-size)) + () + (setq gnus-cite-article (cons (car gnus-article-current) + (cdr gnus-article-current))) + (gnus-cite-parse-wrapper)))) + +(defun gnus-cite-parse-wrapper () + ;; Wrap chopped gnus-cite-parse + (goto-char (point-min)) + (unless (search-forward "\n\n" nil t) + (goto-char (point-max))) + (save-excursion + (gnus-cite-parse-attributions)) + ;; Try to avoid check citation if there is no reason to believe + ;; that article has citations + (if (or gnus-cite-always-check + (save-excursion + (re-search-backward gnus-cite-reply-regexp nil t)) + gnus-cite-loose-attribution-alist) + (progn (save-excursion + (gnus-cite-parse)) + (save-excursion + (gnus-cite-connect-attributions))))) + +(defun gnus-cite-parse () + ;; Parse and connect citation prefixes and attribution lines. + + ;; Parse current buffer searching for citation prefixes. + (let ((line (1+ (count-lines (point-min) (point)))) + (case-fold-search t) + (max (save-excursion + (goto-char (point-max)) + (gnus-article-search-signature) + (point))) + alist entry start begin end numbers prefix) + ;; Get all potential prefixes in `alist'. + (while (< (point) max) + ;; Each line. + (setq begin (point) + end (progn (beginning-of-line 2) (point)) + start end) + (goto-char begin) + ;; Ignore standard Supercite attribution prefix. + (when (looking-at gnus-supercite-regexp) + (if (match-end 1) + (setq end (1+ (match-end 1))) + (setq end (1+ begin)))) + ;; Ignore very long prefixes. + (when (> end (+ (point) gnus-cite-max-prefix)) + (setq end (+ (point) gnus-cite-max-prefix))) + (while (re-search-forward gnus-cite-prefix-regexp (1- end) t) + ;; Each prefix. + (setq end (match-end 0) + prefix (buffer-substring begin end)) + (gnus-set-text-properties 0 (length prefix) nil prefix) + (setq entry (assoc prefix alist)) + (if entry + (setcdr entry (cons line (cdr entry))) + (push (list prefix line) alist)) + (goto-char begin)) + (goto-char start) + (setq line (1+ line))) + ;; We got all the potential prefixes. Now create + ;; `gnus-cite-prefix-alist' containing the oldest prefix for each + ;; line that appears at least gnus-cite-minimum-match-count + ;; times. First sort them by length. Longer is older. + (setq alist (sort alist (lambda (a b) + (> (length (car a)) (length (car b)))))) + (while alist + (setq entry (car alist) + prefix (car entry) + numbers (cdr entry) + alist (cdr alist)) + (cond ((null numbers) + ;; No lines with this prefix that wasn't also part of + ;; a longer prefix. + ) + ((< (length numbers) gnus-cite-minimum-match-count) + ;; Too few lines with this prefix. We keep it a bit + ;; longer in case it is an exact match for an attribution + ;; line, but we don't remove the line from other + ;; prefixes. + (push entry gnus-cite-prefix-alist)) + (t + (push entry + gnus-cite-prefix-alist) + ;; Remove articles from other prefixes. + (let ((loop alist) + current) + (while loop + (setq current (car loop) + loop (cdr loop)) + (setcdr current + (gnus-set-difference (cdr current) numbers))))))))) + +(defun gnus-cite-parse-attributions () + (let (al-alist) + ;; Parse attributions + (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (wrote (count-lines (point-min) end)) + (prefix (gnus-cite-find-prefix wrote)) + ;; Check previous line for an attribution leader. + (tag (progn + (beginning-of-line 1) + (when (looking-at gnus-supercite-secondary-regexp) + (buffer-substring (match-beginning 1) + (match-end 1))))) + (in (progn + (goto-char start) + (and (re-search-backward gnus-cite-attribution-prefix + (save-excursion + (beginning-of-line 0) + (point)) + t) + (not (re-search-forward gnus-cite-attribution-suffix + start t)) + (count-lines (point-min) (1+ (point))))))) + (when (eq wrote in) + (setq in nil)) + (goto-char end) + ;; don't add duplicates + (let ((al (buffer-substring (save-excursion (beginning-of-line 0) + (1+ (point))) + end))) + (if (not (assoc al al-alist)) + (progn + (push (list wrote in prefix tag) + gnus-cite-loose-attribution-alist) + (push (cons al t) al-alist)))))))) + +(defun gnus-cite-connect-attributions () + ;; Connect attributions to citations + + ;; No citations have been connected to attribution lines yet. + (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil)) + + ;; Parse current buffer searching for attribution lines. + ;; Find exact supercite citations. + (gnus-cite-match-attributions 'small nil + (lambda (prefix tag) + (when tag + (concat "\\`" + (regexp-quote prefix) "[ \t]*" + (regexp-quote tag) ">")))) + ;; Find loose supercite citations after attributions. + (gnus-cite-match-attributions 'small t + (lambda (prefix tag) + (when tag + (concat "\\<" + (regexp-quote tag) + "\\>")))) + ;; Find loose supercite citations anywhere. + (gnus-cite-match-attributions 'small nil + (lambda (prefix tag) + (when tag + (concat "\\<" + (regexp-quote tag) + "\\>")))) + ;; Find nested citations after attributions. + (gnus-cite-match-attributions 'small-if-unique t + (lambda (prefix tag) + (concat "\\`" (regexp-quote prefix) ".+"))) + ;; Find nested citations anywhere. + (gnus-cite-match-attributions 'small nil + (lambda (prefix tag) + (concat "\\`" (regexp-quote prefix) ".+"))) + ;; Remove loose prefixes with too few lines. + (let ((alist gnus-cite-loose-prefix-alist) + entry) + (while alist + (setq entry (car alist) + alist (cdr alist)) + (when (< (length (cdr entry)) gnus-cite-minimum-match-count) + (setq gnus-cite-prefix-alist + (delq entry gnus-cite-prefix-alist) + gnus-cite-loose-prefix-alist + (delq entry gnus-cite-loose-prefix-alist))))) + ;; Find flat attributions. + (gnus-cite-match-attributions 'first t nil) + ;; Find any attributions (are we getting desperate yet?). + (gnus-cite-match-attributions 'first nil nil)) + +(defun gnus-cite-match-attributions (sort after fun) + ;; Match all loose attributions and citations (SORT AFTER FUN) . + ;; + ;; If SORT is `small', the citation with the shortest prefix will be + ;; used, if it is `first' the first prefix will be used, if it is + ;; `small-if-unique' the shortest prefix will be used if the + ;; attribution line does not share its own prefix with other + ;; loose attribution lines, otherwise the first prefix will be used. + ;; + ;; If AFTER is non-nil, only citations after the attribution line + ;; will be considered. + ;; + ;; If FUN is non-nil, it will be called with the arguments (WROTE + ;; PREFIX TAG) and expected to return a regular expression. Only + ;; citations whose prefix matches the regular expression will be + ;; considered. + ;; + ;; WROTE is the attribution line number. + ;; PREFIX is the attribution line prefix. + ;; TAG is the Supercite tag on the attribution line. + (let ((atts gnus-cite-loose-attribution-alist) + (case-fold-search t) + att wrote in prefix tag regexp limit smallest best size) + (while atts + (setq att (car atts) + atts (cdr atts) + wrote (nth 0 att) + in (nth 1 att) + prefix (nth 2 att) + tag (nth 3 att) + regexp (if fun (funcall fun prefix tag) "") + size (cond ((eq sort 'small) t) + ((eq sort 'first) nil) + (t (< (length (gnus-cite-find-loose prefix)) 2))) + limit (if after wrote -1) + smallest 1000000 + best nil) + (let ((cites gnus-cite-loose-prefix-alist) + cite candidate numbers first compare) + (while cites + (setq cite (car cites) + cites (cdr cites) + candidate (car cite) + numbers (cdr cite) + first (apply 'min numbers) + compare (if size (length candidate) first)) + (and (> first limit) + regexp + (string-match regexp candidate) + (< compare smallest) + (setq best cite + smallest compare)))) + (if (null best) + () + (setq gnus-cite-loose-attribution-alist + (delq att gnus-cite-loose-attribution-alist)) + (push (cons wrote (car best)) gnus-cite-attribution-alist) + (when in + (push (cons in (car best)) gnus-cite-attribution-alist)) + (when (memq best gnus-cite-loose-prefix-alist) + (let ((loop gnus-cite-prefix-alist) + (numbers (cdr best)) + current) + (setq gnus-cite-loose-prefix-alist + (delq best gnus-cite-loose-prefix-alist)) + (while loop + (setq current (car loop) + loop (cdr loop)) + (if (eq current best) + () + (setcdr current (gnus-set-difference (cdr current) numbers)) + (when (null (cdr current)) + (setq gnus-cite-loose-prefix-alist + (delq current gnus-cite-loose-prefix-alist) + atts (delq current atts))))))))))) + +(defun gnus-cite-find-loose (prefix) + ;; Return a list of loose attribution lines prefixed by PREFIX. + (let* ((atts gnus-cite-loose-attribution-alist) + att line lines) + (while atts + (setq att (car atts) + line (car att) + atts (cdr atts)) + (when (string-equal (gnus-cite-find-prefix line) prefix) + (push line lines))) + lines)) + +(defun gnus-cite-add-face (number prefix face) + ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. + (when face + (let ((inhibit-point-motion-hooks t) + from to) + (goto-line number) + (unless (eobp);; Sometimes things become confused. + (forward-char (length prefix)) + (skip-chars-forward " \t") + (setq from (point)) + (end-of-line 1) + (skip-chars-backward " \t") + (setq to (point)) + (when (< from to) + (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))) + +(defun gnus-cite-toggle (prefix) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) + (inhibit-point-motion-hooks t) + number) + (while numbers + (setq number (car numbers) + numbers (cdr numbers)) + (goto-line number) + (cond ((get-text-property (point) 'invisible) + (remove-text-properties (point) (progn (forward-line 1) (point)) + gnus-hidden-properties)) + ((assq number gnus-cite-attribution-alist)) + (t + (gnus-add-text-properties + (point) (progn (forward-line 1) (point)) + (nconc (list 'article-type 'cite) + gnus-hidden-properties)))))))) + +(defun gnus-cite-find-prefix (line) + ;; Return citation prefix for LINE. + (let ((alist gnus-cite-prefix-alist) + (prefix "") + entry) + (while alist + (setq entry (car alist) + alist (cdr alist)) + (when (memq line (cdr entry)) + (setq prefix (car entry)))) + prefix)) + +(gnus-add-shutdown 'gnus-cache-close 'gnus) + +(defun gnus-cache-close () + (setq gnus-cite-prefix-alist nil)) + +(gnus-ems-redefine) + +(provide 'gnus-cite) + +;;; gnus-cite.el ends here diff --git a/lisp/gnus-cus.el b/lisp/gnus-cus.el new file mode 100644 index 0000000..37c0bf9 --- /dev/null +++ b/lisp/gnus-cus.el @@ -0,0 +1,650 @@ +;;; gnus-cus.el --- customization commands for Gnus +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'wid-edit) +(require 'gnus-score) + +;;; Widgets: + +;; There should be special validation for this. +(define-widget 'gnus-email-address 'string + "An email address") + +(defun gnus-custom-mode () + "Major mode for editing Gnus customization buffers. + +The following commands are available: + +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. + +Entry to this mode calls the value of `gnus-custom-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'gnus-custom-mode + mode-name "Gnus Customize") + (use-local-map widget-keymap) + (run-hooks 'gnus-custom-mode-hook)) + +;;; Group Customization: + +(defconst gnus-group-parameters + '((to-address (gnus-email-address :tag "To Address") "\ +This will be used when doing followups and posts. + +This is primarily useful in mail groups that represent closed +mailing lists--mailing lists where it's expected that everybody that +writes to the mailing list is subscribed to it. Since using this +parameter ensures that the mail only goes to the mailing list itself, +it means that members won't receive two copies of your followups. + +Using `to-address' will actually work whether the group is foreign or +not. Let's say there's a group on the server that is called +`fa.4ad-l'. This is a real newsgroup, but the server has gotten the +articles from a mail-to-news gateway. Posting directly to this group +is therefore impossible--you have to send mail to the mailing list +address instead.") + + (to-list (gnus-email-address :tag "To List") "\ +This address will be used when doing a `a' in the group. + +It is totally ignored when doing a followup--except that if it is +present in a news group, you'll get mail group semantics when doing +`f'.") + + (broken-reply-to (const :tag "Broken Reply To" t) "\ +Ignore `Reply-To' headers in this group. + +That can be useful if you're reading a mailing list group where the +listserv has inserted `Reply-To' headers that point back to the +listserv itself. This is broken behavior. So there!") + + (to-group (string :tag "To Group") "\ +All posts will be send to the specified group.") + + (gcc-self (choice :tag "GCC" + :value t + (const t) + (const none) + (string :format "%v" :hide-front-space t)) "\ +Specify default value for GCC header. + +If this symbol is present in the group parameter list and set to `t', +new composed messages will be `Gcc''d to the current group. If it is +present and set to `none', no `Gcc:' header will be generated, if it +is present and a string, this string will be inserted literally as a +`gcc' header (this symbol takes precedence over any default `Gcc' +rules as described later).") + + (auto-expire (const :tag "Automatic Expire" t) "\ +All articles that are read will be marked as expirable.") + + (total-expire (const :tag "Total Expire" t) "\ +All read articles will be put through the expiry process + +This happens even if they are not marked as expirable. +Use with caution.") + + (expiry-wait (choice :tag "Expire Wait" + :value never + (const never) + (const immediate) + (number :hide-front-space t + :format "%v")) "\ +When to expire. + +Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function' +when expiring expirable messages. The value can either be a number of +days (not necessarily an integer) or the symbols `never' or +`immediate'.") + + (score-file (file :tag "Score File") "\ +Make the specified file into the current score file. +This means that all score commands you issue will end up in this file.") + + (adapt-file (file :tag "Adapt File") "\ +Make the specified file into the current adaptive file. +All adaptive score entries will be put into this file.") + + (admin-address (gnus-email-address :tag "Admin Address") "\ +Administration address for a mailing list. + +When unsubscribing to a mailing list you should never send the +unsubscription notice to the mailing list itself. Instead, you'd +send messages to the administrative address. This parameter allows +you to put the admin address somewhere convenient.") + + (display (choice :tag "Display" + :value default + (const all) + (const default)) "\ +Which articles to display on entering the group. + +`all' + Display all articles, both read and unread. + +`default' + Display the default visible articles, which normally includes + unread and ticked articles.") + + (comment (string :tag "Comment") "\ +An arbitrary comment on the group.")) + "Alist of valid group parameters. + +Each entry has the form (NAME TYPE DOC), where NAME is the parameter +itself (a symbol), TYPE is the parameters type (a sexp widget), and +DOC is a documentation string for the parameter.") + +(defvar gnus-custom-params) +(defvar gnus-custom-method) +(defvar gnus-custom-group) + +(defun gnus-group-customize (group &optional part) + "Edit the group on the current line." + (interactive (list (gnus-group-group-name))) + (let ((part (or part 'info)) + info + (types (mapcar (lambda (entry) + `(cons :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,(nth 1 entry))) + gnus-group-parameters))) + (unless group + (error "No group on current line")) + (unless (setq info (gnus-get-info group)) + (error "Killed group; can't be edited")) + ;; Ready. + (kill-buffer (get-buffer-create "*Gnus Customize*")) + (switch-to-buffer (get-buffer-create "*Gnus Customize*")) + (gnus-custom-mode) + (make-local-variable 'gnus-custom-group) + (setq gnus-custom-group group) + (widget-insert "Customize the ") + (widget-create 'info-link + :help-echo "Push me to learn more." + :tag "group parameters" + "(gnus)Group Parameters") + (widget-insert " for <") + (widget-insert group) + (widget-insert "> and press ") + (widget-create 'push-button + :tag "done" + :help-echo "Push me when done customizing." + :action 'gnus-group-customize-done) + (widget-insert ".\n\n") + (make-local-variable 'gnus-custom-params) + (setq gnus-custom-params + (widget-create 'group + :value (gnus-info-params info) + `(set :inline t + :greedy t + :tag "Parameters" + :format "%t:\n%h%v" + :doc "\ +These special paramerters are recognized by Gnus. +Check the [ ] for the parameters you want to apply to this group, then +edit the value to suit your taste." + ,@types) + '(repeat :inline t + :tag "Variables" + :format "%t:\n%h%v%i\n\n" + :doc "\ +Set variables local to the group you are entering. + +If you want to turn threading off in `news.answers', you could put +`(gnus-show-threads nil)' in the group parameters of that group. +`gnus-show-threads' will be made into a local variable in the summary +buffer you enter, and the form `nil' will be `eval'ed there. + +This can also be used as a group-specific hook function, if you'd +like. If you want to hear a beep when you enter a group, you could +put something like `(dummy-variable (ding))' in the parameters of that +group. `dummy-variable' will be set to the result of the `(ding)' +form, but who cares?" + (group :value (nil nil) + (symbol :tag "Variable") + (sexp :tag + "Value"))) + + '(repeat :inline t + :tag "Unknown entries" + sexp))) + (widget-insert "\n\nYou can also edit the ") + (widget-create 'info-link + :tag "select method" + :help-echo "Push me to learn more about select methods." + "(gnus)Select Methods") + (widget-insert " for the group.\n") + (setq gnus-custom-method + (widget-create 'sexp + :tag "Method" + :value (gnus-info-method info))) + (use-local-map widget-keymap) + (widget-setup))) + +(defun gnus-group-customize-done (&rest ignore) + "Apply changes and bury the buffer." + (interactive) + (gnus-group-edit-group-done 'params gnus-custom-group + (widget-value gnus-custom-params)) + (gnus-group-edit-group-done 'method gnus-custom-group + (widget-value gnus-custom-method)) + (bury-buffer)) + +;;; Score Customization: + +(defconst gnus-score-parameters + '((mark (number :tag "Mark") "\ +The value of this entry should be a number. +Any articles with a score lower than this number will be marked as read.") + + (expunge (number :tag "Expunge") "\ +The value of this entry should be a number. +Any articles with a score lower than this number will be removed from +the summary buffer.") + + (mark-and-expunge (number :tag "Mark-and-expunge") "\ +The value of this entry should be a number. +Any articles with a score lower than this number will be marked as +read and removed from the summary buffer.") + + (thread-mark-and-expunge (number :tag "Thread-mark-and-expunge") "\ +The value of this entry should be a number. +All articles that belong to a thread that has a total score below this +number will be marked as read and removed from the summary buffer. +`gnus-thread-score-function' says how to compute the total score +for a thread.") + + (files (repeat :tag "Files" file) "\ +The value of this entry should be any number of file names. +These files are assumed to be score files as well, and will be loaded +the same way this one was.") + + (exclude-files (repeat :tag "Exclude-files" file) "\ +The clue of this entry should be any number of files. +These files will not be loaded, even though they would normally be so, +for some reason or other.") + + (eval (sexp :tag "Eval" :value nil) "\ +The value of this entry will be `eval'el. +This element will be ignored when handling global score files.") + + (read-only (boolean :tag "Read-only" :value t) "\ +Read-only score files will not be updated or saved. +Global score files should feature this atom.") + + (orphan (number :tag "Orphan") "\ +The value of this entry should be a number. +Articles that do not have parents will get this number added to their +scores. Imagine you follow some high-volume newsgroup, like +`comp.lang.c'. Most likely you will only follow a few of the threads, +also want to see any new threads. + +You can do this with the following two score file entries: + + (orphan -500) + (mark-and-expunge -100) + +When you enter the group the first time, you will only see the new +threads. You then raise the score of the threads that you find +interesting (with `I T' or `I S'), and ignore (`C y') the rest. +Next time you enter the group, you will see new articles in the +interesting threads, plus any new threads. + +I.e.---the orphan score atom is for high-volume groups where there +exist a few interesting threads which can't be found automatically +by ordinary scoring rules.") + + (adapt (choice :tag "Adapt" + (const t) + (const ignore) + (sexp :format "%v" + :hide-front-space t)) "\ +This entry controls the adaptive scoring. +If it is `t', the default adaptive scoring rules will be used. If it +is `ignore', no adaptive scoring will be performed on this group. If +it is a list, this list will be used as the adaptive scoring rules. +If it isn't present, or is something other than `t' or `ignore', the +default adaptive scoring rules will be used. If you want to use +adaptive scoring on most groups, you'd set `gnus-use-adaptive-scoring' +to `t', and insert an `(adapt ignore)' in the groups where you do not +want adaptive scoring. If you only want adaptive scoring in a few +groups, you'd set `gnus-use-adaptive-scoring' to `nil', and insert +`(adapt t)' in the score files of the groups where you want it.") + + (adapt-file (file :tag "Adapt-file") "\ +All adaptive score entries will go to the file named by this entry. +It will also be applied when entering the group. This atom might +be handy if you want to adapt on several groups at once, using the +same adaptive file for a number of groups.") + + (local (repeat :tag "Local" + (group :value (nil nil) + (symbol :tag "Variable") + (sexp :tag "Value"))) "\ +The value of this entry should be a list of `(VAR VALUE)' pairs. +Each VAR will be made buffer-local to the current summary buffer, +and set to the value specified. This is a convenient, if somewhat +strange, way of setting variables in some groups if you don't like +hooks much.") + (touched (sexp :format "Touched\n") "Internal variable.")) + "Alist of valid symbolic score parameters. + +Each entry has the form (NAME TYPE DOC), where NAME is the parameter +itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a +documentation string for the parameter.") + +(define-widget 'gnus-score-string 'group + "Edit score entries for string-valued headers." + :convert-widget 'gnus-score-string-convert) + +(defun gnus-score-string-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(string :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value s + ;; I should really create a forgiving :match + ;; function for each type below, that only + ;; looked at the first letter. + (const :tag "Regexp" r) + (const :tag "Regexp (fixed case)" R) + (const :tag "Substring" s) + (const :tag "Substring (fixed case)" S) + (const :tag "Exact" e) + (const :tag "Exact (fixed case)" E) + (const :tag "Word" w) + (const :tag "Word (fixed case)" W) + (const :tag "default" nil))) + (group `(group ,match ,score ,expire ,type)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header.\n")) + " +You can have an arbitrary number of score entries for this header, +each score entry has four elements: + +1. The \"match element\". This should be the string to look for in the + header. + +2. The \"score element\". This number should be an integer in the + neginf to posinf interval. This number is added to the score + of the article if the match is successful. If this element is + not present, the `gnus-score-interactive-default-score' number + will be used instead. This is 1000 by default. + +3. The \"date element\". This date says when the last time this score + entry matched, which provides a mechanism for expiring the + score entries. It this element is not present, the score + entry is permanent. The date is represented by the number of + days since December 31, 1 ce. + +4. The \"type element\". This element specifies what function should + be used to see whether this score entry matches the article. + + There are the regexp, as well as substring types, and exact match, + and word match types. If this element is not present, Gnus will + assume that substring matching should be used. There is case + sensitive variants of all match types."))) + (widget-put widget :args `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + (choice :format "%v" + :value ("" nil nil s) + ,group + sexp))))) + widget) + +(define-widget 'gnus-score-integer 'group + "Edit score entries for integer-valued headers." + :convert-widget 'gnus-score-integer-convert) + +(defun gnus-score-integer-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(integer :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value < + (const <) + (const >) + (const =) + (const >=) + (const <=))) + (group `(group ,match ,score ,expire ,type)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header."))))) + (widget-put widget :args `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + ,group)))) + widget) + +(define-widget 'gnus-score-date 'group + "Edit score entries for date-valued headers." + :convert-widget 'gnus-score-date-convert) + +(defun gnus-score-date-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(string :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value regexp + (const regexp) + (const before) + (const at) + (const after))) + (group `(group ,match ,score ,expire ,type)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header.")) + " +For the Date header we have three kinda silly match types: `before', +`at' and `after'. I can't really imagine this ever being useful, but, +like, it would feel kinda silly not to provide this function. Just in +case. You never know. Better safe than sorry. Once burnt, twice +shy. Don't judge a book by its cover. Never not have sex on a first +date. (I have been told that at least one person, and I quote, +\"found this function indispensable\", however.) + +A more useful match type is `regexp'. With it, you can match the date +string using a regular expression. The date is normalized to ISO8601 +compact format first---`YYYYMMDDTHHMMSS'. If you want to match all +articles that have been posted on April 1st in every year, you could +use `....0401.........' as a match string, for instance. (Note that +the date is kept in its original time zone, so this will match +articles that were posted when it was April 1st where the article was +posted from. Time zones are such wholesome fun for the whole family, +eh?"))) + (widget-put widget :args `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + ,group)))) + widget) + +(defvar gnus-custom-scores) +(defvar gnus-custom-score-alist) + +(defun gnus-score-customize (file) + "Customize score file FILE." + (interactive (list gnus-current-score-file)) + (let ((scores (gnus-score-load file)) + (types (mapcar (lambda (entry) + `(group :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,(nth 1 entry))) + gnus-score-parameters))) + ;; Ready. + (kill-buffer (get-buffer-create "*Gnus Customize*")) + (switch-to-buffer (get-buffer-create "*Gnus Customize*")) + (gnus-custom-mode) + (make-local-variable 'gnus-custom-score-alist) + (setq gnus-custom-score-alist scores) + (widget-insert "Customize the ") + (widget-create 'info-link + :help-echo "Push me to learn more." + :tag "score entries" + "(gnus)Score File Format") + (widget-insert " for\n\t") + (widget-insert file) + (widget-insert "\nand press ") + (widget-create 'push-button + :tag "done" + :help-echo "Push me when done customizing." + :action 'gnus-score-customize-done) + (widget-insert ".\n +Check the [ ] for the entries you want to apply to this score file, then +edit the value to suit your taste. Don't forget to mark the checkbox, +if you do all your changes will be lost. ") + (widget-create 'push-button + :action (lambda (&rest ignore) + (require 'gnus-audio) + (gnus-audio-play "Evil_Laugh.au")) + "Bhahahah!") + (widget-insert "\n\n") + (make-local-variable 'gnus-custom-scores) + (setq gnus-custom-scores + (widget-create 'group + :value scores + `(checklist :inline t + :greedy t + (gnus-score-string :tag "From") + (gnus-score-string :tag "Subject") + (gnus-score-string :tag "References") + (gnus-score-string :tag "Xref") + (gnus-score-string :tag "Message-ID") + (gnus-score-integer :tag "Lines") + (gnus-score-integer :tag "Chars") + (gnus-score-date :tag "Date") + (gnus-score-string :tag "Head" + :doc "\ +Match all headers in the article. + +Using one of `Head', `Body', `All' will slow down scoring considerable. +") + (gnus-score-string :tag "Body" + :doc "\ +Match the body sans header of the article. + +Using one of `Head', `Body', `All' will slow down scoring considerable. +") + (gnus-score-string :tag "All" + :doc "\ +Match the entire article, including both headers and body. + +Using one of `Head', `Body', `All' will slow down scoring +considerable. +") + (gnus-score-string :tag + "Followup" + :doc "\ +Score all followups to the specified authors. + +This entry is somewhat special, in that it will match the `From:' +header, and affect the score of not only the matching articles, but +also all followups to the matching articles. This allows you +e.g. increase the score of followups to your own articles, or decrease +the score of followups to the articles of some known trouble-maker. +") + (gnus-score-string :tag "Thread" + :doc "\ +Add a score entry on all articles that are part of a thread. + +This match key works along the same lines as the `Followup' match key. +If you say that you want to score on a (sub-)thread that is started by +an article with a `Message-ID' X, then you add a `thread' match. This +will add a new `thread' match for each article that has X in its +`References' header. (These new `thread' matches will use the +`Message-ID's of these matching articles.) This will ensure that you +can raise/lower the score of an entire thread, even though some +articles in the thread may not have complete `References' headers. +Note that using this may lead to undeterministic scores of the +articles in the thread. +") + ,@types) + '(repeat :inline t + :tag "Unknown entries" + sexp))) + (use-local-map widget-keymap) + (widget-setup))) + +(defun gnus-score-customize-done (&rest ignore) + "Reset the score alist with the present value." + (let ((alist gnus-custom-score-alist) + (value (widget-value gnus-custom-scores))) + (setcar alist (car value)) + (setcdr alist (cdr value)) + (gnus-score-set 'touched '(t) alist)) + (bury-buffer)) + +;;; The End: + +(provide 'gnus-cus) + +;;; gnus-cus.el ends here + diff --git a/lisp/gnus-demon.el b/lisp/gnus-demon.el new file mode 100644 index 0000000..ec1f2bd --- /dev/null +++ b/lisp/gnus-demon.el @@ -0,0 +1,308 @@ +;;; gnus-demon.el --- daemonic Gnus behaviour +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-int) +(require 'nnheader) +(eval-and-compile + (if (string-match "XEmacs" (emacs-version)) + (require 'itimer) + (require 'timer))) + +(defgroup gnus-demon nil + "Demonic behaviour." + :group 'gnus) + +(defcustom gnus-demon-handlers nil + "Alist of daemonic handlers to be run at intervals. +Each handler is a list on the form + +\(FUNCTION TIME IDLE) + +FUNCTION is the function to be called. +TIME is the number of `gnus-demon-timestep's between each call. +If nil, never call. If t, call each `gnus-demon-timestep'. +If IDLE is t, only call if Emacs has been idle for a while. If IDLE +is a number, only call when Emacs has been idle more than this number +of `gnus-demon-timestep's. If IDLE is nil, don't care about +idleness. If IDLE is a number and TIME is nil, then call once each +time Emacs has been idle for IDLE `gnus-demon-timestep's." + :group 'gnus-demon + :type '(repeat (list function + (choice :tag "Time" + (const :tag "never" nil) + (const :tag "one" t) + (integer :tag "steps" 1)) + (choice :tag "Idle" + (const :tag "don't care" nil) + (const :tag "for a while" t) + (integer :tag "steps" 1))))) + +(defcustom gnus-demon-timestep 60 + "*Number of seconds in each demon timestep." + :group 'gnus-demon + :type 'integer) + +;;; Internal variables. + +(defvar gnus-demon-timer nil) +(defvar gnus-demon-idle-has-been-called nil) +(defvar gnus-demon-idle-time 0) +(defvar gnus-demon-handler-state nil) +(defvar gnus-demon-last-keys nil) +(defvar gnus-inhibit-demon nil + "*If non-nil, no daemonic function will be run.") + +(eval-and-compile + (autoload 'timezone-parse-date "timezone") + (autoload 'timezone-make-arpa-date "timezone")) + +;;; Functions. + +(defun gnus-demon-add-handler (function time idle) + "Add the handler FUNCTION to be run at TIME and IDLE." + ;; First remove any old handlers that use this function. + (gnus-demon-remove-handler function) + ;; Then add the new one. + (push (list function time idle) gnus-demon-handlers) + (gnus-demon-init)) + +(defun gnus-demon-remove-handler (function &optional no-init) + "Remove the handler FUNCTION from the list of handlers." + (setq gnus-demon-handlers + (delq (assq function gnus-demon-handlers) + gnus-demon-handlers)) + (unless no-init + (gnus-demon-init))) + +(defun gnus-demon-init () + "Initialize the Gnus daemon." + (interactive) + (gnus-demon-cancel) + (when gnus-demon-handlers + ;; Set up the timer. + (setq gnus-demon-timer + (nnheader-run-at-time + gnus-demon-timestep gnus-demon-timestep 'gnus-demon)) + ;; Reset control variables. + (setq gnus-demon-handler-state + (mapcar + (lambda (handler) + (list (car handler) (gnus-demon-time-to-step (nth 1 handler)) + (nth 2 handler))) + gnus-demon-handlers)) + (setq gnus-demon-idle-time 0) + (setq gnus-demon-idle-has-been-called nil) + (setq gnus-use-demon t))) + +(gnus-add-shutdown 'gnus-demon-cancel 'gnus) + +(defun gnus-demon-cancel () + "Cancel any Gnus daemons." + (interactive) + (when gnus-demon-timer + (nnheader-cancel-timer gnus-demon-timer)) + (setq gnus-demon-timer nil + gnus-use-demon nil + gnus-demon-idle-has-been-called nil) + (condition-case () + (nnheader-cancel-function-timers 'gnus-demon) + (error t))) + +(defun gnus-demon-is-idle-p () + "Whether Emacs is idle or not." + ;; We do this simply by comparing the 100 most recent keystrokes + ;; with the ones we had last time. If they are the same, one might + ;; guess that Emacs is indeed idle. This only makes sense if one + ;; calls this function seldom -- like once a minute, which is what + ;; we do here. + (let ((keys (recent-keys))) + (or (equal keys gnus-demon-last-keys) + (progn + (setq gnus-demon-last-keys keys) + nil)))) + +(defun gnus-demon-time-to-step (time) + "Find out how many seconds to TIME, which is on the form \"17:43\"." + (if (not (stringp time)) + time + (let* ((now (current-time)) + ;; obtain NOW as discrete components -- make a vector for speed + (nowParts (apply 'vector (decode-time now))) + ;; obtain THEN as discrete components + (thenParts (timezone-parse-time time)) + (thenHour (string-to-int (elt thenParts 0))) + (thenMin (string-to-int (elt thenParts 1))) + ;; convert time as elements into number of seconds since EPOCH. + (then (encode-time 0 + thenMin + thenHour + ;; If THEN is earlier than NOW, make it + ;; same time tomorrow. Doc for encode-time + ;; says that this is OK. + (+ (elt nowParts 3) + (if (or (< thenHour (elt nowParts 2)) + (and (= thenHour (elt nowParts 2)) + (<= thenMin (elt nowParts 1)))) + 1 0)) + (elt nowParts 4) + (elt nowParts 5) + (elt nowParts 6) + (elt nowParts 7) + (elt nowParts 8))) + ;; calculate number of seconds between NOW and THEN + (diff (+ (* 65536 (- (car then) (car now))) + (- (cadr then) (cadr now))))) + ;; return number of timesteps in the number of seconds + (round (/ diff gnus-demon-timestep))))) + +(defun gnus-demon () + "The Gnus daemon that takes care of running all Gnus handlers." + ;; Increase or reset the time Emacs has been idle. + (if (gnus-demon-is-idle-p) + (incf gnus-demon-idle-time) + (setq gnus-demon-idle-time 0) + (setq gnus-demon-idle-has-been-called nil)) + ;; Disable all daemonic stuff if we're in the minibuffer + (when (and (not (window-minibuffer-p (selected-window))) + (not gnus-inhibit-demon)) + ;; Then we go through all the handler and call those that are + ;; sufficiently ripe. + (let ((handlers gnus-demon-handler-state) + (gnus-inhibit-demon t) + handler time idle) + (while handlers + (setq handler (pop handlers)) + (cond + ((numberp (setq time (nth 1 handler))) + ;; These handlers use a regular timeout mechanism. We decrease + ;; the timer if it hasn't reached zero yet. + (unless (zerop time) + (setcar (nthcdr 1 handler) (decf time))) + (and (zerop time) ; If the timer now is zero... + ;; Test for appropriate idleness + (progn + (setq idle (nth 2 handler)) + (cond + ((null idle) t) ; Don't care about idle. + ((numberp idle) ; Numerical idle... + (< idle gnus-demon-idle-time)) ; Idle timed out. + (t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle. + ;; So we call the handler. + (progn + (ignore-errors (funcall (car handler))) + ;; And reset the timer. + (setcar (nthcdr 1 handler) + (gnus-demon-time-to-step + (nth 1 (assq (car handler) gnus-demon-handlers))))))) + ;; These are only supposed to be called when Emacs is idle. + ((null (setq idle (nth 2 handler))) + ;; We do nothing. + ) + ((and (not (numberp idle)) + (gnus-demon-is-idle-p)) + ;; We want to call this handler each and every time that + ;; Emacs is idle. + (ignore-errors (funcall (car handler)))) + (t + ;; We want to call this handler only if Emacs has been idle + ;; for a specified number of timesteps. + (and (not (memq (car handler) gnus-demon-idle-has-been-called)) + (< idle gnus-demon-idle-time) + (gnus-demon-is-idle-p) + (progn + (ignore-errors (funcall (car handler))) + ;; Make sure the handler won't be called once more in + ;; this idle-cycle. + (push (car handler) gnus-demon-idle-has-been-called))))))))) + +(defun gnus-demon-add-nocem () + "Add daemonic NoCeM handling to Gnus." + (gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30)) + +(defun gnus-demon-scan-nocem () + "Scan NoCeM groups for NoCeM messages." + (save-window-excursion + (gnus-nocem-scan-groups))) + +(defun gnus-demon-add-disconnection () + "Add daemonic server disconnection to Gnus." + (gnus-demon-add-handler 'gnus-demon-close-connections nil 30)) + +(defun gnus-demon-close-connections () + (save-window-excursion + (gnus-close-backends))) + +(defun gnus-demon-add-scanmail () + "Add daemonic scanning of mail from the mail backends." + (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60)) + +(defun gnus-demon-scan-mail () + (save-window-excursion + (let ((servers gnus-opened-servers) + server) + (while (setq server (car (pop servers))) + (and (gnus-check-backend-function 'request-scan (car server)) + (or (gnus-server-opened server) + (gnus-open-server server)) + (gnus-request-scan nil server)))))) + +(defun gnus-demon-add-rescan () + "Add daemonic scanning of new articles from all backends." + (gnus-demon-add-handler 'gnus-demon-scan-news 120 60)) + +(defun gnus-demon-scan-news () + (save-window-excursion + (when (gnus-alive-p) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-get-new-news))))) + +(defun gnus-demon-add-scan-timestamps () + "Add daemonic updating of timestamps in empty newgroups." + (gnus-demon-add-handler 'gnus-demon-scan-timestamps nil 30)) + +(defun gnus-demon-scan-timestamps () + "Set the timestamp on all newsgroups with no unread and no ticked articles." + (when (gnus-alive-p) + (let ((cur-time (current-time)) + (newsrc (cdr gnus-newsrc-alist)) + info group unread has-ticked) + (while (setq info (pop newsrc)) + (setq group (gnus-info-group info) + unread (gnus-group-unread group) + has-ticked (cdr (assq 'tick (gnus-info-marks info)))) + (when (and (numberp unread) + (= unread 0) + (not has-ticked)) + (gnus-group-set-parameter group 'timestamp cur-time)))))) + +(provide 'gnus-demon) + +;;; gnus-demon.el ends here diff --git a/lisp/gnus-draft.el b/lisp/gnus-draft.el new file mode 100644 index 0000000..31ad3f5 --- /dev/null +++ b/lisp/gnus-draft.el @@ -0,0 +1,168 @@ +;;; gnus-draft.el --- draft message support for Gnus +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-sum) +(require 'message) +(require 'gnus-msg) +(require 'nndraft) +(eval-when-compile (require 'cl)) + +;;; Draft minor mode + +(defvar gnus-draft-mode nil + "Minor mode for providing a draft summary buffers.") + +(defvar gnus-draft-mode-map nil) + +(unless gnus-draft-mode-map + (setq gnus-draft-mode-map (make-sparse-keymap)) + + (gnus-define-keys gnus-draft-mode-map + "Dt" gnus-draft-toggle-sending + "De" gnus-draft-edit-message + "Ds" gnus-draft-send-message + "DS" gnus-draft-send-all-messages)) + +(defun gnus-draft-make-menu-bar () + (unless (boundp 'gnus-draft-menu) + (easy-menu-define + gnus-draft-menu gnus-draft-mode-map "" + '("Drafts" + ["Toggle whether to send" gnus-draft-toggle-sending t])))) + +(defun gnus-draft-mode (&optional arg) + "Minor mode for providing a draft summary buffers. + +\\{gnus-draft-mode-map}" + (interactive "P") + (when (eq major-mode 'gnus-summary-mode) + (when (set (make-local-variable 'gnus-draft-mode) + (if (null arg) (not gnus-draft-mode) + (> (prefix-numeric-value arg) 0))) + ;; Set up the menu. + (when (gnus-visual-p 'draft-menu 'menu) + (gnus-draft-make-menu-bar)) + (gnus-add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map) + (run-hooks 'gnus-draft-mode-hook)))) + +;;; Commands + +(defun gnus-draft-toggle-sending (article) + "Toggle whether to send an article or not." + (interactive (list (gnus-summary-article-number))) + (if (gnus-draft-article-sendable-p article) + (progn + (push article gnus-newsgroup-unsendable) + (gnus-summary-mark-article article gnus-unsendable-mark)) + (setq gnus-newsgroup-unsendable + (delq article gnus-newsgroup-unsendable)) + (gnus-summary-mark-article article gnus-unread-mark)) + (gnus-summary-position-point)) + +(defun gnus-draft-edit-message () + "Enter a mail/post buffer to edit and send the draft." + (interactive) + (gnus-set-global-variables) + (let ((article (gnus-summary-article-number))) + (gnus-draft-setup article gnus-newsgroup-name) + (push + `((lambda () + (when (buffer-name (get-buffer ,gnus-summary-buffer)) + (save-excursion + (set-buffer (get-buffer ,gnus-summary-buffer)) + (gnus-cache-possibly-remove-article ,article nil nil nil t) + (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) + message-send-actions))) + +(defun gnus-draft-send-message (&optional n) + "Send the current draft." + (interactive "P") + (gnus-set-global-variables) + (let ((articles (gnus-summary-work-articles n)) + article) + (while (setq article (pop articles)) + (gnus-summary-remove-process-mark article) + (unless (memq article gnus-newsgroup-unsendable) + (gnus-draft-send article gnus-newsgroup-name) + (gnus-summary-mark-article article gnus-canceled-mark))))) + +(defun gnus-draft-send (article &optional group) + "Send message ARTICLE." + (gnus-draft-setup article (or group "nndraft:queue")) + (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)) + (message-send-and-exit))) + +(defun gnus-draft-send-all-messages () + "Send all the sendable drafts." + (interactive) + (gnus-uu-mark-buffer) + (gnus-draft-send-message)) + +(defun gnus-group-send-drafts () + "Send all sendable articles from the queue group." + (interactive) + (gnus-request-group "nndraft:queue") + (save-excursion + (let ((articles (nndraft-articles)) + (unsendable (gnus-uncompress-range + (cdr (assq 'unsend + (gnus-info-marks + (gnus-get-info "nndraft:queue")))))) + article) + (while (setq article (pop articles)) + (unless (memq article unsendable) + (gnus-draft-send article)))))) + +;;; Utility functions + +;;;!!!If this is byte-compiled, it fails miserably. +;;;!!!I have no idea why. + +(progn +(defun gnus-draft-setup (narticle group) + (gnus-setup-message 'forward + (let ((article narticle)) + (message-mail) + (erase-buffer) + (message "%s %s" group article) + (if (not (gnus-request-restore-buffer article group)) + (error "Couldn't restore the article") + ;; Insert the separator. + (goto-char (point-min)) + (search-forward "\n\n") + (forward-char -1) + (insert mail-header-separator) + (forward-line 1)))))) + +(defun gnus-draft-article-sendable-p (article) + "Say whether ARTICLE is sendable." + (not (memq article gnus-newsgroup-unsendable))) + +(provide 'gnus-draft) + +;;; gnus-draft.el ends here diff --git a/lisp/gnus-dup.el b/lisp/gnus-dup.el new file mode 100644 index 0000000..e0265e3 --- /dev/null +++ b/lisp/gnus-dup.el @@ -0,0 +1,160 @@ +;;; gnus-dup.el --- suppression of duplicate articles in Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package tries to mark articles as read the second time the +;; user reads a copy. This is useful if the server doesn't support +;; Xref properly, or if the user reads the same group from several +;; servers. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-art) + +(defgroup gnus-duplicate nil + "Suppression of duplicate articles." + :group 'gnus) + +(defcustom gnus-save-duplicate-list nil + "*If non-nil, save the duplicate list when shutting down Gnus. +If nil, duplicate suppression will only work on duplicates +seen in the same session." + :group 'gnus-duplicate + :type 'boolean) + +(defcustom gnus-duplicate-list-length 10000 + "*The number of Message-IDs to keep in the duplicate suppression list." + :group 'gnus-duplicate + :type 'integer) + +(defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression") + "*The name of the file to store the duplicate suppression list." + :group 'gnus-duplicate + :type 'file) + +;;; Internal variables + +(defvar gnus-dup-list nil) +(defvar gnus-dup-hashtb nil) + +(defvar gnus-dup-list-dirty nil) + +;;; +;;; Starting and stopping +;;; + +(gnus-add-shutdown 'gnus-dup-close 'gnus) + +(defun gnus-dup-close () + "Possibly save the duplicate suppression list and shut down the subsystem." + (gnus-dup-save) + (setq gnus-dup-list nil + gnus-dup-hashtb nil + gnus-dup-list-dirty nil)) + +(defun gnus-dup-open () + "Possibly read the duplicate suppression list and start the subsystem." + (if gnus-save-duplicate-list + (gnus-dup-read) + (setq gnus-dup-list nil)) + (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) + ;; Enter all Message-IDs into the hash table. + (let ((list gnus-dup-list) + (obarray gnus-dup-hashtb)) + (while list + (intern (pop list))))) + +(defun gnus-dup-read () + "Read the duplicate suppression list." + (setq gnus-dup-list nil) + (when (file-exists-p gnus-duplicate-file) + (load gnus-duplicate-file t t t))) + +(defun gnus-dup-save () + "Save the duplicate suppression list." + (when (and gnus-save-duplicate-list + gnus-dup-list-dirty) + (nnheader-temp-write gnus-duplicate-file + (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list)))) + (setq gnus-dup-list-dirty nil)) + +;;; +;;; Interface functions +;;; + +(defun gnus-dup-enter-articles () + "Enter articles from the current group for future duplicate suppression." + (unless gnus-dup-list + (gnus-dup-open)) + (setq gnus-dup-list-dirty t) ; mark list for saving + (let ((data gnus-newsgroup-data) + datum msgid) + ;; Enter the Message-IDs of all read articles into the list + ;; and hash table. + (while (setq datum (pop data)) + (when (and (not (gnus-data-pseudo-p datum)) + (> (gnus-data-number datum) 0) + (not (memq (gnus-data-number datum) gnus-newsgroup-unreads)) + (not (= (gnus-data-mark datum) gnus-canceled-mark)) + (setq msgid (mail-header-id (gnus-data-header datum))) + (not (nnheader-fake-message-id-p msgid)) + (not (intern-soft msgid gnus-dup-hashtb))) + (push msgid gnus-dup-list) + (intern msgid gnus-dup-hashtb)))) + ;; Chop off excess Message-IDs from the list. + (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) + (when end + (setcdr end nil)))) + +(defun gnus-dup-suppress-articles () + "Mark duplicate articles as read." + (unless gnus-dup-list + (gnus-dup-open)) + (gnus-message 6 "Suppressing duplicates...") + (let ((headers gnus-newsgroup-headers) + number header) + (while (setq header (pop headers)) + (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) + (gnus-summary-article-unread-p (mail-header-number header))) + (setq gnus-newsgroup-unreads + (delq (setq number (mail-header-number header)) + gnus-newsgroup-unreads)) + (push (cons number gnus-duplicate-mark) + gnus-newsgroup-reads)))) + (gnus-message 6 "Suppressing duplicates...done")) + +(defun gnus-dup-unsuppress-article (article) + "Stop suppression of ARTICLE." + (let ((id (mail-header-id (gnus-data-header (gnus-data-find article))))) + (when id + (setq gnus-dup-list-dirty t) + (setq gnus-dup-list (delete id gnus-dup-list)) + (unintern id gnus-dup-hashtb)))) + +(provide 'gnus-dup) + +;;; gnus-dup.el ends here diff --git a/lisp/gnus-eform.el b/lisp/gnus-eform.el new file mode 100644 index 0000000..b8df3d3 --- /dev/null +++ b/lisp/gnus-eform.el @@ -0,0 +1,130 @@ +;;; gnus-eform.el --- a mode for editing forms for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-win) + +;;; +;;; Editing forms +;;; + +(defgroup gnus-edit-form nil + "A mode for editing forms." + :group 'gnus) + +(defcustom gnus-edit-form-mode-hook nil + "Hook run in `gnus-edit-form-mode' buffers." + :group 'gnus-edit-form + :type 'hook) + +(defcustom gnus-edit-form-menu-hook nil + "Hook run when creating menus in `gnus-edit-form-mode' buffers." + :group 'gnus-edit-form + :type 'hook) + +;;; Internal variables + +(defvar gnus-edit-form-done-function nil) +(defvar gnus-edit-form-buffer "*Gnus edit form*") + +(defvar gnus-edit-form-mode-map nil) +(unless gnus-edit-form-mode-map + (setq gnus-edit-form-mode-map (copy-keymap emacs-lisp-mode-map)) + (gnus-define-keys gnus-edit-form-mode-map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit)) + +(defun gnus-edit-form-make-menu-bar () + (unless (boundp 'gnus-edit-form-menu) + (easy-menu-define + gnus-edit-form-menu gnus-edit-form-mode-map "" + '("Edit Form" + ["Exit and save changes" gnus-edit-form-done t] + ["Exit" gnus-edit-form-exit t])) + (run-hooks 'gnus-edit-form-menu-hook))) + +(defun gnus-edit-form-mode () + "Major mode for editing forms. +It is a slightly enhanced emacs-lisp-mode. + +\\{gnus-edit-form-mode-map}" + (interactive) + (when (gnus-visual-p 'group-menu 'menu) + (gnus-edit-form-make-menu-bar)) + (kill-all-local-variables) + (setq major-mode 'gnus-edit-form-mode) + (setq mode-name "Edit Form") + (use-local-map gnus-edit-form-mode-map) + (make-local-variable 'gnus-edit-form-done-function) + (make-local-variable 'gnus-prev-winconf) + (run-hooks 'gnus-edit-form-mode-hook)) + +(defun gnus-edit-form (form documentation exit-func) + "Edit FORM in a new buffer. +Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning +of the buffer." + (let ((winconf (current-window-configuration))) + (set-buffer (get-buffer-create gnus-edit-form-buffer)) + (gnus-configure-windows 'edit-form) + (gnus-add-current-to-buffer-list) + (gnus-edit-form-mode) + (setq gnus-prev-winconf winconf) + (setq gnus-edit-form-done-function exit-func) + (erase-buffer) + (insert documentation) + (unless (bolp) + (insert "\n")) + (goto-char (point-min)) + (while (not (eobp)) + (insert ";;; ") + (forward-line 1)) + (insert ";; Type `C-c C-c' after you've finished editing.\n") + (insert "\n") + (let ((p (point))) + (pp form (current-buffer)) + (insert "\n") + (goto-char p)))) + +(defun gnus-edit-form-done () + "Update changes and kill the current buffer." + (interactive) + (goto-char (point-min)) + (let ((form (read (current-buffer))) + (func gnus-edit-form-done-function)) + (gnus-edit-form-exit) + (funcall func form))) + +(defun gnus-edit-form-exit () + "Kill the current buffer." + (interactive) + (let ((winconf gnus-prev-winconf)) + (kill-buffer (current-buffer)) + (set-window-configuration winconf))) + +(provide 'gnus-eform) + +;;; gnus-eform.el ends here diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el new file mode 100644 index 0000000..3112671 --- /dev/null +++ b/lisp/gnus-ems.el @@ -0,0 +1,263 @@ +;;; gnus-ems.el --- functions for making Gnus work under different Emacsen +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +;;; Function aliases later to be redefined for XEmacs usage. + +(defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version) + "Non-nil if running under XEmacs.") + +(defvar gnus-mouse-2 [mouse-2]) +(defvar gnus-down-mouse-2 [down-mouse-2]) +(defvar gnus-mode-line-modified + (if (or gnus-xemacs + (< emacs-major-version 20)) + '("--**-" . "-----") + '("**" "--"))) + +(eval-and-compile + (autoload 'gnus-xmas-define "gnus-xmas") + (autoload 'gnus-xmas-redefine "gnus-xmas") + (autoload 'appt-select-lowest-window "appt")) + +(or (fboundp 'mail-file-babyl-p) + (fset 'mail-file-babyl-p 'rmail-file-p)) + +;;; Mule functions. + +(defun gnus-mule-cite-add-face (number prefix face) + ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. + (when face + (let ((inhibit-point-motion-hooks t) + from to) + (goto-line number) + (if (boundp 'MULE) + (forward-char (chars-in-string prefix)) + (forward-char (length prefix))) + (skip-chars-forward " \t") + (setq from (point)) + (end-of-line 1) + (skip-chars-backward " \t") + (setq to (point)) + (when (< from to) + (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) + +(defun gnus-mule-max-width-function (el max-width) + (` (let* ((val (eval (, el))) + (valstr (if (numberp val) + (int-to-string val) val))) + (if (> (length valstr) (, max-width)) + (truncate-string valstr (, max-width)) + valstr)))) + +(defun gnus-encode-coding-string (string system) + string) + +(defun gnus-decode-coding-string (string system) + string) + +(eval-and-compile + (if (string-match "XEmacs\\|Lucid" emacs-version) + nil + + (defvar gnus-mouse-face-prop 'mouse-face + "Property used for highlighting mouse regions.")) + + (cond + ((string-match "XEmacs\\|Lucid" emacs-version) + (gnus-xmas-define)) + + ((or (not (boundp 'emacs-minor-version)) + (< emacs-minor-version 30)) + ;; Remove the `intangible' prop. + (let ((props (and (boundp 'gnus-hidden-properties) + gnus-hidden-properties))) + (while (and props (not (eq (car (cdr props)) 'intangible))) + (setq props (cdr props))) + (when props + (setcdr props (cdr (cdr (cdr props)))))) + (unless (fboundp 'buffer-substring-no-properties) + (defun buffer-substring-no-properties (beg end) + (format "%s" (buffer-substring beg end))))) + + ((boundp 'MULE) + (provide 'gnusutil)))) + +(eval-and-compile + (cond + ((not window-system) + (defun gnus-dummy-func (&rest args)) + (let ((funcs '(mouse-set-point set-face-foreground + set-face-background x-popup-menu))) + (while funcs + (unless (fboundp (car funcs)) + (fset (car funcs) 'gnus-dummy-func)) + (setq funcs (cdr funcs)))))) + (unless (fboundp 'file-regular-p) + (defun file-regular-p (file) + (and (not (file-directory-p file)) + (not (file-symlink-p file)) + (file-exists-p file)))) + (unless (fboundp 'face-list) + (defun face-list (&rest args)))) + +(eval-and-compile + (let ((case-fold-search t)) + (cond + ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type)) + (setq nnheader-file-name-translation-alist + (append nnheader-file-name-translation-alist + '((?: . ?_) + (?+ . ?-)))))))) + +(defvar gnus-tmp-unread) +(defvar gnus-tmp-replied) +(defvar gnus-tmp-score-char) +(defvar gnus-tmp-indentation) +(defvar gnus-tmp-opening-bracket) +(defvar gnus-tmp-lines) +(defvar gnus-tmp-name) +(defvar gnus-tmp-closing-bracket) +(defvar gnus-tmp-subject-or-nil) + +(defun gnus-ems-redefine () + (cond + ((string-match "XEmacs\\|Lucid" emacs-version) + (gnus-xmas-redefine)) + + ((featurep 'mule) + ;; Mule and new Emacs definitions + + ;; [Note] Now there are three kinds of mule implementations, + ;; original MULE, XEmacs/mule and beta version of Emacs including + ;; some mule features. Unfortunately these API are different. In + ;; particular, Emacs (including original MULE) and XEmacs are + ;; quite different. + ;; Predicates to check are following: + ;; (boundp 'MULE) is t only if MULE (original; anything older than + ;; Mule 2.3) is running. + ;; (featurep 'mule) is t when every mule variants are running. + + ;; These implementations may be able to share between original + ;; MULE and beta version of new Emacs. In addition, it is able to + ;; detect XEmacs/mule by (featurep 'mule) and to check variable + ;; `emacs-version'. In this case, implementation for XEmacs/mule + ;; may be able to share between XEmacs and XEmacs/mule. + + (defalias 'gnus-truncate-string 'truncate-string) + + (defvar gnus-summary-display-table nil + "Display table used in summary mode buffers.") + (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) + (fset 'gnus-max-width-function 'gnus-mule-max-width-function) + (fset 'gnus-summary-set-display-table 'ignore) + (fset 'gnus-encode-coding-string 'encode-coding-string) + (fset 'gnus-decode-coding-string 'decode-coding-string) + + (when (boundp 'gnus-check-before-posting) + (setq gnus-check-before-posting + (delq 'long-lines + (delq 'control-chars gnus-check-before-posting)))) + + (defun gnus-summary-line-format-spec () + (insert gnus-tmp-unread gnus-tmp-replied + gnus-tmp-score-char gnus-tmp-indentation) + (put-text-property + (point) + (progn + (insert + gnus-tmp-opening-bracket + (format "%4d: %-20s" + gnus-tmp-lines + (if (> (length gnus-tmp-name) 20) + (truncate-string gnus-tmp-name 20) + gnus-tmp-name)) + gnus-tmp-closing-bracket) + (point)) + gnus-mouse-face-prop gnus-mouse-face) + (insert " " gnus-tmp-subject-or-nil "\n")) + ))) + +(defun gnus-region-active-p () + "Say whether the region is active." + (and (boundp 'transient-mark-mode) + transient-mark-mode + (boundp 'mark-active) + mark-active)) + +(defun gnus-add-minor-mode (mode name map) + (if (fboundp 'add-minor-mode) + (add-minor-mode mode name map) + (unless (assq mode minor-mode-alist) + (push `(,mode ,name) minor-mode-alist)) + (unless (assq mode minor-mode-map-alist) + (push (cons mode map) + minor-mode-map-alist)))) + +(defun gnus-x-splash () + "Show a splash screen using a pixmap in the current buffer." + (let ((dir (nnheader-find-etc-directory "gnus")) + pixmap file height beg i) + (save-excursion + (switch-to-buffer (get-buffer-create gnus-group-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (when (and dir + (file-exists-p (setq file (concat dir "x-splash")))) + (nnheader-temp-write nil + (insert-file-contents file) + (goto-char (point-min)) + (ignore-errors + (setq pixmap (read (current-buffer)))))) + (when pixmap + (erase-buffer) + (unless (facep 'gnus-splash) + (make-face 'gnus-splash)) + (setq height (/ (car pixmap) (frame-char-height)) + width (/ (cadr pixmap) (frame-char-width))) + (set-face-foreground 'gnus-splash "ForestGreen") + (set-face-stipple 'gnus-splash pixmap) + (insert-char ?\n (* (/ (window-height) 2 height) height)) + (setq i height) + (while (> i 0) + (insert-char ? (* (+ (/ (window-width) 2 width) 1) width)) + (setq beg (point)) + (insert-char ? width) + (set-text-properties beg (point) '(face gnus-splash)) + (insert "\n") + (decf i)) + (goto-char (point-min)) + (sit-for 0)))))) + +(provide 'gnus-ems) + +;; Local Variables: +;; byte-compile-warnings: '(redefine callargs) +;; End: + +;;; gnus-ems.el ends here diff --git a/lisp/gnus-gl.el b/lisp/gnus-gl.el new file mode 100644 index 0000000..786cda4 --- /dev/null +++ b/lisp/gnus-gl.el @@ -0,0 +1,860 @@ +;;; gnus-gl.el --- an interface to GroupLens for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Brad Miller +;; Keywords: news, score + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; GroupLens software and documentation is copyright (c) 1995 by Paul +;; Resnick (Massachusetts Institute of Technology); Brad Miller, John +;; Riedl, Jon Herlocker, and Joseph Konstan (University of Minnesota), +;; and David Maltz (Carnegie-Mellon University). +;; +;; Permission to use, copy, modify, and distribute this documentation +;; for non-commercial and commercial purposes without fee is hereby +;; granted provided that this copyright notice and permission notice +;; appears in all copies and that the names of the individuals and +;; institutions holding this copyright are not used in advertising or +;; publicity pertaining to this software without specific, written +;; prior permission. The copyright holders make no representations +;; about the suitability of this software and documentation for any +;; purpose. It is provided ``as is'' without express or implied +;; warranty. +;; +;; The copyright holders request that they be notified of +;; modifications of this code. Please send electronic mail to +;; grouplens@cs.umn.edu for more information or to announce derived +;; works. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Author: Brad Miller +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; User Documentation: +;; To use GroupLens you must load this file. +;; You must also register a pseudonym with the Better Bit Bureau. +;; http://www.cs.umn.edu/Research/GroupLens +;; +;; ---------------- For your .emacs or .gnus file ---------------- +;; +;; As of version 2.5, grouplens now works as a minor mode of +;; gnus-summary-mode. To get make that work you just need a couple of +;; hooks. +;; (setq gnus-use-grouplens t) +;; (setq grouplens-pseudonym "") +;; (setq grouplens-bbb-host "grouplens.cs.umn.edu") +;; +;; (setq gnus-summary-default-score 0) +;; +;; USING GROUPLENS +;; How do I Rate an article?? +;; Before you type n to go to the next article, hit a number from 1-5 +;; Type r in the summary buffer and you will be prompted. +;; Note that when you're in grouplens-minor-mode 'r' masks the +;; usual reply binding for 'r' +;; +;; What if, Gasp, I find a bug??? +;; Please type M-x gnus-gl-submit-bug-report. This will set up a +;; mail buffer with the state of variables and buffers that will help +;; me debug the problem. A short description up front would help too! +;; +;; How do I display the prediction for an article: +;; If you set the gnus-summary-line-format as shown above, the score +;; (prediction) will be shown automatically. +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Programmer Notes +;; 10/9/95 +;; gnus-scores-articles contains the articles +;; When scoring is done, the call tree looks something like: +;; gnus-possibly-score-headers +;; ==> gnus-score-headers +;; ==> gnus-score-load-file +;; ==> get-all-mids (from the eval form) +;; +;; it would be nice to have one that gets called after all the other +;; headers have been scored. +;; we may want a variable gnus-grouplens-scale-factor +;; and gnus-grouplens-offset this would probably be either -3 or 0 +;; to make the scores centered around zero or not. +;; Notes 10/12/95 +;; According to Lars, Norse god of gnus, the simple way to insert a +;; call to an external function is to have a function added to the +;; variable gnus-score-find-files-function This new function +;; gnus-grouplens-score-alist will return a core alist that +;; has (("message-id" ("" score) ("" score)) +;; This seems like it would be pretty inefficient, though workable. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TODO +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; 3. Add some more ways to rate messages +;; 4. Better error handling for token timeouts. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bugs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus-score) +(require 'gnus) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; User variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar gnus-summary-grouplens-line-format + "%U\%R\%z%l%I\%(%[%4L: %-20,20n%]%) %s\n" + "*The line format spec in summary GroupLens mode buffers.") + +(defvar grouplens-pseudonym "" + "User's pseudonym. +This pseudonym is obtained during the registration process") + +(defvar grouplens-bbb-host "grouplens.cs.umn.edu" + "Host where the bbbd is running" ) + +(defvar grouplens-bbb-port 9000 + "Port where the bbbd is listening" ) + +(defvar grouplens-newsgroups + '("comp.groupware" "comp.human-factors" "comp.lang.c++" + "comp.lang.java" "comp.os.linux.admin" "comp.os.linux.advocacy" + "comp.os.linux.announce" "comp.os.linux.answers" + "comp.os.linux.development" "comp.os.linux.development.apps" + "comp.os.linux.development.system" "comp.os.linux.hardware" + "comp.os.linux.help" "comp.os.linux.m68k" "comp.os.linux.misc" + "comp.os.linux.networking" "comp.os.linux.setup" "comp.os.linux.x" + "mn.general" "rec.arts.movies" "rec.arts.movies.current-films" + "rec.food.recipes" "rec.humor") + "*Groups that are part of the GroupLens experiment.") + +(defvar grouplens-prediction-display 'prediction-spot + "valid values are: + prediction-spot -- an * corresponding to the prediction between 1 and 5, + confidence-interval -- a numeric confidence interval + prediction-bar -- |##### | the longer the bar, the better the article, + confidence-bar -- | ----- } the prediction is in the middle of the bar, + confidence-spot -- ) * | the spot gets bigger with more confidence, + prediction-num -- plain-old numeric value, + confidence-plus-minus -- prediction +/i confidence") + +(defvar grouplens-score-offset 0 + "Offset the prediction by this value. +Setting this variable to -2 would have the following effect on +GroupLens scores: + + 1 --> -2 + 2 --> -1 + 3 --> 0 + 4 --> 1 + 5 --> 2 + +The reason is that a user might want to do this is to combine +GroupLens predictions with scores calculated by other score methods.") + +(defvar grouplens-score-scale-factor 1 + "This variable allows the user to magnify the effect of GroupLens scores. +The scale factor is applied after the offset.") + +(defvar gnus-grouplens-override-scoring 'override + "Tell GroupLens to override the normal Gnus scoring mechanism. +GroupLens scores can be combined with gnus scores in one of three ways. +'override -- just use grouplens predictions for grouplens groups +'combine -- combine grouplens scores with gnus scores +'separate -- treat grouplens scores completely separate from gnus") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Program global variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar grouplens-bbb-token nil + "Current session token number") + +(defvar grouplens-bbb-process nil + "Process Id of current bbbd network stream process") + +(defvar grouplens-bbb-buffer nil + "Buffer associated with the BBBD process") + +(defvar grouplens-rating-alist nil + "Current set of message-id rating pairs") + +(defvar grouplens-current-hashtable nil + "A hashtable to hold predictions from the BBB") + +(defvar grouplens-current-group nil) + +;;(defvar bbb-alist nil) + +(defvar bbb-timeout-secs 10 + "Number of seconds to wait for some response from the BBB. +If this times out we give up and assume that something has died..." ) + +(defvar grouplens-previous-article nil + "Message-ID of the last article read.") + +(defvar bbb-read-point) +(defvar bbb-response-point) + +(defun bbb-renew-hash-table () + (setq grouplens-current-hashtable (make-vector 100 0))) + +(bbb-renew-hash-table) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Utility Functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun bbb-connect-to-bbbd (host port) + (unless grouplens-bbb-buffer + (setq grouplens-bbb-buffer + (get-buffer-create (format " *BBBD trace: %s*" host))) + (save-excursion + (set-buffer grouplens-bbb-buffer) + (make-local-variable 'bbb-read-point) + (make-local-variable 'bbb-response-point) + (setq bbb-read-point (point-min)))) + + ;; if an old process is still running for some reason, kill it + (when grouplens-bbb-process + (ignore-errors + (when (eq 'open (process-status grouplens-bbb-process)) + (set-process-buffer grouplens-bbb-process nil) + (delete-process grouplens-bbb-process)))) + + ;; clear the trace buffer of old output + (save-excursion + (set-buffer grouplens-bbb-buffer) + (erase-buffer)) + + ;; open the connection to the server + (catch 'done + (condition-case error + (setq grouplens-bbb-process + (open-network-stream "BBBD" grouplens-bbb-buffer host port)) + (error (gnus-message 3 "Error: Failed to connect to BBB") + nil)) + (and (null grouplens-bbb-process) + (throw 'done nil)) + (save-excursion + (set-buffer grouplens-bbb-buffer) + (setq bbb-read-point (point-min)) + (or (bbb-read-response grouplens-bbb-process) + (throw 'done nil)))) + + ;; return the process + grouplens-bbb-process) + +(defun bbb-send-command (process command) + (goto-char (point-max)) + (insert command) + (insert "\r\n") + (setq bbb-read-point (point)) + (setq bbb-response-point (point)) + (set-marker (process-mark process) (point)) ; process output also comes here + (process-send-string process command) + (process-send-string process "\r\n") + (process-send-eof process)) + +(defun bbb-read-response (process) + "This function eats the initial response of OK or ERROR from the BBB." + (let ((case-fold-search nil) + match-end) + (goto-char bbb-read-point) + (while (and (not (search-forward "\r\n" nil t)) + (accept-process-output process bbb-timeout-secs)) + (goto-char bbb-read-point)) + (setq match-end (point)) + (goto-char bbb-read-point) + (setq bbb-read-point match-end) + (looking-at "OK"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Login Functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun bbb-login () + "return the token number if login is successful, otherwise return nil" + (interactive) + (setq grouplens-bbb-token nil) + (if (not (equal grouplens-pseudonym "")) + (let ((bbb-process + (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) + (if bbb-process + (save-excursion + (set-buffer (process-buffer bbb-process)) + (bbb-send-command bbb-process + (concat "login " grouplens-pseudonym)) + (if (bbb-read-response bbb-process) + (setq grouplens-bbb-token (bbb-extract-token-number)) + (gnus-message 3 "Error: GroupLens login failed"))))) + (gnus-message 3 "Error: you must set a pseudonym")) + grouplens-bbb-token) + +(defun bbb-extract-token-number () + (let ((token-pos (search-forward "token=" nil t))) + (when (looking-at "[0-9]+") + (buffer-substring token-pos (match-end 0))))) + +(gnus-add-shutdown 'bbb-logout 'gnus) + +(defun bbb-logout () + "logout of bbb session" + (when grouplens-bbb-token + (let ((bbb-process + (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) + (when bbb-process + (save-excursion + (set-buffer (process-buffer bbb-process)) + (bbb-send-command bbb-process (concat "logout " grouplens-bbb-token)) + (bbb-read-response bbb-process)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Get Predictions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun bbb-build-mid-scores-alist (groupname) + "this function can be called as part of the function to return the +list of score files to use. See the gnus variable +gnus-score-find-score-files-function. + +*Note:* If you want to use grouplens scores along with calculated scores, +you should see the offset and scale variables. At this point, I don't +recommend using both scores and grouplens predictions together." + (setq grouplens-current-group groupname) + (when (member groupname grouplens-newsgroups) + (setq grouplens-previous-article nil) + ;; scores-alist should be a list of lists: + ;; ((("message-id" ("" score1 nil s) (" score2 nil s)))) + ;;`((("message-id" . ,predict-list))) ; Yes, this is the return value + (list + (list + (list (append (list "message-id") + (bbb-get-predictions (bbb-get-all-mids) groupname))))))) + +(defun bbb-get-predictions (midlist groupname) + "Ask the bbb for predictions, and build up the score alist." + (gnus-message 5 "Fetching Predictions...") + (if grouplens-bbb-token + (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host + grouplens-bbb-port))) + (when bbb-process + (save-excursion + (set-buffer (process-buffer bbb-process)) + (bbb-send-command bbb-process + (bbb-build-predict-command midlist groupname + grouplens-bbb-token)) + (if (bbb-read-response bbb-process) + (bbb-get-prediction-response bbb-process) + (gnus-message 1 "Invalid Token, login and try again") + (ding))))) + (gnus-message 3 "Error: You are not logged in to a BBB") + (ding))) + +(defun bbb-get-all-mids () + (mapcar (function (lambda (x) (mail-header-id x))) gnus-newsgroup-headers)) + +(defun bbb-build-predict-command (mlist grpname token) + (concat "getpredictions " token " " grpname "\r\n" + (mapconcat 'identity mlist "\r\n") "\r\n.\r\n")) + +(defun bbb-get-prediction-response (process) + (let ((case-fold-search nil)) + (goto-char bbb-read-point) + (while (and (not (search-forward ".\r\n" nil t)) + (accept-process-output process bbb-timeout-secs)) + (goto-char bbb-read-point)) + (goto-char (+ bbb-response-point 4));; we ought to be right before OK + (bbb-build-response-alist))) + +;; build-response-alist assumes that the cursor has been positioned at +;; the first line of the list of mid/rating pairs. +(defun bbb-build-response-alist () + (let (resp mid pred) + (while + (cond + ((looking-at "\\(<.*>\\) :nopred=") + ;;(push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp) + (forward-line 1) + t) + ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)") + (setq mid (bbb-get-mid) + pred (bbb-get-pred)) + (push `(,mid ,pred nil s) resp) + (gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh)) + grouplens-current-hashtable) + (forward-line 1) + t) + ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)") + (setq mid (bbb-get-mid) + pred (bbb-get-pred)) + (push `(,mid ,pred nil s) resp) + (gnus-sethash mid (list pred 0 0) grouplens-current-hashtable) + (forward-line 1) + t) + (t nil))) + resp)) + +;; these "get" functions assume that there is an active match lying +;; around. Where the first parenthesized expression is the +;; message-id, and the second is the prediction, the third and fourth +;; are the confidence interval +;; +;; Since gnus assumes that scores are integer values?? we round the +;; prediction. +(defun bbb-get-mid () + (buffer-substring (match-beginning 1) (match-end 1))) + +(defun bbb-get-pred () + (let ((tpred (string-to-number (buffer-substring (match-beginning 2) + (match-end 2))))) + (if (> tpred 0) + (round (* grouplens-score-scale-factor + (+ grouplens-score-offset tpred))) + 1))) + +(defun bbb-get-confl () + (string-to-number (buffer-substring (match-beginning 4) (match-end 4)))) + +(defun bbb-get-confh () + (string-to-number (buffer-substring (match-beginning 4) (match-end 4)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Prediction Display +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defconst grplens-rating-range 4.0) +(defconst grplens-maxrating 5) +(defconst grplens-minrating 1) +(defconst grplens-predstringsize 12) + +(defvar gnus-tmp-score) +(defun bbb-grouplens-score (header) + (if (eq gnus-grouplens-override-scoring 'separate) + (bbb-grouplens-other-score header) + (let* ((rate-string (make-string 12 ?\ )) + (mid (mail-header-id header)) + (hashent (gnus-gethash mid grouplens-current-hashtable)) + (iscore gnus-tmp-score) + (low (car (cdr hashent))) + (high (car (cdr (cdr hashent))))) + (aset rate-string 0 ?|) + (aset rate-string 11 ?|) + (unless (member grouplens-current-group grouplens-newsgroups) + (unless (equal grouplens-prediction-display 'prediction-num) + (cond ((< iscore 0) + (setq iscore 1)) + ((> iscore 5) + (setq iscore 5)))) + (setq low 0) + (setq high 0)) + (if (and (bbb-valid-score iscore) + (not (null mid))) + (cond + ;; prediction-spot + ((equal grouplens-prediction-display 'prediction-spot) + (setq rate-string (bbb-fmt-prediction-spot rate-string iscore))) + ;; confidence-interval + ((equal grouplens-prediction-display 'confidence-interval) + (setq rate-string (bbb-fmt-confidence-interval iscore low high))) + ;; prediction-bar + ((equal grouplens-prediction-display 'prediction-bar) + (setq rate-string (bbb-fmt-prediction-bar rate-string iscore))) + ;; confidence-bar + ((equal grouplens-prediction-display 'confidence-bar) + (setq rate-string (format "| %4.2f |" iscore))) + ;; confidence-spot + ((equal grouplens-prediction-display 'confidence-spot) + (setq rate-string (format "| %4.2f |" iscore))) + ;; prediction-num + ((equal grouplens-prediction-display 'prediction-num) + (setq rate-string (bbb-fmt-prediction-num iscore))) + ;; confidence-plus-minus + ((equal grouplens-prediction-display 'confidence-plus-minus) + (setq rate-string (bbb-fmt-confidence-plus-minus iscore low high)) + ) + (t (gnus-message 3 "Invalid prediction display type"))) + (aset rate-string 5 ?N) (aset rate-string 6 ?A)) + rate-string))) + +;; Gnus user format function that doesn't depend on +;; bbb-build-mid-scores-alist being used as the score function, but is +;; instead called from gnus-select-group-hook. -- LAB +(defun bbb-grouplens-other-score (header) + (if (not (member grouplens-current-group grouplens-newsgroups)) + ;; Return an empty string + "" + (let* ((rate-string (make-string 12 ?\ )) + (mid (mail-header-id header)) + (hashent (gnus-gethash mid grouplens-current-hashtable)) + (pred (or (nth 0 hashent) 0)) + (low (nth 1 hashent)) + (high (nth 2 hashent))) + ;; Init rate-string + (aset rate-string 0 ?|) + (aset rate-string 11 ?|) + (unless (equal grouplens-prediction-display 'prediction-num) + (cond ((< pred 0) + (setq pred 1)) + ((> pred 5) + (setq pred 5)))) + ;; If no entry in BBB hash mark rate string as NA and return + (cond + ((null hashent) + (aset rate-string 5 ?N) + (aset rate-string 6 ?A) + rate-string) + + ((equal grouplens-prediction-display 'prediction-spot) + (bbb-fmt-prediction-spot rate-string pred)) + + ((equal grouplens-prediction-display 'confidence-interval) + (bbb-fmt-confidence-interval pred low high)) + + ((equal grouplens-prediction-display 'prediction-bar) + (bbb-fmt-prediction-bar rate-string pred)) + + ((equal grouplens-prediction-display 'confidence-bar) + (format "| %4.2f |" pred)) + + ((equal grouplens-prediction-display 'confidence-spot) + (format "| %4.2f |" pred)) + + ((equal grouplens-prediction-display 'prediction-num) + (bbb-fmt-prediction-num pred)) + + ((equal grouplens-prediction-display 'confidence-plus-minus) + (bbb-fmt-confidence-plus-minus pred low high)) + + (t + (gnus-message 3 "Invalid prediction display type") + (aset rate-string 0 ?|) + (aset rate-string 11 ?|) + rate-string))))) + +(defun bbb-valid-score (score) + (or (equal grouplens-prediction-display 'prediction-num) + (and (>= score grplens-minrating) + (<= score grplens-maxrating)))) + +(defun bbb-requires-confidence (format-type) + (or (equal format-type 'confidence-plus-minus) + (equal format-type 'confidence-spot) + (equal format-type 'confidence-interval))) + +(defun bbb-have-confidence (clow chigh) + (not (or (null clow) + (null chigh)))) + +(defun bbb-fmt-prediction-spot (rate-string score) + (aset rate-string + (round (* (/ (- score grplens-minrating) grplens-rating-range) + (+ (- grplens-predstringsize 4) 1.49))) + ?*) + rate-string) + +(defun bbb-fmt-confidence-interval (score low high) + (if (bbb-have-confidence low high) + (format "|%4.2f-%4.2f |" low high) + (bbb-fmt-prediction-num score))) + +(defun bbb-fmt-confidence-plus-minus (score low high) + (if (bbb-have-confidence low high) + (format "|%3.1f+/-%4.2f|" score (/ (- high low) 2.0)) + (bbb-fmt-prediction-num score))) + +(defun bbb-fmt-prediction-bar (rate-string score) + (let* ((i 1) + (step (/ grplens-rating-range (- grplens-predstringsize 4))) + (half-step (/ step 2)) + (loc (- grplens-minrating half-step))) + (while (< i (- grplens-predstringsize 2)) + (if (> score loc) + (aset rate-string i ?#) + (aset rate-string i ?\ )) + (setq i (+ i 1)) + (setq loc (+ loc step))) + ) + rate-string) + +(defun bbb-fmt-prediction-num (score) + (format "| %4.2f |" score)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Put Ratings +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun bbb-put-ratings () + (if (and grouplens-bbb-token + grouplens-rating-alist + (member gnus-newsgroup-name grouplens-newsgroups)) + (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host + grouplens-bbb-port)) + (rate-command (bbb-build-rate-command grouplens-rating-alist))) + (if bbb-process + (save-excursion + (set-buffer (process-buffer bbb-process)) + (gnus-message 5 "Sending Ratings...") + (bbb-send-command bbb-process rate-command) + (if (bbb-read-response bbb-process) + (setq grouplens-rating-alist nil) + (gnus-message 1 + "Token timed out: call bbb-login and quit again") + (ding)) + (gnus-message 5 "Sending Ratings...Done")) + (gnus-message 3 "No BBB connection"))) + (setq grouplens-rating-alist nil))) + +(defun bbb-build-rate-command (rate-alist) + (concat "putratings " grouplens-bbb-token " " grouplens-current-group " \r\n" + (mapconcat '(lambda (this) ; form (mid . (score . time)) + (concat (car this) + " :rating=" (cadr this) ".00" + " :time=" (cddr this))) + rate-alist "\r\n") + "\r\n.\r\n")) + +;; Interactive rating functions. +(defun bbb-summary-rate-article (rating &optional midin) + (interactive "nRating: ") + (when (member gnus-newsgroup-name grouplens-newsgroups) + (let ((mid (or midin (bbb-get-current-id)))) + (if (and rating + (>= rating grplens-minrating) + (<= rating grplens-maxrating) + mid) + (let ((oldrating (assoc mid grouplens-rating-alist))) + (if oldrating + (setcdr oldrating (cons rating 0)) + (push `(,mid . (,rating . 0)) grouplens-rating-alist)) + (gnus-summary-mark-article nil (int-to-string rating))) + (gnus-message 3 "Invalid rating"))))) + +(defun grouplens-next-unread-article (rating) + "Select unread article after current one." + (interactive "P") + (when rating + (bbb-summary-rate-article rating)) + (gnus-summary-next-unread-article)) + +(defun grouplens-best-unread-article (rating) + "Select unread article after current one." + (interactive "P") + (when rating + (bbb-summary-rate-article rating)) + (gnus-summary-best-unread-article)) + +(defun grouplens-summary-catchup-and-exit (rating) + "Mark all articles not marked as unread in this newsgroup as read, + then exit. If prefix argument ALL is non-nil, all articles are + marked as read." + (interactive "P") + (when rating + (bbb-summary-rate-article rating)) + (if (numberp rating) + (gnus-summary-catchup-and-exit) + (gnus-summary-catchup-and-exit rating))) + +(defun grouplens-score-thread (score) + "Raise the score of the articles in the current thread with SCORE." + (interactive "nRating: ") + (let (e) + (save-excursion + (let ((articles (gnus-summary-articles-in-thread)) + article) + (while (setq article (pop articles)) + (gnus-summary-goto-subject article) + (gnus-set-global-variables) + (bbb-summary-rate-article score + (mail-header-id + (gnus-summary-article-header article))))) + (setq e (point))) + (let ((gnus-summary-check-current t)) + (or (zerop (gnus-summary-next-subject 1 t)) + (goto-char e)))) + (gnus-summary-recenter) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary)) + +(defun bbb-exit-group () + (bbb-put-ratings) + (bbb-renew-hash-table)) + +(defun bbb-get-current-id () + (if gnus-current-headers + (mail-header-id gnus-current-headers) + (gnus-message 3 "You must select an article before you rate it"))) + +(defun bbb-grouplens-group-p (group) + "Say whether GROUP is a GroupLens group." + (if (member group grouplens-newsgroups) " (GroupLens Enhanced)" "")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TIME SPENT READING +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar grouplens-current-starting-time nil) + +(defun grouplens-start-timer () + (setq grouplens-current-starting-time (current-time))) + +(defun grouplens-elapsed-time () + (let ((et (bbb-time-float (current-time)))) + (- et (bbb-time-float grouplens-current-starting-time)))) + +(defun bbb-time-float (timeval) + (+ (* (car timeval) 65536) + (cadr timeval))) + +(defun grouplens-do-time () + (when (member gnus-newsgroup-name grouplens-newsgroups) + (when grouplens-previous-article + (let ((elapsed-time (grouplens-elapsed-time)) + (oldrating (assoc grouplens-previous-article + grouplens-rating-alist))) + (if (not oldrating) + (push `(,grouplens-previous-article . (0 . ,elapsed-time)) + grouplens-rating-alist) + (setcdr oldrating (cons (cadr oldrating) elapsed-time))))) + (grouplens-start-timer) + (setq grouplens-previous-article (bbb-get-current-id)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BUG REPORTING +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst gnus-gl-version "gnus-gl.el 2.50") +(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu") +(defun gnus-gl-submit-bug-report () + "Submit via mail a bug report on gnus-gl" + (interactive) + (require 'reporter) + (reporter-submit-bug-report gnus-gl-maintainer-address + (concat "gnus-gl.el " gnus-gl-version) + (list 'grouplens-pseudonym + 'grouplens-bbb-host + 'grouplens-bbb-port + 'grouplens-newsgroups + 'grouplens-bbb-token + 'grouplens-bbb-process + 'grouplens-current-group + 'grouplens-previous-article) + nil + 'gnus-gl-get-trace)) + +(defun gnus-gl-get-trace () + "Insert the contents of the BBBD trace buffer" + (when grouplens-bbb-buffer + (insert-buffer grouplens-bbb-buffer))) + +;; +;; GroupLens minor mode +;; + +(defvar gnus-grouplens-mode nil + "Minor mode for providing a GroupLens interface in Gnus summary buffers.") + +(defvar gnus-grouplens-mode-map nil) + +(unless gnus-grouplens-mode-map + (setq gnus-grouplens-mode-map (make-keymap)) + (gnus-define-keys + gnus-grouplens-mode-map + "n" grouplens-next-unread-article + "r" bbb-summary-rate-article + "k" grouplens-score-thread + "c" grouplens-summary-catchup-and-exit + "," grouplens-best-unread-article)) + +(defun gnus-grouplens-make-menu-bar () + (unless (boundp 'gnus-grouplens-menu) + (easy-menu-define + gnus-grouplens-menu gnus-grouplens-mode-map "" + '("GroupLens" + ["Login" bbb-login t] + ["Rate" bbb-summary-rate-article t] + ["Next article" grouplens-next-unread-article t] + ["Best article" grouplens-best-unread-article t] + ["Raise thread" grouplens-score-thread t] + ["Report bugs" gnus-gl-submit-bug-report t])))) + +(defun gnus-grouplens-mode (&optional arg) + "Minor mode for providing a GroupLens interface in Gnus summary buffers." + (interactive "P") + (when (and (eq major-mode 'gnus-summary-mode) + (member gnus-newsgroup-name grouplens-newsgroups)) + (make-local-variable 'gnus-grouplens-mode) + (setq gnus-grouplens-mode + (if (null arg) (not gnus-grouplens-mode) + (> (prefix-numeric-value arg) 0))) + (when gnus-grouplens-mode + (make-local-hook 'gnus-select-article-hook) + (add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local) + (make-local-hook 'gnus-exit-group-hook) + (add-hook 'gnus-exit-group-hook 'bbb-exit-group nil 'local) + (make-local-variable 'gnus-score-find-score-files-function) + + (cond + ((eq gnus-grouplens-override-scoring 'combine) + ;; either add bbb-buld-mid-scores-alist to a list + ;; or make a list + (if (listp gnus-score-find-score-files-function) + (setq gnus-score-find-score-files-function + (append 'bbb-build-mid-scores-alist + gnus-score-find-score-files-function)) + (setq gnus-score-find-score-files-function + (list gnus-score-find-score-files-function + 'bbb-build-mid-scores-alist)))) + ;; leave the gnus-score-find-score-files variable alone + ((eq gnus-grouplens-override-scoring 'separate) + (add-hook 'gnus-select-group-hook + (lambda () + (bbb-get-predictions (bbb-get-all-mids) + gnus-newsgroup-name)))) + ;; default is to override + (t + (setq gnus-score-find-score-files-function + 'bbb-build-mid-scores-alist))) + + ;; Change how summary lines look + (make-local-variable 'gnus-summary-line-format) + (make-local-variable 'gnus-summary-line-format-spec) + (setq gnus-summary-line-format gnus-summary-grouplens-line-format) + (setq gnus-summary-line-format-spec nil) + (gnus-update-format-specifications nil 'summary) + (gnus-update-summary-mark-positions) + + ;; Set up the menu. + (when (and menu-bar-mode + (gnus-visual-p 'grouplens-menu 'menu)) + (gnus-grouplens-make-menu-bar)) + (gnus-add-minor-mode + 'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map) + (run-hooks 'gnus-grouplens-mode-hook)))) + +(provide 'gnus-gl) + +;;; gnus-gl.el ends here diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el new file mode 100644 index 0000000..d63442b --- /dev/null +++ b/lisp/gnus-group.el @@ -0,0 +1,3360 @@ +;;; gnus-group.el --- group mode commands for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-start) +(require 'nnmail) +(require 'gnus-spec) +(require 'gnus-int) +(require 'gnus-range) +(require 'gnus-win) +(require 'gnus-undo) + +(defcustom gnus-group-archive-directory + "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" + "*The address of the (ding) archives." + :group 'gnus-group-foreign + :type 'directory) + +(defcustom gnus-group-recent-archive-directory + "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" + "*The address of the most recent (ding) articles." + :group 'gnus-group-foreign + :type 'directory) + +(defcustom gnus-no-groups-message "No news is no news" + "*Message displayed by Gnus when no groups are available." + :group 'gnus-start + :type 'string) + +(defcustom gnus-keep-same-level nil + "*Non-nil means that the next newsgroup after the current will be on the same level. +When you type, for instance, `n' after reading the last article in the +current newsgroup, you will go to the next newsgroup. If this variable +is nil, the next newsgroup will be the next from the group +buffer. +If this variable is non-nil, Gnus will either put you in the +next newsgroup with the same level, or, if no such newsgroup is +available, the next newsgroup with the lowest possible level higher +than the current level. +If this variable is `best', Gnus will make the next newsgroup the one +with the best level." + :group 'gnus-group-levels + :type '(choice (const nil) + (const best) + (sexp :tag "other" t))) + +(defcustom gnus-group-goto-unread t + "*If non-nil, movement commands will go to the next unread and subscribed group." + :link '(custom-manual "(gnus)Group Maneuvering") + :group 'gnus-group-various + :type 'boolean) + +(defcustom gnus-goto-next-group-when-activating t + "*If non-nil, the \\\\[gnus-group-get-new-news-this-group] command will advance point to the next group." + :link '(custom-manual "(gnus)Scanning New Messages") + :group 'gnus-group-various + :type 'boolean) + +(defcustom gnus-permanently-visible-groups nil + "*Regexp to match groups that should always be listed in the group buffer. +This means that they will still be listed even when there are no +unread articles in the groups. + +If nil, no groups are permanently visible." + :group 'gnus-group-listing + :type '(choice regexp (const nil))) + +(defcustom gnus-list-groups-with-ticked-articles t + "*If non-nil, list groups that have only ticked articles. +If nil, only list groups that have unread articles." + :group 'gnus-group-listing + :type 'boolean) + +(defcustom gnus-group-default-list-level gnus-level-subscribed + "*Default listing level. +Ignored if `gnus-group-use-permanent-levels' is non-nil." + :group 'gnus-group-listing + :type 'integer) + +(defcustom gnus-group-list-inactive-groups t + "*If non-nil, inactive groups will be listed." + :group 'gnus-group-listing + :group 'gnus-group-levels + :type 'boolean) + +(defcustom gnus-group-sort-function 'gnus-group-sort-by-alphabet + "*Function used for sorting the group buffer. +This function will be called with group info entries as the arguments +for the groups to be sorted. Pre-made functions include +`gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name', +`gnus-group-sort-by-unread', `gnus-group-sort-by-level', +`gnus-group-sort-by-score', `gnus-group-sort-by-method', and +`gnus-group-sort-by-rank'. + +This variable can also be a list of sorting functions. In that case, +the most significant sort function should be the last function in the +list." + :group 'gnus-group-listing + :link '(custom-manual "(gnus)Sorting Groups") + :type '(radio (function-item gnus-group-sort-by-alphabet) + (function-item gnus-group-sort-by-real-name) + (function-item gnus-group-sort-by-unread) + (function-item gnus-group-sort-by-level) + (function-item gnus-group-sort-by-score) + (function-item gnus-group-sort-by-method) + (function-item gnus-group-sort-by-rank) + (function :tag "other" nil))) + +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y: %(%g%)%l\n" + "*Format of group lines. +It works along the same lines as a normal formatting string, +with some simple extensions. + +%M Only marked articles (character, \"*\" or \" \") +%S Whether the group is subscribed (character, \"U\", \"K\", \"Z\" or \" \") +%L Level of subscribedness (integer) +%N Number of unread articles (integer) +%I Number of dormant articles (integer) +%i Number of ticked and dormant (integer) +%T Number of ticked articles (integer) +%R Number of read articles (integer) +%t Estimated total number of articles (integer) +%y Number of unread, unticked articles (integer) +%G Group name (string) +%g Qualified group name (string) +%D Group description (string) +%s Select method (string) +%o Moderated group (char, \"m\") +%p Process mark (char) +%O Moderated group (string, \"(m)\" or \"\") +%P Topic indentation (string) +%m Whether there is new(ish) mail in the group (char, \"%\") +%l Whether there are GroupLens predictions for this group (string) +%n Select from where (string) +%z A string that look like `<%s:%n>' if a foreign select method is used +%d The date the group was last entered. +%u User defined specifier. The next character in the format string should + be a letter. Gnus will call the function gnus-user-format-function-X, + where X is the letter following %u. The function will be passed the + current header as argument. The function should return a string, which + will be inserted into the buffer just like information from any other + group specifier. + +Text between %( and %) will be highlighted with `gnus-mouse-face' when +the mouse point move inside the area. There can only be one such area. + +Note that this format specification is not always respected. For +reasons of efficiency, when listing killed groups, this specification +is ignored altogether. If the spec is changed considerably, your +output may end up looking strange when listing both alive and killed +groups. + +If you use %o or %O, reading the active file will be slower and quite +a bit of extra memory will be used. %D will also worsen performance. +Also note that if you change the format specification to include any +of these specs, you must probably re-start Gnus to see them go into +effect." + :group 'gnus-group-visual + :type 'string) + +(defcustom gnus-group-mode-line-format "Gnus: %%b {%M\%:%S}" + "*The format specification for the group mode line. +It works along the same lines as a normal formatting string, +with some simple extensions: + +%S The native news server. +%M The native select method. +%: \":\" if %S isn't \"\"." + :group 'gnus-group-visual + :type 'string) + +(defcustom gnus-group-mode-hook nil + "Hook for Gnus group mode." + :group 'gnus-group-various + :options '(gnus-topic-mode) + :type 'hook) + +(defcustom gnus-group-menu-hook nil + "Hook run after the creation of the group mode menu." + :group 'gnus-group-various + :type 'hook) + +(defcustom gnus-group-catchup-group-hook nil + "Hook run when catching up a group from the group buffer." + :group 'gnus-group-various + :link '(custom-manual "(gnus)Group Data") + :type 'hook) + +(defcustom gnus-group-update-group-hook nil + "Hook called when updating group lines." + :group 'gnus-group-visual + :type 'hook) + +(defcustom gnus-group-prepare-function 'gnus-group-prepare-flat + "*A function that is called to generate the group buffer. +The function is called with three arguments: The first is a number; +all group with a level less or equal to that number should be listed, +if the second is non-nil, empty groups should also be displayed. If +the third is non-nil, it is a number. No groups with a level lower +than this number should be displayed. + +The only current function implemented is `gnus-group-prepare-flat'." + :group 'gnus-group-listing + :type 'function) + +(defcustom gnus-group-prepare-hook nil + "Hook called after the group buffer has been generated. +If you want to modify the group buffer, you can use this hook." + :group 'gnus-group-listing + :type 'hook) + +(defcustom gnus-suspend-gnus-hook nil + "Hook called when suspending (not exiting) Gnus." + :group 'gnus-exit + :type 'hook) + +(defcustom gnus-exit-gnus-hook nil + "Hook called when exiting Gnus." + :group 'gnus-exit + :type 'hook) + +(defcustom gnus-after-exiting-gnus-hook nil + "Hook called after exiting Gnus." + :group 'gnus-exit + :type 'hook) + +(defcustom gnus-group-update-hook '(gnus-group-highlight-line) + "Hook called when a group line is changed. +The hook will not be called if `gnus-visual' is nil. + +The default function `gnus-group-highlight-line' will +highlight the line according to the `gnus-group-highlight' +variable." + :group 'gnus-group-visual + :type 'hook) + +(defcustom gnus-useful-groups + `(("(ding) mailing list mirrored at sunsite.auc.dk" + "emacs.ding" + (nntp "sunsite.auc.dk" + (nntp-address "sunsite.auc.dk"))) + ("Gnus help group" + "gnus-help" + (nndoc "gnus-help" + (nndoc-article-type mbox) + (eval `(nndoc-address + ,(let ((file (nnheader-find-etc-directory + "gnus-tut.txt" t))) + (unless file + (error "Couldn't find doc group")) + file)))))) + "Alist of useful group-server pairs." + :group 'gnus-group-listing + :type '(repeat (list (string :tag "Description") + (string :tag "Name") + (sexp :tag "Method")))) + +(defcustom gnus-group-highlight + '(;; News. + ((and (= unread 0) (not mailp) (eq level 1)) . + gnus-group-news-1-empty-face) + ((and (not mailp) (eq level 1)) . + gnus-group-news-1-face) + ((and (= unread 0) (not mailp) (eq level 2)) . + gnus-group-news-2-empty-face) + ((and (not mailp) (eq level 2)) . + gnus-group-news-2-face) + ((and (= unread 0) (not mailp) (eq level 3)) . + gnus-group-news-3-empty-face) + ((and (not mailp) (eq level 3)) . + gnus-group-news-3-face) + ((and (= unread 0) (not mailp)) . + gnus-group-news-low-empty-face) + ((and (not mailp)) . + gnus-group-news-low-face) + ;; Mail. + ((and (= unread 0) (eq level 1)) . + gnus-group-mail-1-empty-face) + ((eq level 1) . + gnus-group-mail-1-face) + ((and (= unread 0) (eq level 2)) . + gnus-group-mail-2-empty-face) + ((eq level 2) . + gnus-group-mail-2-face) + ((and (= unread 0) (eq level 3)) . + gnus-group-mail-3-empty-face) + ((eq level 3) . + gnus-group-mail-3-face) + ((= unread 0) . + gnus-group-mail-low-empty-face) + (t . + gnus-group-mail-low-face)) + "Controls the highlighting of group buffer lines. + +Below is a list of `Form'/`Face' pairs. When deciding how a a +particular group line should be displayed, each form is +evaluated. The content of the face field after the first true form is +used. You can change how those group lines are displayed by +editing the face field. + +It is also possible to change and add form fields, but currently that +requires an understanding of Lisp expressions. Hopefully this will +change in a future release. For now, you can use the following +variables in the Lisp expression: + +group: The name of the group. +unread: The number of unread articles in the group. +method: The select method used. +mailp: Whether it's a mail group or not. +level: The level of the group. +score: The score of the group. +ticked: The number of ticked articles." + :group 'gnus-group-visual + :type '(repeat (cons (sexp :tag "Form") face))) + +(defcustom gnus-new-mail-mark ?% + "Mark used for groups with new mail." + :group 'gnus-group-visual + :type 'character) + +;;; Internal variables + +(defvar gnus-group-sort-alist-function 'gnus-group-sort-flat + "Function for sorting the group buffer.") + +(defvar gnus-group-sort-selected-function 'gnus-group-sort-selected-flat + "Function for sorting the selected groups in the group buffer.") + +(defvar gnus-group-indentation-function nil) +(defvar gnus-goto-missing-group-function nil) +(defvar gnus-group-update-group-function nil) +(defvar gnus-group-goto-next-group-function nil + "Function to override finding the next group after listing groups.") + +(defvar gnus-group-edit-buffer nil) + +(defvar gnus-group-line-format-alist + `((?M gnus-tmp-marked-mark ?c) + (?S gnus-tmp-subscribed ?c) + (?L gnus-tmp-level ?d) + (?N (cond ((eq number t) "*" ) + ((numberp number) + (int-to-string + (+ number + (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) + (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) + (t number)) ?s) + (?R gnus-tmp-number-of-read ?s) + (?t gnus-tmp-number-total ?d) + (?y gnus-tmp-number-of-unread ?s) + (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) + (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) + (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) + (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) + (?g gnus-tmp-group ?s) + (?G gnus-tmp-qualified-group ?s) + (?c (gnus-short-group-name gnus-tmp-group) ?s) + (?D gnus-tmp-newsgroup-description ?s) + (?o gnus-tmp-moderated ?c) + (?O gnus-tmp-moderated-string ?s) + (?p gnus-tmp-process-marked ?c) + (?s gnus-tmp-news-server ?s) + (?n gnus-tmp-news-method ?s) + (?P gnus-group-indentation ?s) + (?l gnus-tmp-grouplens ?s) + (?z gnus-tmp-news-method-string ?s) + (?m (gnus-group-new-mail gnus-tmp-group) ?c) + (?d (gnus-group-timestamp-string gnus-tmp-group) ?s) + (?u gnus-tmp-user-defined ?s))) + +(defvar gnus-group-mode-line-format-alist + `((?S gnus-tmp-news-server ?s) + (?M gnus-tmp-news-method ?s) + (?u gnus-tmp-user-defined ?s) + (?: gnus-tmp-colon ?s))) + +(defvar gnus-topic-topology nil + "The complete topic hierarchy.") + +(defvar gnus-topic-alist nil + "The complete topic-group alist.") + +(defvar gnus-group-marked nil) + +(defvar gnus-group-list-mode nil) + +;;; +;;; Gnus group mode +;;; + +(put 'gnus-group-mode 'mode-class 'special) + +(when t + (gnus-define-keys gnus-group-mode-map + " " gnus-group-read-group + "=" gnus-group-select-group + "\r" gnus-group-select-group + "\M-\r" gnus-group-quick-select-group + [(meta control return)] gnus-group-select-group-ephemerally + "j" gnus-group-jump-to-group + "n" gnus-group-next-unread-group + "p" gnus-group-prev-unread-group + "\177" gnus-group-prev-unread-group + [delete] gnus-group-prev-unread-group + "N" gnus-group-next-group + "P" gnus-group-prev-group + "\M-n" gnus-group-next-unread-group-same-level + "\M-p" gnus-group-prev-unread-group-same-level + "," gnus-group-best-unread-group + "." gnus-group-first-unread-group + "u" gnus-group-unsubscribe-current-group + "U" gnus-group-unsubscribe-group + "c" gnus-group-catchup-current + "C" gnus-group-catchup-current-all + "\M-c" gnus-group-clear-data + "l" gnus-group-list-groups + "L" gnus-group-list-all-groups + "m" gnus-group-mail + "g" gnus-group-get-new-news + "\M-g" gnus-group-get-new-news-this-group + "R" gnus-group-restart + "r" gnus-group-read-init-file + "B" gnus-group-browse-foreign-server + "b" gnus-group-check-bogus-groups + "F" gnus-group-find-new-groups + "\C-c\C-d" gnus-group-describe-group + "\M-d" gnus-group-describe-all-groups + "\C-c\C-a" gnus-group-apropos + "\C-c\M-\C-a" gnus-group-description-apropos + "a" gnus-group-post-news + "\ek" gnus-group-edit-local-kill + "\eK" gnus-group-edit-global-kill + "\C-k" gnus-group-kill-group + "\C-y" gnus-group-yank-group + "\C-w" gnus-group-kill-region + "\C-x\C-t" gnus-group-transpose-groups + "\C-c\C-l" gnus-group-list-killed + "\C-c\C-x" gnus-group-expire-articles + "\C-c\M-\C-x" gnus-group-expire-all-groups + "V" gnus-version + "s" gnus-group-save-newsrc + "z" gnus-group-suspend + "q" gnus-group-exit + "Q" gnus-group-quit + "?" gnus-group-describe-briefly + "\C-c\C-i" gnus-info-find-node + "\M-e" gnus-group-edit-group-method + "^" gnus-group-enter-server-mode + gnus-mouse-2 gnus-mouse-pick-group + "<" beginning-of-buffer + ">" end-of-buffer + "\C-c\C-b" gnus-bug + "\C-c\C-s" gnus-group-sort-groups + "t" gnus-topic-mode + "\C-c\M-g" gnus-activate-all-groups + "\M-&" gnus-group-universal-argument + "#" gnus-group-mark-group + "\M-#" gnus-group-unmark-group) + + (gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) + "m" gnus-group-mark-group + "u" gnus-group-unmark-group + "w" gnus-group-mark-region + "b" gnus-group-mark-buffer + "r" gnus-group-mark-regexp + "U" gnus-group-unmark-all-groups) + + (gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) + "d" gnus-group-make-directory-group + "h" gnus-group-make-help-group + "u" gnus-group-make-useful-group + "a" gnus-group-make-archive-group + "k" gnus-group-make-kiboze-group + "m" gnus-group-make-group + "E" gnus-group-edit-group + "e" gnus-group-edit-group-method + "p" gnus-group-edit-group-parameters + "v" gnus-group-add-to-virtual + "V" gnus-group-make-empty-virtual + "D" gnus-group-enter-directory + "f" gnus-group-make-doc-group + "w" gnus-group-make-web-group + "r" gnus-group-rename-group + "c" gnus-group-customize + "\177" gnus-group-delete-group + [delete] gnus-group-delete-group) + + (gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map) + "b" gnus-group-brew-soup + "w" gnus-soup-save-areas + "s" gnus-soup-send-replies + "p" gnus-soup-pack-packet + "r" nnsoup-pack-replies) + + (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) + "s" gnus-group-sort-groups + "a" gnus-group-sort-groups-by-alphabet + "u" gnus-group-sort-groups-by-unread + "l" gnus-group-sort-groups-by-level + "v" gnus-group-sort-groups-by-score + "r" gnus-group-sort-groups-by-rank + "m" gnus-group-sort-groups-by-method) + + (gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map) + "s" gnus-group-sort-selected-groups + "a" gnus-group-sort-selected-groups-by-alphabet + "u" gnus-group-sort-selected-groups-by-unread + "l" gnus-group-sort-selected-groups-by-level + "v" gnus-group-sort-selected-groups-by-score + "r" gnus-group-sort-selected-groups-by-rank + "m" gnus-group-sort-selected-groups-by-method) + + (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) + "k" gnus-group-list-killed + "z" gnus-group-list-zombies + "s" gnus-group-list-groups + "u" gnus-group-list-all-groups + "A" gnus-group-list-active + "a" gnus-group-apropos + "d" gnus-group-description-apropos + "m" gnus-group-list-matching + "M" gnus-group-list-all-matching + "l" gnus-group-list-level) + + (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) + "f" gnus-score-flush-cache) + + (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) + "d" gnus-group-describe-group + "f" gnus-group-fetch-faq + "v" gnus-version) + + (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) + "l" gnus-group-set-current-level + "t" gnus-group-unsubscribe-current-group + "s" gnus-group-unsubscribe-group + "k" gnus-group-kill-group + "y" gnus-group-yank-group + "w" gnus-group-kill-region + "\C-k" gnus-group-kill-level + "z" gnus-group-kill-all-zombies)) + +(defun gnus-group-make-menu-bar () + (gnus-turn-off-edit-menu 'group) + (unless (boundp 'gnus-group-reading-menu) + + (easy-menu-define + gnus-group-reading-menu gnus-group-mode-map "" + '("Group" + ["Read" gnus-group-read-group (gnus-group-group-name)] + ["Select" gnus-group-select-group (gnus-group-group-name)] + ["See old articles" (gnus-group-select-group 'all) + :keys "C-u SPC" :active (gnus-group-group-name)] + ["Catch up" gnus-group-catchup-current (gnus-group-group-name)] + ["Catch up all articles" gnus-group-catchup-current-all + (gnus-group-group-name)] + ["Check for new articles" gnus-group-get-new-news-this-group + (gnus-group-group-name)] + ["Toggle subscription" gnus-group-unsubscribe-current-group + (gnus-group-group-name)] + ["Kill" gnus-group-kill-group (gnus-group-group-name)] + ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] + ["Describe" gnus-group-describe-group (gnus-group-group-name)] + ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] + ;; Actually one should check, if any of the marked groups gives t for + ;; (gnus-check-backend-function 'request-expire-articles ...) + ["Expire articles" gnus-group-expire-articles + (or (and (gnus-group-group-name) + (gnus-check-backend-function + 'request-expire-articles + (gnus-group-group-name))) gnus-group-marked)] + ["Set group level" gnus-group-set-current-level + (gnus-group-group-name)] + ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] + ["Customize" gnus-group-customize (gnus-group-group-name)] + ("Edit" + ["Parameters" gnus-group-edit-group-parameters + (gnus-group-group-name)] + ["Select method" gnus-group-edit-group-method + (gnus-group-group-name)] + ["Info" gnus-group-edit-group (gnus-group-group-name)] + ["Local kill file" gnus-group-edit-local-kill (gnus-group-group-name)] + ["Global kill file" gnus-group-edit-global-kill t]))) + + (easy-menu-define + gnus-group-group-menu gnus-group-mode-map "" + '("Groups" + ("Listing" + ["List unread subscribed groups" gnus-group-list-groups t] + ["List (un)subscribed groups" gnus-group-list-all-groups t] + ["List killed groups" gnus-group-list-killed gnus-killed-list] + ["List zombie groups" gnus-group-list-zombies gnus-zombie-list] + ["List level..." gnus-group-list-level t] + ["Describe all groups" gnus-group-describe-all-groups t] + ["Group apropos..." gnus-group-apropos t] + ["Group and description apropos..." gnus-group-description-apropos t] + ["List groups matching..." gnus-group-list-matching t] + ["List all groups matching..." gnus-group-list-all-matching t] + ["List active file" gnus-group-list-active t]) + ("Sort" + ["Default sort" gnus-group-sort-groups t] + ["Sort by method" gnus-group-sort-groups-by-method t] + ["Sort by rank" gnus-group-sort-groups-by-rank t] + ["Sort by score" gnus-group-sort-groups-by-score t] + ["Sort by level" gnus-group-sort-groups-by-level t] + ["Sort by unread" gnus-group-sort-groups-by-unread t] + ["Sort by name" gnus-group-sort-groups-by-alphabet t]) + ("Sort process/prefixed" + ["Default sort" gnus-group-sort-selected-groups + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by method" gnus-group-sort-selected-groups-by-method + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by rank" gnus-group-sort-selected-groups-by-rank + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by score" gnus-group-sort-selected-groups-by-score + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by level" gnus-group-sort-selected-groups-by-level + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by unread" gnus-group-sort-selected-groups-by-unread + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by name" gnus-group-sort-selected-groups-by-alphabet + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) + ("Mark" + ["Mark group" gnus-group-mark-group + (and (gnus-group-group-name) + (not (memq (gnus-group-group-name) gnus-group-marked)))] + ["Unmark group" gnus-group-unmark-group + (and (gnus-group-group-name) + (memq (gnus-group-group-name) gnus-group-marked))] + ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] + ["Mark regexp..." gnus-group-mark-regexp t] + ["Mark region" gnus-group-mark-region t] + ["Mark buffer" gnus-group-mark-buffer t] + ["Execute command" gnus-group-universal-argument + (or gnus-group-marked (gnus-group-group-name))]) + ("Subscribe" + ["Subscribe to a group" gnus-group-unsubscribe-group t] + ["Kill all newsgroups in region" gnus-group-kill-region t] + ["Kill all zombie groups" gnus-group-kill-all-zombies + gnus-zombie-list] + ["Kill all groups on level..." gnus-group-kill-level t]) + ("Foreign groups" + ["Make a foreign group" gnus-group-make-group t] + ["Add a directory group" gnus-group-make-directory-group t] + ["Add the help group" gnus-group-make-help-group t] + ["Add the archive group" gnus-group-make-archive-group t] + ["Make a doc group" gnus-group-make-doc-group t] + ["Make a web group" gnus-group-make-web-group t] + ["Make a kiboze group" gnus-group-make-kiboze-group t] + ["Make a virtual group" gnus-group-make-empty-virtual t] + ["Add a group to a virtual" gnus-group-add-to-virtual t] + ["Rename group" gnus-group-rename-group + (gnus-check-backend-function + 'request-rename-group (gnus-group-group-name))] + ["Delete group" gnus-group-delete-group + (gnus-check-backend-function + 'request-delete-group (gnus-group-group-name))]) + ("Move" + ["Next" gnus-group-next-group t] + ["Previous" gnus-group-prev-group t] + ["Next unread" gnus-group-next-unread-group t] + ["Previous unread" gnus-group-prev-unread-group t] + ["Next unread same level" gnus-group-next-unread-group-same-level t] + ["Previous unread same level" + gnus-group-prev-unread-group-same-level t] + ["Jump to group" gnus-group-jump-to-group t] + ["First unread group" gnus-group-first-unread-group t] + ["Best unread group" gnus-group-best-unread-group t]) + ["Delete bogus groups" gnus-group-check-bogus-groups t] + ["Find new newsgroups" gnus-group-find-new-groups t] + ["Transpose" gnus-group-transpose-groups + (gnus-group-group-name)] + ["Read a directory as a group..." gnus-group-enter-directory t])) + + (easy-menu-define + gnus-group-misc-menu gnus-group-mode-map "" + '("Misc" + ("SOUP" + ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] + ["Send replies" gnus-soup-send-replies + (fboundp 'gnus-soup-pack-packet)] + ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] + ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] + ["Brew SOUP" gnus-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) + ["Send a bug report" gnus-bug t] + ["Send a mail" gnus-group-mail t] + ["Post an article..." gnus-group-post-news t] + ["Check for new news" gnus-group-get-new-news t] + ["Activate all groups" gnus-activate-all-groups t] + ["Restart Gnus" gnus-group-restart t] + ["Read init file" gnus-group-read-init-file t] + ["Browse foreign server" gnus-group-browse-foreign-server t] + ["Enter server buffer" gnus-group-enter-server-mode t] + ["Expire all expirable articles" gnus-group-expire-all-groups t] + ["Generate any kiboze groups" nnkiboze-generate-groups t] + ["Gnus version" gnus-version t] + ["Save .newsrc files" gnus-group-save-newsrc t] + ["Suspend Gnus" gnus-group-suspend t] + ["Clear dribble buffer" gnus-group-clear-dribble t] + ["Read manual" gnus-info-find-node t] + ["Flush score cache" gnus-score-flush-cache t] + ["Toggle topics" gnus-topic-mode t] + ["Exit from Gnus" gnus-group-exit t] + ["Exit without saving" gnus-group-quit t])) + + (run-hooks 'gnus-group-menu-hook))) + +(defun gnus-group-mode () + "Major mode for reading news. + +All normal editing commands are switched off. +\\ +The group buffer lists (some of) the groups available. For instance, +`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]' +lists all zombie groups. + +Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe +to a group not displayed, type `\\[gnus-group-unsubscribe-group]'. + +For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-group-mode-map}" + (interactive) + (when (gnus-visual-p 'group-menu 'menu) + (gnus-group-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-group-mode) + (setq mode-name "Group") + (gnus-group-set-mode-line) + (setq mode-line-process nil) + (use-local-map gnus-group-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (setq buffer-read-only t) + (gnus-set-default-directory) + (gnus-update-format-specifications nil 'group 'group-mode) + (gnus-update-group-mark-positions) + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) + (when gnus-use-undo + (gnus-undo-mode 1)) + (run-hooks 'gnus-group-mode-hook)) + +(defun gnus-update-group-mark-positions () + (save-excursion + (let ((gnus-process-mark 128) + (gnus-group-marked '("dummy.group")) + (gnus-active-hashtb (make-vector 10 0))) + (gnus-set-active "dummy.group" '(0 . 0)) + (gnus-set-work-buffer) + (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) + (goto-char (point-min)) + (setq gnus-group-mark-positions + (list (cons 'process (and (search-forward "\200" nil t) + (- (point) 2)))))))) + +(defun gnus-clear-inboxes-moved () + (setq nnmail-moved-inboxes nil)) + +(defun gnus-mouse-pick-group (e) + "Enter the group under the mouse pointer." + (interactive "e") + (mouse-set-point e) + (gnus-group-read-group nil)) + +;; Look at LEVEL and find out what the level is really supposed to be. +;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens +;; will depend on whether `gnus-group-use-permanent-levels' is used. +(defun gnus-group-default-level (&optional level number-or-nil) + (cond + (gnus-group-use-permanent-levels + (or (setq gnus-group-use-permanent-levels + (or level (if (numberp gnus-group-use-permanent-levels) + gnus-group-use-permanent-levels + (or gnus-group-default-list-level + gnus-level-subscribed)))) + gnus-group-default-list-level gnus-level-subscribed)) + (number-or-nil + level) + (t + (or level gnus-group-default-list-level gnus-level-subscribed)))) + +(defun gnus-group-setup-buffer () + (switch-to-buffer (get-buffer-create gnus-group-buffer)) + (unless (eq major-mode 'gnus-group-mode) + (gnus-add-current-to-buffer-list) + (gnus-group-mode) + (when gnus-carpal + (gnus-carpal-setup-buffer 'group)))) + +(defun gnus-group-list-groups (&optional level unread lowest) + "List newsgroups with level LEVEL or lower that have unread articles. +Default is all subscribed groups. +If argument UNREAD is non-nil, groups with no unread articles are also +listed. + +Also see the `gnus-group-use-permanent-levels' variable." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (or + (gnus-group-default-level nil t) + gnus-group-default-list-level + gnus-level-subscribed)))) + ;; Just do this here, for no particular good reason. + (gnus-clear-inboxes-moved) + (unless level + (setq level (car gnus-group-list-mode) + unread (cdr gnus-group-list-mode))) + (setq level (gnus-group-default-level level)) + (gnus-group-setup-buffer) + (gnus-update-format-specifications nil 'group 'group-mode) + (let ((case-fold-search nil) + (props (text-properties-at (gnus-point-at-bol))) + (empty (= (point-min) (point-max))) + (group (gnus-group-group-name)) + number) + (set-buffer gnus-group-buffer) + (setq number (funcall gnus-group-prepare-function level unread lowest)) + (when (or (and (numberp number) + (zerop number)) + (zerop (buffer-size))) + ;; No groups in the buffer. + (gnus-message 5 gnus-no-groups-message)) + ;; We have some groups displayed. + (goto-char (point-max)) + (when (or (not gnus-group-goto-next-group-function) + (not (funcall gnus-group-goto-next-group-function + group props))) + (cond + (empty + (goto-char (point-min))) + ((not group) + ;; Go to the first group with unread articles. + (gnus-group-search-forward t)) + (t + ;; Find the right group to put point on. If the current group + ;; has disappeared in the new listing, try to find the next + ;; one. If no next one can be found, just leave point at the + ;; first newsgroup in the buffer. + (when (not (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe + group gnus-active-hashtb)))) + (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb)))) + (while (and newsrc + (not (gnus-goto-char + (text-property-any + (point-min) (point-max) 'gnus-group + (gnus-intern-safe + (caar newsrc) gnus-active-hashtb))))) + (setq newsrc (cdr newsrc))) + (unless newsrc + (goto-char (point-max)) + (forward-line -1))))))) + ;; Adjust cursor point. + (gnus-group-position-point))) + +(defun gnus-group-list-level (level &optional all) + "List groups on LEVEL. +If ALL (the prefix), also list groups that have no unread articles." + (interactive "nList groups on level: \nP") + (gnus-group-list-groups level all level)) + +(defun gnus-group-prepare-flat (level &optional all lowest regexp) + "List all newsgroups with unread articles of level LEVEL or lower. +If ALL is non-nil, list groups that have no unread articles. +If LOWEST is non-nil, list all newsgroups of level LOWEST or higher. +If REGEXP, only list groups matching REGEXP." + (set-buffer gnus-group-buffer) + (let ((buffer-read-only nil) + (newsrc (cdr gnus-newsrc-alist)) + (lowest (or lowest 1)) + info clevel unread group params) + (erase-buffer) + (when (< lowest gnus-level-zombie) + ;; List living groups. + (while newsrc + (setq info (car newsrc) + group (gnus-info-group info) + params (gnus-info-params info) + newsrc (cdr newsrc) + unread (car (gnus-gethash group gnus-newsrc-hashtb))) + (and unread ; This group might be bogus + (or (not regexp) + (string-match regexp group)) + (<= (setq clevel (gnus-info-level info)) level) + (>= clevel lowest) + (or all ; We list all groups? + (if (eq unread t) ; Unactivated? + gnus-group-list-inactive-groups ; We list unactivated + (> unread 0)) ; We list groups with unread articles + (and gnus-list-groups-with-ticked-articles + (cdr (assq 'tick (gnus-info-marks info)))) + ; And groups with tickeds + ;; Check for permanent visibility. + (and gnus-permanently-visible-groups + (string-match gnus-permanently-visible-groups + group)) + (memq 'visible params) + (cdr (assq 'visible params))) + (gnus-group-insert-group-line + group (gnus-info-level info) + (gnus-info-marks info) unread (gnus-info-method info))))) + + ;; List dead groups. + (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie) + (gnus-group-prepare-flat-list-dead + (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) + gnus-level-zombie ?Z + regexp)) + (and (>= level gnus-level-killed) (<= lowest gnus-level-killed) + (gnus-group-prepare-flat-list-dead + (setq gnus-killed-list (sort gnus-killed-list 'string<)) + gnus-level-killed ?K regexp)) + + (gnus-group-set-mode-line) + (setq gnus-group-list-mode (cons level all)) + (run-hooks 'gnus-group-prepare-hook) + t)) + +(defun gnus-group-prepare-flat-list-dead (groups level mark regexp) + ;; List zombies and killed lists somewhat faster, which was + ;; suggested by Jack Vinson . It does + ;; this by ignoring the group format specification altogether. + (let (group) + (if regexp + ;; This loop is used when listing groups that match some + ;; regexp. + (while groups + (setq group (pop groups)) + (when (string-match regexp group) + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " group "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level level)))) + ;; This loop is used when listing all groups. + (while groups + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " + (setq group (pop groups)) "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level level)))))) + +(defun gnus-group-update-group-line () + "Update the current line in the group buffer." + (let* ((buffer-read-only nil) + (group (gnus-group-group-name)) + (entry (and group (gnus-gethash group gnus-newsrc-hashtb))) + gnus-group-indentation) + (when group + (and entry + (not (gnus-ephemeral-group-p group)) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (nth 2 entry)) + ")"))) + (setq gnus-group-indentation (gnus-group-group-indentation)) + (gnus-delete-line) + (gnus-group-insert-group-line-info group) + (forward-line -1) + (gnus-group-position-point)))) + +(defun gnus-group-insert-group-line-info (group) + "Insert GROUP on the current line." + (let ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-indentation (gnus-group-group-indentation)) + active info) + (if entry + (progn + ;; (Un)subscribed group. + (setq info (nth 2 entry)) + (gnus-group-insert-group-line + group (gnus-info-level info) (gnus-info-marks info) + (or (car entry) t) (gnus-info-method info))) + ;; This group is dead. + (gnus-group-insert-group-line + group + (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed) + nil + (if (setq active (gnus-active group)) + (if (zerop (cdr active)) + 0 + (- (1+ (cdr active)) (car active))) + nil) + nil)))) + +(defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level + gnus-tmp-marked number + gnus-tmp-method) + "Insert a group line in the group buffer." + (let* ((gnus-tmp-active (gnus-active gnus-tmp-group)) + (gnus-tmp-number-total + (if gnus-tmp-active + (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active))) + 0)) + (gnus-tmp-number-of-unread + (if (numberp number) (int-to-string (max 0 number)) + "*")) + (gnus-tmp-number-of-read + (if (numberp number) + (int-to-string (max 0 (- gnus-tmp-number-total number))) + "*")) + (gnus-tmp-subscribed + (cond ((<= gnus-tmp-level gnus-level-subscribed) ? ) + ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) + ((= gnus-tmp-level gnus-level-zombie) ?Z) + (t ?K))) + (gnus-tmp-qualified-group (gnus-group-real-name gnus-tmp-group)) + (gnus-tmp-newsgroup-description + (if gnus-description-hashtb + (or (gnus-gethash gnus-tmp-group gnus-description-hashtb) "") + "")) + (gnus-tmp-moderated + (if (and gnus-moderated-hashtb + (gnus-gethash gnus-tmp-group gnus-moderated-hashtb)) + ?m ? )) + (gnus-tmp-moderated-string + (if (eq gnus-tmp-moderated ?m) "(m)" "")) + (gnus-tmp-method + (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) ; + (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) + (gnus-tmp-news-method (or (car gnus-tmp-method) "")) + (gnus-tmp-news-method-string + (if gnus-tmp-method + (format "(%s:%s)" (car gnus-tmp-method) + (cadr gnus-tmp-method)) "")) + (gnus-tmp-marked-mark + (if (and (numberp number) + (zerop number) + (cdr (assq 'tick gnus-tmp-marked))) + ?* ? )) + (gnus-tmp-process-marked + (if (member gnus-tmp-group gnus-group-marked) + gnus-process-mark ? )) + (gnus-tmp-grouplens + (or (and gnus-use-grouplens + (bbb-grouplens-group-p gnus-tmp-group)) + "")) + (buffer-read-only nil) + header gnus-tmp-header) ; passed as parameter to user-funcs. + (beginning-of-line) + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + ;; Insert the text. + (eval gnus-group-line-format-spec)) + `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) + gnus-unread ,(if (numberp number) + (string-to-int gnus-tmp-number-of-unread) + t) + gnus-marked ,gnus-tmp-marked-mark + gnus-indentation ,gnus-group-indentation + gnus-level ,gnus-tmp-level)) + (when (inline (gnus-visual-p 'group-highlight 'highlight)) + (forward-line -1) + (run-hooks 'gnus-group-update-hook) + (forward-line)) + ;; Allow XEmacs to remove front-sticky text properties. + (gnus-group-remove-excess-properties))) + +(defun gnus-group-highlight-line () + "Highlight the current line according to `gnus-group-highlight'." + (let* ((list gnus-group-highlight) + (p (point)) + (end (progn (end-of-line) (point))) + ;; now find out where the line starts and leave point there. + (beg (progn (beginning-of-line) (point))) + (group (gnus-group-group-name)) + (entry (gnus-group-entry group)) + (unread (if (numberp (car entry)) (car entry) 0)) + (active (gnus-active group)) + (total (if active (1+ (- (cdr active) (car active))) 0)) + (info (nth 2 entry)) + (method (gnus-server-get-method group (gnus-info-method info))) + (marked (gnus-info-marks info)) + (mailp (memq 'mail (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + (level (or (gnus-info-level info) 9)) + (score (or (gnus-info-score info) 0)) + (ticked (gnus-range-length (cdr (assq 'tick marked)))) + (group-age (gnus-group-timestamp-delta group)) + (inhibit-read-only t)) + ;; Eval the cars of the lists until we find a match. + (while (and list + (not (eval (caar list)))) + (setq list (cdr list))) + (let ((face (cdar list))) + (unless (eq face (get-text-property beg 'face)) + (gnus-put-text-property + beg end 'face + (setq face (if (boundp face) (symbol-value face) face))) + (gnus-extent-start-open beg))) + (goto-char p))) + +(defun gnus-group-update-group (group &optional visible-only) + "Update all lines where GROUP appear. +If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't +already." + ;; Can't use `save-excursion' here, so we do it manually. + (let ((buf (current-buffer)) + mark) + (set-buffer gnus-group-buffer) + (setq mark (point-marker)) + ;; The buffer may be narrowed. + (save-restriction + (widen) + (let ((ident (gnus-intern-safe group gnus-active-hashtb)) + (loc (point-min)) + found buffer-read-only) + ;; Enter the current status into the dribble buffer. + (let ((entry (gnus-gethash group gnus-newsrc-hashtb))) + (when (and entry (not (gnus-ephemeral-group-p group))) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (nth 2 entry)) + ")")))) + ;; Find all group instances. If topics are in use, each group + ;; may be listed in more than once. + (while (setq loc (text-property-any + loc (point-max) 'gnus-group ident)) + (setq found t) + (goto-char loc) + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-delete-line) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (run-hooks 'gnus-group-update-group-hook))) + (setq loc (1+ loc))) + (unless (or found visible-only) + ;; No such line in the buffer, find out where it's supposed to + ;; go, and insert it there (or at the end of the buffer). + (if gnus-goto-missing-group-function + (funcall gnus-goto-missing-group-function group) + (let ((entry (cddr (gnus-gethash group gnus-newsrc-hashtb)))) + (while (and entry (car entry) + (not + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe + (caar entry) gnus-active-hashtb))))) + (setq entry (cdr entry))) + (or entry (goto-char (point-max))))) + ;; Finally insert the line. + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (run-hooks 'gnus-group-update-group-hook)))) + (when gnus-group-update-group-function + (funcall gnus-group-update-group-function group)) + (gnus-group-set-mode-line))) + (goto-char mark) + (set-marker mark nil) + (set-buffer buf))) + +(defun gnus-group-set-mode-line () + "Update the mode line in the group buffer." + (when (memq 'group gnus-updated-mode-lines) + ;; Yes, we want to keep this mode line updated. + (save-excursion + (set-buffer gnus-group-buffer) + (let* ((gformat (or gnus-group-mode-line-format-spec + (gnus-set-format 'group-mode))) + (gnus-tmp-news-server (cadr gnus-select-method)) + (gnus-tmp-news-method (car gnus-select-method)) + (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":")) + (max-len 60) + gnus-tmp-header ;Dummy binding for user-defined formats + ;; Get the resulting string. + (modified + (and gnus-dribble-buffer + (buffer-name gnus-dribble-buffer) + (buffer-modified-p gnus-dribble-buffer) + (save-excursion + (set-buffer gnus-dribble-buffer) + (not (zerop (buffer-size)))))) + (mode-string (eval gformat))) + ;; Say whether the dribble buffer has been modified. + (setq mode-line-modified + (if modified (car gnus-mode-line-modified) + (cdr gnus-mode-line-modified))) + ;; If the line is too long, we chop it off. + (when (> (length mode-string) max-len) + (setq mode-string (substring mode-string 0 (- max-len 4)))) + (prog1 + (setq mode-line-buffer-identification + (gnus-mode-line-buffer-identification + (list mode-string))) + (set-buffer-modified-p modified)))))) + +(defun gnus-group-group-name () + "Get the name of the newsgroup on the current line." + (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group))) + (and group (symbol-name group)))) + +(defun gnus-group-group-level () + "Get the level of the newsgroup on the current line." + (get-text-property (gnus-point-at-bol) 'gnus-level)) + +(defun gnus-group-group-indentation () + "Get the indentation of the newsgroup on the current line." + (or (get-text-property (gnus-point-at-bol) 'gnus-indentation) + (and gnus-group-indentation-function + (funcall gnus-group-indentation-function)) + "")) + +(defun gnus-group-group-unread () + "Get the number of unread articles of the newsgroup on the current line." + (get-text-property (gnus-point-at-bol) 'gnus-unread)) + +(defun gnus-group-new-mail (group) + (if (nnmail-new-mail-p (gnus-group-real-name group)) + gnus-new-mail-mark + ? )) + +(defun gnus-group-level (group) + "Return the estimated level of GROUP." + (or (gnus-info-level (gnus-get-info group)) + (and (member group gnus-zombie-list) 8) + 9)) + +(defun gnus-group-search-forward (&optional backward all level first-too) + "Find the next newsgroup with unread articles. +If BACKWARD is non-nil, find the previous newsgroup instead. +If ALL is non-nil, just find any newsgroup. +If LEVEL is non-nil, find group with level LEVEL, or higher if no such +group exists. +If FIRST-TOO, the current line is also eligible as a target." + (let ((way (if backward -1 1)) + (low gnus-level-killed) + (beg (point)) + pos found lev) + (if (and backward (progn (beginning-of-line)) (bobp)) + nil + (unless first-too + (forward-line way)) + (while (and + (not (eobp)) + (not (setq + found + (and + (get-text-property (point) 'gnus-group) + (or all + (and + (let ((unread + (get-text-property (point) 'gnus-unread))) + (and (numberp unread) (> unread 0))) + (setq lev (get-text-property (point) + 'gnus-level)) + (<= lev gnus-level-subscribed))) + (or (not level) + (and (setq lev (get-text-property (point) + 'gnus-level)) + (or (= lev level) + (and (< lev low) + (< level lev) + (progn + (setq low lev) + (setq pos (point)) + nil)))))))) + (zerop (forward-line way))))) + (if found + (progn (gnus-group-position-point) t) + (goto-char (or pos beg)) + (and pos t)))) + +;;; Gnus group mode commands + +;; Group marking. + +(defun gnus-group-mark-group (n &optional unmark no-advance) + "Mark the current group." + (interactive "p") + (let ((buffer-read-only nil) + group) + (while (and (> n 0) + (not (eobp))) + (when (setq group (gnus-group-group-name)) + ;; Go to the mark position. + (beginning-of-line) + (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) + (subst-char-in-region + (point) (1+ (point)) (following-char) + (if unmark + (progn + (setq gnus-group-marked (delete group gnus-group-marked)) + ? ) + (setq gnus-group-marked + (cons group (delete group gnus-group-marked))) + gnus-process-mark))) + (unless no-advance + (gnus-group-next-group 1)) + (decf n)) + (gnus-summary-position-point) + n)) + +(defun gnus-group-unmark-group (n) + "Remove the mark from the current group." + (interactive "p") + (gnus-group-mark-group n 'unmark) + (gnus-group-position-point)) + +(defun gnus-group-unmark-all-groups () + "Unmark all groups." + (interactive) + (let ((groups gnus-group-marked)) + (save-excursion + (while groups + (gnus-group-remove-mark (pop groups))))) + (gnus-group-position-point)) + +(defun gnus-group-mark-region (unmark beg end) + "Mark all groups between point and mark. +If UNMARK, remove the mark instead." + (interactive "P\nr") + (let ((num (count-lines beg end))) + (save-excursion + (goto-char beg) + (- num (gnus-group-mark-group num unmark))))) + +(defun gnus-group-mark-buffer (&optional unmark) + "Mark all groups in the buffer. +If UNMARK, remove the mark instead." + (interactive "P") + (gnus-group-mark-region unmark (point-min) (point-max))) + +(defun gnus-group-mark-regexp (regexp) + "Mark all groups that match some regexp." + (interactive "sMark (regexp): ") + (let ((alist (cdr gnus-newsrc-alist)) + group) + (while alist + (when (string-match regexp (setq group (gnus-info-group (pop alist)))) + (gnus-group-set-mark group)))) + (gnus-group-position-point)) + +(defun gnus-group-remove-mark (group) + "Remove the process mark from GROUP and move point there. +Return nil if the group isn't displayed." + (if (gnus-group-goto-group group) + (save-excursion + (gnus-group-mark-group 1 'unmark t) + t) + (setq gnus-group-marked + (delete group gnus-group-marked)) + nil)) + +(defun gnus-group-set-mark (group) + "Set the process mark on GROUP." + (if (gnus-group-goto-group group) + (save-excursion + (gnus-group-mark-group 1 nil t)) + (setq gnus-group-marked (cons group (delete group gnus-group-marked))))) + +(defun gnus-group-universal-argument (arg &optional groups func) + "Perform any command on all groups according to the process/prefix convention." + (interactive "P") + (if (eq (setq func (or func + (key-binding + (read-key-sequence + (substitute-command-keys + "\\\\[gnus-group-universal-argument]"))))) + 'undefined) + (gnus-error 1 "Undefined key") + (gnus-group-iterate arg + (lambda (group) + (command-execute func)))) + (gnus-group-position-point)) + +(defun gnus-group-process-prefix (n) + "Return a list of groups to work on. +Take into consideration N (the prefix) and the list of marked groups." + (cond + (n + (setq n (prefix-numeric-value n)) + ;; There is a prefix, so we return a list of the N next + ;; groups. + (let ((way (if (< n 0) -1 1)) + (n (abs n)) + group groups) + (save-excursion + (while (and (> n 0) + (setq group (gnus-group-group-name))) + (push group groups) + (setq n (1- n)) + (gnus-group-next-group way))) + (nreverse groups))) + ((gnus-region-active-p) + ;; Work on the region between point and mark. + (let ((max (max (point) (mark))) + groups) + (save-excursion + (goto-char (min (point) (mark))) + (while + (and + (push (gnus-group-group-name) groups) + (zerop (gnus-group-next-group 1)) + (< (point) max))) + (nreverse groups)))) + (gnus-group-marked + ;; No prefix, but a list of marked articles. + (reverse gnus-group-marked)) + (t + ;; Neither marked articles or a prefix, so we return the + ;; current group. + (let ((group (gnus-group-group-name))) + (and group (list group)))))) + +(eval-and-compile + (let ((function (make-symbol "gnus-group-iterate-function")) + (window (make-symbol "gnus-group-iterate-window")) + (groups (make-symbol "gnus-group-iterate-groups")) + (group (make-symbol "gnus-group-iterate-group"))) + (eval + `(defun gnus-group-iterate (arg ,function) + "Iterate FUNCTION over all process/prefixed groups. +FUNCTION will be called with the group name as the paremeter +and with point over the group in question." + (let ((,groups (gnus-group-process-prefix arg)) + (,window (selected-window)) + ,group) + (while (setq ,group (pop ,groups)) + (select-window ,window) + (gnus-group-remove-mark ,group) + (save-selected-window + (save-excursion + (funcall ,function ,group))))))))) + +(put 'gnus-group-iterate 'lisp-indent-function 1) + +;; Selecting groups. + +(defun gnus-group-read-group (&optional all no-article group) + "Read news in this newsgroup. +If the prefix argument ALL is non-nil, already read articles become +readable. IF ALL is a number, fetch this number of articles. If the +optional argument NO-ARTICLE is non-nil, no article will be +auto-selected upon group entry. If GROUP is non-nil, fetch that +group." + (interactive "P") + (let ((no-display (eq all 0)) + (group (or group (gnus-group-group-name))) + number active marked entry) + (when (eq all 0) + (setq all nil)) + (unless group + (error "No group on current line")) + (setq marked (gnus-info-marks + (nth 2 (setq entry (gnus-gethash + group gnus-newsrc-hashtb))))) + ;; This group might be a dead group. In that case we have to get + ;; the number of unread articles from `gnus-active-hashtb'. + (setq number + (cond ((numberp all) all) + (entry (car entry)) + ((setq active (gnus-active group)) + (- (1+ (cdr active)) (car active))))) + (gnus-summary-read-group + group (or all (and (numberp number) + (zerop (+ number (gnus-range-length + (cdr (assq 'tick marked))) + (gnus-range-length + (cdr (assq 'dormant marked))))))) + no-article nil no-display))) + +(defun gnus-group-select-group (&optional all) + "Select this newsgroup. +No article is selected automatically. +If ALL is non-nil, already read articles become readable. +If ALL is a number, fetch this number of articles." + (interactive "P") + (gnus-group-read-group all t)) + +(defun gnus-group-quick-select-group (&optional all) + "Select the current group \"quickly\". +This means that no highlighting or scoring will be performed. +If ALL (the prefix argument) is 0, don't even generate the summary +buffer. + +This might be useful if you want to toggle threading +before entering the group." + (interactive "P") + (require 'gnus-score) + (let (gnus-visual + gnus-score-find-score-files-function + gnus-home-score-file + gnus-apply-kill-hook + gnus-summary-expunge-below) + (gnus-group-read-group all t))) + +(defun gnus-group-visible-select-group (&optional all) + "Select the current group without hiding any articles." + (interactive "P") + (let ((gnus-inhibit-limiting t)) + (gnus-group-read-group all t))) + +(defun gnus-group-select-group-ephemerally () + "Select the current group without doing any processing whatsoever. +You will actually be entered into a group that's a copy of +the current group; no changes you make while in this group will +be permanent." + (interactive) + (require 'gnus-score) + (let* (gnus-visual + gnus-score-find-score-files-function gnus-apply-kill-hook + gnus-summary-expunge-below gnus-show-threads gnus-suppress-duplicates + gnus-summary-mode-hook gnus-select-group-hook + (group (gnus-group-group-name)) + (method (gnus-find-method-for-group group))) + (setq method + `(,(car method) ,(concat (cadr method) "-ephemeral") + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method))) + (gnus-group-read-ephemeral-group + (gnus-group-prefixed-name group method) method))) + +;;;###autoload +(defun gnus-fetch-group (group) + "Start Gnus if necessary and enter GROUP. +Returns whether the fetching was successful or not." + (interactive "sGroup name: ") + (unless (get-buffer gnus-group-buffer) + (gnus)) + (gnus-group-read-group nil nil group)) + +(defvar gnus-ephemeral-group-server 0) + +;; Enter a group that is not in the group buffer. Non-nil is returned +;; if selection was successful. +(defun gnus-group-read-ephemeral-group (group method &optional activate + quit-config request-only) + "Read GROUP from METHOD as an ephemeral group. +If ACTIVATE, request the group first. +If QUIT-CONFIG, use that window configuration when exiting from the +ephemeral group. +If REQUEST-ONLY, don't actually read the group; just request it. + +Return the name of the group is selection was successful." + ;; Transform the select method into a unique server. + (let ((saddr (intern (format "%s-address" (car method))))) + (setq method (gnus-copy-sequence method)) + (require (car method)) + (when (boundp saddr) + (unless (assq saddr method) + (nconc method `((,saddr ,(cadr method)))) + (setf (cadr method) (format "%s-%d" (cadr method) + (incf gnus-ephemeral-group-server)))))) + (let ((group (if (gnus-group-foreign-p group) group + (gnus-group-prefixed-name group method)))) + (gnus-sethash + group + `(-1 nil (,group + ,gnus-level-default-subscribed nil nil ,method + ((quit-config . + ,(if quit-config quit-config + (cons gnus-summary-buffer + gnus-current-window-configuration)))))) + gnus-newsrc-hashtb) + (set-buffer gnus-group-buffer) + (unless (gnus-check-server method) + (error "Unable to contact server: %s" (gnus-status-message method))) + (when activate + (gnus-activate-group group 'scan) + (unless (gnus-request-group group) + (error "Couldn't request group: %s" + (nnheader-get-report (car method))))) + (if request-only + group + (condition-case () + (when (gnus-group-read-group t t group) + group) + ;;(error nil) + (quit nil))))) + +(defun gnus-group-jump-to-group (group) + "Jump to newsgroup GROUP." + (interactive + (list (completing-read + "Group: " gnus-active-hashtb nil + (gnus-read-active-file-p) + nil + 'gnus-group-history))) + + (when (equal group "") + (error "Empty group name")) + + (unless (gnus-ephemeral-group-p group) + ;; Either go to the line in the group buffer... + (unless (gnus-group-goto-group group) + ;; ... or insert the line. + (gnus-group-update-group group) + (gnus-group-goto-group group))) + ;; Adjust cursor point. + (gnus-group-position-point)) + +(defun gnus-group-goto-group (group &optional far) + "Goto to newsgroup GROUP. +If FAR, it is likely that the group is not on the current line." + (when group + (if far + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) + (beginning-of-line) + (cond + ;; It's quite likely that we are on the right line, so + ;; we check the current line first. + ((eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb)) + (point)) + ;; Previous and next line are also likely, so we check them as well. + ((save-excursion + (forward-line -1) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb))) + (forward-line -1) + (point)) + ((save-excursion + (forward-line 1) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb))) + (forward-line 1) + (point)) + (t + ;; Search through the entire buffer. + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))) + +(defun gnus-group-next-group (n &optional silent) + "Go to next N'th newsgroup. +If N is negative, search backward instead. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group n t nil silent)) + +(defun gnus-group-next-unread-group (n &optional all level silent) + "Go to next N'th unread newsgroup. +If N is negative, search backward instead. +If ALL is non-nil, choose any newsgroup, unread or not. +If LEVEL is non-nil, choose the next group with level LEVEL, or, if no +such group can be found, the next group with a level higher than +LEVEL. +Returns the difference between N and the number of skips actually +made." + (interactive "p") + (let ((backward (< n 0)) + (n (abs n))) + (while (and (> n 0) + (gnus-group-search-forward + backward (or (not gnus-group-goto-unread) all) level)) + (setq n (1- n))) + (when (and (/= 0 n) + (not silent)) + (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread") + (if level " on this level or higher" ""))) + n)) + +(defun gnus-group-prev-group (n) + "Go to previous N'th newsgroup. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group (- n) t)) + +(defun gnus-group-prev-unread-group (n) + "Go to previous N'th unread newsgroup. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group (- n))) + +(defun gnus-group-next-unread-group-same-level (n) + "Go to next N'th unread newsgroup on the same level. +If N is negative, search backward instead. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group n t (gnus-group-group-level)) + (gnus-group-position-point)) + +(defun gnus-group-prev-unread-group-same-level (n) + "Go to next N'th unread newsgroup on the same level. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group (- n) t (gnus-group-group-level)) + (gnus-group-position-point)) + +(defun gnus-group-best-unread-group (&optional exclude-group) + "Go to the group with the highest level. +If EXCLUDE-GROUP, do not go to that group." + (interactive) + (goto-char (point-min)) + (let ((best 100000) + unread best-point) + (while (not (eobp)) + (setq unread (get-text-property (point) 'gnus-unread)) + (when (and (numberp unread) (> unread 0)) + (when (and (get-text-property (point) 'gnus-level) + (< (get-text-property (point) 'gnus-level) best) + (or (not exclude-group) + (not (equal exclude-group (gnus-group-group-name))))) + (setq best (get-text-property (point) 'gnus-level)) + (setq best-point (point)))) + (forward-line 1)) + (when best-point + (goto-char best-point)) + (gnus-summary-position-point) + (and best-point (gnus-group-group-name)))) + +(defun gnus-group-first-unread-group () + "Go to the first group with unread articles." + (interactive) + (prog1 + (let ((opoint (point)) + unread) + (goto-char (point-min)) + (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active. + (and (numberp unread) ; Not a topic. + (not (zerop unread))) ; Has unread articles. + (zerop (gnus-group-next-unread-group 1))) ; Next unread group. + (point) ; Success. + (goto-char opoint) + nil)) ; Not success. + (gnus-group-position-point))) + +(defun gnus-group-enter-server-mode () + "Jump to the server buffer." + (interactive) + (gnus-enter-server-buffer)) + +(defun gnus-group-make-group (name &optional method address args) + "Add a new newsgroup. +The user will be prompted for a NAME, for a select METHOD, and an +ADDRESS." + (interactive + (list + (gnus-read-group "Group name: ") + (gnus-read-method "From method: "))) + + (let* ((meth (when (and method + (not (gnus-server-equal method gnus-select-method))) + (if address (list (intern method) address) + method))) + (nname (if method (gnus-group-prefixed-name name meth) name)) + backend info) + (when (gnus-gethash nname gnus-newsrc-hashtb) + (error "Group %s already exists" nname)) + ;; Subscribe to the new group. + (gnus-group-change-level + (setq info (list t nname gnus-level-default-subscribed nil nil meth)) + gnus-level-default-subscribed gnus-level-killed + (and (gnus-group-group-name) + (gnus-gethash (gnus-group-group-name) + gnus-newsrc-hashtb)) + t) + ;; Make it active. + (gnus-set-active nname (cons 1 0)) + (unless (gnus-ephemeral-group-p name) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (cdr info)) ")"))) + ;; Insert the line. + (gnus-group-insert-group-line-info nname) + (forward-line -1) + (gnus-group-position-point) + + ;; Load the backend and try to make the backend create + ;; the group as well. + (when (assoc (symbol-name (setq backend (car (gnus-server-get-method + nil meth)))) + gnus-valid-select-methods) + (require backend)) + (gnus-check-server meth) + (when (gnus-check-backend-function 'request-create-group nname) + (gnus-request-create-group nname nil args)) + t)) + +(defun gnus-group-delete-group (group &optional force) + "Delete the current group. Only meaningful with mail groups. +If FORCE (the prefix) is non-nil, all the articles in the group will +be deleted. This is \"deleted\" as in \"removed forever from the face +of the Earth\". There is no undo. The user will be prompted before +doing the deletion." + (interactive + (list (gnus-group-group-name) + current-prefix-arg)) + (unless group + (error "No group to rename")) + (unless (gnus-check-backend-function 'request-delete-group group) + (error "This backend does not support group deletion")) + (prog1 + (if (not (gnus-yes-or-no-p + (format + "Do you really want to delete %s%s? " + group (if force " and all its contents" "")))) + () ; Whew! + (gnus-message 6 "Deleting group %s..." group) + (if (not (gnus-request-delete-group group force)) + (gnus-error 3 "Couldn't delete group %s" group) + (gnus-message 6 "Deleting group %s...done" group) + (gnus-group-goto-group group) + (gnus-group-kill-group 1 t) + (gnus-sethash group nil gnus-active-hashtb) + t)) + (gnus-group-position-point))) + +(defun gnus-group-rename-group (group new-name) + "Rename group from GROUP to NEW-NAME. +When used interactively, GROUP is the group under point +and NEW-NAME will be prompted for." + (interactive + (list + (gnus-group-group-name) + (progn + (unless (gnus-check-backend-function + 'request-rename-group (gnus-group-group-name)) + (error "This backend does not support renaming groups")) + (gnus-read-group "Rename group to: " + (gnus-group-real-name (gnus-group-group-name)))))) + + (unless (gnus-check-backend-function 'request-rename-group group) + (error "This backend does not support renaming groups")) + (unless group + (error "No group to rename")) + (when (equal (gnus-group-real-name group) new-name) + (error "Can't rename to the same name")) + + ;; We find the proper prefixed name. + (setq new-name + (if (gnus-group-native-p group) + ;; Native group. + new-name + ;; Foreign group. + (gnus-group-prefixed-name + (gnus-group-real-name new-name) + (gnus-info-method (gnus-get-info group))))) + + (gnus-message 6 "Renaming group %s to %s..." group new-name) + (prog1 + (if (not (gnus-request-rename-group group new-name)) + (gnus-error 3 "Couldn't rename group %s to %s" group new-name) + ;; We rename the group internally by killing it... + (gnus-group-goto-group group) + (gnus-group-kill-group) + ;; ... changing its name ... + (setcar (cdar gnus-list-of-killed-groups) new-name) + ;; ... and then yanking it. Magic! + (gnus-group-yank-group) + (gnus-set-active new-name (gnus-active group)) + (gnus-message 6 "Renaming group %s to %s...done" group new-name) + new-name) + (gnus-group-position-point))) + +(defun gnus-group-edit-group (group &optional part) + "Edit the group on the current line." + (interactive (list (gnus-group-group-name))) + (let ((part (or part 'info)) + info) + (unless group + (error "No group on current line")) + (unless (setq info (gnus-get-info group)) + (error "Killed group; can't be edited")) + (ignore-errors + (gnus-close-group group)) + (gnus-edit-form + ;; Find the proper form to edit. + (cond ((eq part 'method) + (or (gnus-info-method info) "native")) + ((eq part 'params) + (gnus-info-params info)) + (t info)) + ;; The proper documentation. + (format + "Editing the %s for `%s'." + (cond + ((eq part 'method) "select method") + ((eq part 'params) "group parameters") + (t "group info")) + group) + `(lambda (form) + (gnus-group-edit-group-done ',part ,group form))))) + +(defun gnus-group-edit-group-method (group) + "Edit the select method of GROUP." + (interactive (list (gnus-group-group-name))) + (gnus-group-edit-group group 'method)) + +(defun gnus-group-edit-group-parameters (group) + "Edit the group parameters of GROUP." + (interactive (list (gnus-group-group-name))) + (gnus-group-edit-group group 'params)) + +(defun gnus-group-edit-group-done (part group form) + "Update variables." + (let* ((method (cond ((eq part 'info) (nth 4 form)) + ((eq part 'method) form) + (t nil))) + (info (cond ((eq part 'info) form) + ((eq part 'method) (gnus-get-info group)) + (t nil))) + (new-group (if info + (if (or (not method) + (gnus-server-equal + gnus-select-method method)) + (gnus-group-real-name (car info)) + (gnus-group-prefixed-name + (gnus-group-real-name (car info)) method)) + nil))) + (when (and new-group + (not (equal new-group group))) + (when (gnus-group-goto-group group) + (gnus-group-kill-group 1)) + (gnus-activate-group new-group)) + ;; Set the info. + (if (not (and info new-group)) + (gnus-group-set-info form (or new-group group) part) + (setq info (gnus-copy-sequence info)) + (setcar info new-group) + (unless (gnus-server-equal method "native") + (unless (nthcdr 3 info) + (nconc info (list nil nil))) + (unless (nthcdr 4 info) + (nconc info (list nil))) + (gnus-info-set-method info method)) + (gnus-group-set-info info)) + (gnus-group-update-group (or new-group group)) + (gnus-group-position-point))) + +(defun gnus-group-make-useful-group (group method) + (interactive + (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups + nil t) + gnus-useful-groups))) + (list (cadr entry) (caddr entry)))) + (setq method (gnus-copy-sequence method)) + (let (entry) + (while (setq entry (memq (assq 'eval method) method)) + (setcar entry (eval (cadar entry))))) + (gnus-group-make-group group method)) + +(defun gnus-group-make-help-group () + "Create the Gnus documentation group." + (interactive) + (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) + (file (nnheader-find-etc-directory "gnus-tut.txt" t)) + dir) + (when (gnus-gethash name gnus-newsrc-hashtb) + (error "Documentation group already exists")) + (if (not file) + (gnus-message 1 "Couldn't find doc group") + (gnus-group-make-group + (gnus-group-real-name name) + (list 'nndoc "gnus-help" + (list 'nndoc-address file) + (list 'nndoc-article-type 'mbox))))) + (gnus-group-position-point)) + +(defun gnus-group-make-doc-group (file type) + "Create a group that uses a single file as the source." + (interactive + (list (read-file-name "File name: ") + (and current-prefix-arg 'ask))) + (when (eq type 'ask) + (let ((err "") + char found) + (while (not found) + (message + "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [mbdfag]: " + err) + (setq found (cond ((= (setq char (read-char)) ?m) 'mbox) + ((= char ?b) 'babyl) + ((= char ?d) 'digest) + ((= char ?f) 'forward) + ((= char ?a) 'mmfd) + (t (setq err (format "%c unknown. " char)) + nil)))) + (setq type found))) + (let* ((file (expand-file-name file)) + (name (gnus-generate-new-group-name + (gnus-group-prefixed-name + (file-name-nondirectory file) '(nndoc ""))))) + (gnus-group-make-group + (gnus-group-real-name name) + (list 'nndoc file + (list 'nndoc-address file) + (list 'nndoc-article-type (or type 'guess)))))) + +(defvar nnweb-type-definition) +(defvar gnus-group-web-type-history nil) +(defvar gnus-group-web-search-history nil) +(defun gnus-group-make-web-group (&optional solid) + "Create an ephemeral nnweb group. +If SOLID (the prefix), create a solid group." + (interactive "P") + (require 'nnweb) + (let* ((group + (if solid (gnus-read-group "Group name: ") + (message-unique-id))) + (default-type (or (car gnus-group-web-type-history) + (symbol-name (caar nnweb-type-definition)))) + (type + (gnus-string-or + (completing-read + (format "Search engine type (default %s): " default-type) + (mapcar (lambda (elem) (list (symbol-name (car elem)))) + nnweb-type-definition) + nil t nil 'gnus-group-web-type-history) + default-type)) + (search + (read-string + "Search string: " + (cons (or (car gnus-group-web-search-history) "") 0) + 'gnus-group-web-search-history)) + (method + `(nnweb ,group (nnweb-search ,search) + (nnweb-type ,(intern type)) + (nnweb-ephemeral-p t)))) + (if solid + (gnus-group-make-group group "nnweb" "" `(,(intern type) ,search)) + (gnus-group-read-ephemeral-group + group method t + (cons (current-buffer) + (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) + +(defun gnus-group-make-archive-group (&optional all) + "Create the (ding) Gnus archive group of the most recent articles. +Given a prefix, create a full group." + (interactive "P") + (let ((group (gnus-group-prefixed-name + (if all "ding.archives" "ding.recent") '(nndir "")))) + (when (gnus-gethash group gnus-newsrc-hashtb) + (error "Archive group already exists")) + (gnus-group-make-group + (gnus-group-real-name group) + (list 'nndir (if all "hpc" "edu") + (list 'nndir-directory + (if all gnus-group-archive-directory + gnus-group-recent-archive-directory)))) + (gnus-group-add-parameter group (cons 'to-address "ding@gnus.org")))) + +(defun gnus-group-make-directory-group (dir) + "Create an nndir group. +The user will be prompted for a directory. The contents of this +directory will be used as a newsgroup. The directory should contain +mail messages or news articles in files that have numeric names." + (interactive + (list (read-file-name "Create group from directory: "))) + (unless (file-exists-p dir) + (error "No such directory")) + (unless (file-directory-p dir) + (error "Not a directory")) + (let ((ext "") + (i 0) + group) + (while (or (not group) (gnus-gethash group gnus-newsrc-hashtb)) + (setq group + (gnus-group-prefixed-name + (concat (file-name-as-directory (directory-file-name dir)) + ext) + '(nndir ""))) + (setq ext (format "<%d>" (setq i (1+ i))))) + (gnus-group-make-group + (gnus-group-real-name group) + (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) + +(defun gnus-group-make-kiboze-group (group address scores) + "Create an nnkiboze group. +The user will be prompted for a name, a regexp to match groups, and +score file entries for articles to include in the group." + (interactive + (list + (read-string "nnkiboze group name: ") + (read-string "Source groups (regexp): ") + (let ((headers (mapcar (lambda (group) (list group)) + '("subject" "from" "number" "date" "message-id" + "references" "chars" "lines" "xref" + "followup" "all" "body" "head"))) + scores header regexp regexps) + (while (not (equal "" (setq header (completing-read + "Match on header: " headers nil t)))) + (setq regexps nil) + (while (not (equal "" (setq regexp (read-string + (format "Match on %s (string): " + header))))) + (push (list regexp nil nil 'r) regexps)) + (push (cons header regexps) scores)) + scores))) + (gnus-group-make-group group "nnkiboze" address) + (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group)) + (let (emacs-lisp-mode-hook) + (pp scores (current-buffer))))) + +(defun gnus-group-add-to-virtual (n vgroup) + "Add the current group to a virtual group." + (interactive + (list current-prefix-arg + (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t + "nnvirtual:"))) + (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual) + (error "%s is not an nnvirtual group" vgroup)) + (gnus-close-group vgroup) + (let* ((groups (gnus-group-process-prefix n)) + (method (gnus-info-method (gnus-get-info vgroup)))) + (setcar (cdr method) + (concat + (nth 1 method) "\\|" + (mapconcat + (lambda (s) + (gnus-group-remove-mark s) + (concat "\\(^" (regexp-quote s) "$\\)")) + groups "\\|")))) + (gnus-group-position-point)) + +(defun gnus-group-make-empty-virtual (group) + "Create a new, fresh, empty virtual group." + (interactive "sCreate new, empty virtual group: ") + (let* ((method (list 'nnvirtual "^$")) + (pgroup (gnus-group-prefixed-name group method))) + ;; Check whether it exists already. + (when (gnus-gethash pgroup gnus-newsrc-hashtb) + (error "Group %s already exists" pgroup)) + ;; Subscribe the new group after the group on the current line. + (gnus-subscribe-group pgroup (gnus-group-group-name) method) + (gnus-group-update-group pgroup) + (forward-line -1) + (gnus-group-position-point))) + +(defun gnus-group-enter-directory (dir) + "Enter an ephemeral nneething group." + (interactive "DDirectory to read: ") + (let* ((method (list 'nneething dir '(nneething-read-only t))) + (leaf (gnus-group-prefixed-name + (file-name-nondirectory (directory-file-name dir)) + method)) + (name (gnus-generate-new-group-name leaf))) + (unless (gnus-group-read-ephemeral-group + name method t + (cons (current-buffer) + (if (eq major-mode 'gnus-summary-mode) + 'summary 'group))) + (error "Couldn't enter %s" dir)))) + +;; Group sorting commands +;; Suggested by Joe Hildebrand . + +(defun gnus-group-sort-groups (func &optional reverse) + "Sort the group buffer according to FUNC. +When used interactively, the sorting function used will be +determined by the `gnus-group-sort-function' variable. +If REVERSE (the prefix), reverse the sorting order." + (interactive (list gnus-group-sort-function current-prefix-arg)) + (funcall gnus-group-sort-alist-function + (gnus-make-sort-function func) reverse) + (gnus-group-list-groups) + (gnus-dribble-touch)) + +(defun gnus-group-sort-flat (func reverse) + ;; We peel off the dummy group from the alist. + (when func + (when (equal (gnus-info-group (car gnus-newsrc-alist)) "dummy.group") + (pop gnus-newsrc-alist)) + ;; Do the sorting. + (setq gnus-newsrc-alist + (sort gnus-newsrc-alist func)) + (when reverse + (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))) + ;; Regenerate the hash table. + (gnus-make-hashtable-from-newsrc-alist))) + +(defun gnus-group-sort-groups-by-alphabet (&optional reverse) + "Sort the group buffer alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-group-sort-groups-by-unread (&optional reverse) + "Sort the group buffer by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-group-sort-groups-by-level (&optional reverse) + "Sort the group buffer by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-group-sort-groups-by-score (&optional reverse) + "Sort the group buffer by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-group-sort-groups-by-rank (&optional reverse) + "Sort the group buffer by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-group-sort-groups-by-method (&optional reverse) + "Sort the group buffer alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-method reverse)) + +;;; Selected group sorting. + +(defun gnus-group-sort-selected-groups (n func &optional reverse) + "Sort the process/prefixed groups." + (interactive (list current-prefix-arg gnus-group-sort-function)) + (let ((groups (gnus-group-process-prefix n))) + (funcall gnus-group-sort-selected-function + groups (gnus-make-sort-function func) reverse) + (gnus-group-list-groups))) + +(defun gnus-group-sort-selected-flat (groups func reverse) + (let (entries infos) + ;; First find all the group entries for these groups. + (while groups + (push (nthcdr 2 (gnus-gethash (pop groups) gnus-newsrc-hashtb)) + entries)) + ;; Then sort the infos. + (setq infos + (sort + (mapcar + (lambda (entry) (car entry)) + (setq entries (nreverse entries))) + func)) + (when reverse + (setq infos (nreverse infos))) + ;; Go through all the infos and replace the old entries + ;; with the new infos. + (while infos + (setcar entries (pop infos)) + (pop entries)) + ;; Update the hashtable. + (gnus-make-hashtable-from-newsrc-alist))) + +(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse) + "Sort the group buffer alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-group-sort-selected-groups-by-unread (&optional reverse) + "Sort the group buffer by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-group-sort-selected-groups-by-level (&optional reverse) + "Sort the group buffer by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-group-sort-selected-groups-by-score (&optional reverse) + "Sort the group buffer by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-group-sort-selected-groups-by-rank (&optional reverse) + "Sort the group buffer by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-group-sort-selected-groups-by-method (&optional reverse) + "Sort the group buffer alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse)) + +;;; Sorting predicates. + +(defun gnus-group-sort-by-alphabet (info1 info2) + "Sort alphabetically." + (string< (gnus-info-group info1) (gnus-info-group info2))) + +(defun gnus-group-sort-by-real-name (info1 info2) + "Sort alphabetically on real (unprefixed) names." + (string< (gnus-group-real-name (gnus-info-group info1)) + (gnus-group-real-name (gnus-info-group info2)))) + +(defun gnus-group-sort-by-unread (info1 info2) + "Sort by number of unread articles." + (let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb))) + (n2 (car (gnus-gethash (gnus-info-group info2) gnus-newsrc-hashtb)))) + (< (or (and (numberp n1) n1) 0) + (or (and (numberp n2) n2) 0)))) + +(defun gnus-group-sort-by-level (info1 info2) + "Sort by level." + (< (gnus-info-level info1) (gnus-info-level info2))) + +(defun gnus-group-sort-by-method (info1 info2) + "Sort alphabetically by backend name." + (string< (symbol-name (car (gnus-find-method-for-group + (gnus-info-group info1) info1))) + (symbol-name (car (gnus-find-method-for-group + (gnus-info-group info2) info2))))) + +(defun gnus-group-sort-by-score (info1 info2) + "Sort by group score." + (< (gnus-info-score info1) (gnus-info-score info2))) + +(defun gnus-group-sort-by-rank (info1 info2) + "Sort by level and score." + (let ((level1 (gnus-info-level info1)) + (level2 (gnus-info-level info2))) + (or (< level1 level2) + (and (= level1 level2) + (> (gnus-info-score info1) (gnus-info-score info2)))))) + +;;; Clearing data + +(defun gnus-group-clear-data (&optional arg) + "Clear all marks and read ranges from the current group." + (interactive "P") + (gnus-group-iterate arg + (lambda (group) + (let (info) + (gnus-info-clear-data (setq info (gnus-get-info group))) + (gnus-get-unread-articles-in-group info (gnus-active group) t) + (when (gnus-group-goto-group group) + (gnus-group-update-group-line)))))) + +(defun gnus-group-clear-data-on-native-groups () + "Clear all marks and read ranges from all native groups." + (interactive) + (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ") + (let ((alist (cdr gnus-newsrc-alist)) + info) + (while (setq info (pop alist)) + (when (gnus-group-native-p (gnus-info-group info)) + (gnus-info-clear-data info))) + (gnus-get-unread-articles) + (gnus-dribble-enter "") + (when (gnus-y-or-n-p + "Move the cache away to avoid problems in the future? ") + (call-interactively 'gnus-cache-move-cache))))) + +(defun gnus-info-clear-data (info) + "Clear all marks and read ranges from INFO." + (let ((group (gnus-info-group info))) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (when (gnus-group-goto-group ,group) + (gnus-group-update-group-line)))) + (gnus-info-set-read info nil) + (when (gnus-info-marks info) + (gnus-info-set-marks info nil)))) + +;; Group catching up. + +(defun gnus-group-catchup-current (&optional n all) + "Mark all articles not marked as unread in current newsgroup as read. +If prefix argument N is numeric, the ARG next newsgroups will be +caught up. If ALL is non-nil, marked articles will also be marked as +read. Cross references (Xref: header) of articles are ignored. +The difference between N and actual number of newsgroups that were +caught up is returned." + (interactive "P") + (unless (gnus-group-group-name) + (error "No group on the current line")) + (let ((groups (gnus-group-process-prefix n)) + (ret 0)) + (if (not + (or (not gnus-interactive-catchup) ;Without confirmation? + gnus-expert-user + (gnus-y-or-n-p + (format + (if all + "Do you really want to mark all articles in %s as read? " + "Mark all unread articles in %s as read? ") + (if (= (length groups) 1) + (car groups) + (format "these %d groups" (length groups))))))) + n + (while groups + ;; Virtual groups have to be given special treatment. + (let ((method (gnus-find-method-for-group (car groups)))) + (when (eq 'nnvirtual (car method)) + (nnvirtual-catchup-group + (gnus-group-real-name (car groups)) (nth 1 method) all))) + (gnus-group-remove-mark (car groups)) + (if (>= (gnus-group-group-level) gnus-level-zombie) + (gnus-message 2 "Dead groups can't be caught up") + (if (prog1 + (gnus-group-goto-group (car groups)) + (gnus-group-catchup (car groups) all)) + (gnus-group-update-group-line) + (setq ret (1+ ret)))) + (setq groups (cdr groups))) + (gnus-group-next-unread-group 1) + ret))) + +(defun gnus-group-catchup-current-all (&optional n) + "Mark all articles in current newsgroup as read. +Cross references (Xref: header) of articles are ignored." + (interactive "P") + (gnus-group-catchup-current n 'all)) + +(defun gnus-group-catchup (group &optional all) + "Mark all articles in GROUP as read. +If ALL is non-nil, all articles are marked as read. +The return value is the number of articles that were marked as read, +or nil if no action could be taken." + (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (num (car entry))) + ;; Do the updating only if the newsgroup isn't killed. + (if (not (numberp (car entry))) + (gnus-message 1 "Can't catch up %s; non-active group" group) + ;; Do auto-expirable marks if that's required. + (when (gnus-group-auto-expirable-p group) + (gnus-add-marked-articles + group 'expire (gnus-list-of-unread-articles group)) + (when all + (let ((marks (nth 3 (nth 2 entry)))) + (gnus-add-marked-articles + group 'expire (gnus-uncompress-range (cdr (assq 'tick marks)))) + (gnus-add-marked-articles + group 'expire (gnus-uncompress-range (cdr (assq 'tick marks))))))) + (when entry + (gnus-update-read-articles group nil) + ;; Also nix out the lists of marks and dormants. + (when all + (gnus-add-marked-articles group 'tick nil nil 'force) + (gnus-add-marked-articles group 'dormant nil nil 'force)) + (let ((gnus-newsgroup-name group)) + (run-hooks 'gnus-group-catchup-group-hook)) + num)))) + +(defun gnus-group-expire-articles (&optional n) + "Expire all expirable articles in the current newsgroup." + (interactive "P") + (let ((groups (gnus-group-process-prefix n)) + group) + (unless groups + (error "No groups to expire")) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + (when (gnus-check-backend-function 'request-expire-articles group) + (gnus-message 6 "Expiring articles in %s..." group) + (let* ((info (gnus-get-info group)) + (expirable (if (gnus-group-total-expirable-p group) + (cons nil (gnus-list-of-read-articles group)) + (assq 'expire (gnus-info-marks info)))) + (expiry-wait (gnus-group-find-parameter group 'expiry-wait))) + (when expirable + (setcdr + expirable + (gnus-compress-sequence + (if expiry-wait + ;; We set the expiry variables to the group + ;; parameter. + (let ((nnmail-expiry-wait-function nil) + (nnmail-expiry-wait expiry-wait)) + (gnus-request-expire-articles + (gnus-uncompress-sequence (cdr expirable)) group)) + ;; Just expire using the normal expiry values. + (gnus-request-expire-articles + (gnus-uncompress-sequence (cdr expirable)) group)))) + (gnus-close-group group)) + (gnus-message 6 "Expiring articles in %s...done" group))) + (gnus-dribble-touch) + (gnus-group-position-point)))) + +(defun gnus-group-expire-all-groups () + "Expire all expirable articles in all newsgroups." + (interactive) + (save-excursion + (gnus-message 5 "Expiring...") + (let ((gnus-group-marked (mapcar (lambda (info) (gnus-info-group info)) + (cdr gnus-newsrc-alist)))) + (gnus-group-expire-articles nil))) + (gnus-group-position-point) + (gnus-message 5 "Expiring...done")) + +(defun gnus-group-set-current-level (n level) + "Set the level of the next N groups to LEVEL." + (interactive + (list + current-prefix-arg + (string-to-int + (let ((s (read-string + (format "Level (default %s): " + (or (gnus-group-group-level) + gnus-level-default-subscribed))))) + (if (string-match "^\\s-*$" s) + (int-to-string (or (gnus-group-group-level) + gnus-level-default-subscribed)) + s))))) + (unless (and (>= level 1) (<= level gnus-level-killed)) + (error "Illegal level: %d" level)) + (let ((groups (gnus-group-process-prefix n)) + group) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + (gnus-message 6 "Changed level of %s from %d to %d" + group (or (gnus-group-group-level) gnus-level-killed) + level) + (gnus-group-change-level + group level (or (gnus-group-group-level) gnus-level-killed)) + (gnus-group-update-group-line))) + (gnus-group-position-point)) + +(defun gnus-group-unsubscribe (&optional n) + "Unsubscribe the current group." + (interactive "P") + (gnus-group-unsubscribe-current-group n 'unsubscribe)) + +(defun gnus-group-subscribe (&optional n) + "Subscribe the current group." + (interactive "P") + (gnus-group-unsubscribe-current-group n 'subscribe)) + +(defun gnus-group-unsubscribe-current-group (&optional n do-sub) + "Toggle subscription of the current group. +If given numerical prefix, toggle the N next groups." + (interactive "P") + (let ((groups (gnus-group-process-prefix n)) + group) + (while groups + (setq group (car groups) + groups (cdr groups)) + (gnus-group-remove-mark group) + (gnus-group-unsubscribe-group + group + (cond + ((eq do-sub 'unsubscribe) + gnus-level-default-unsubscribed) + ((eq do-sub 'subscribe) + gnus-level-default-subscribed) + ((<= (gnus-group-group-level) gnus-level-subscribed) + gnus-level-default-unsubscribed) + (t + gnus-level-default-subscribed)) + t) + (gnus-group-update-group-line)) + (gnus-group-next-group 1))) + +(defun gnus-group-unsubscribe-group (group &optional level silent) + "Toggle subscription to GROUP. +Killed newsgroups are subscribed. If SILENT, don't try to update the +group line." + (interactive + (list (completing-read + "Group: " gnus-active-hashtb nil + (gnus-read-active-file-p) + nil + 'gnus-group-history))) + (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) + (cond + ((string-match "^[ \t]$" group) + (error "Empty group name")) + (newsrc + ;; Toggle subscription flag. + (gnus-group-change-level + newsrc (if level level (if (<= (gnus-info-level (nth 2 newsrc)) + gnus-level-subscribed) + (1+ gnus-level-subscribed) + gnus-level-default-subscribed))) + (unless silent + (gnus-group-update-group group))) + ((and (stringp group) + (or (not (gnus-read-active-file-p)) + (gnus-active group))) + ;; Add new newsgroup. + (gnus-group-change-level + group + (if level level gnus-level-default-subscribed) + (or (and (member group gnus-zombie-list) + gnus-level-zombie) + gnus-level-killed) + (when (gnus-group-group-name) + (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb))) + (unless silent + (gnus-group-update-group group))) + (t (error "No such newsgroup: %s" group))) + (gnus-group-position-point))) + +(defun gnus-group-transpose-groups (n) + "Move the current newsgroup up N places. +If given a negative prefix, move down instead. The difference between +N and the number of steps taken is returned." + (interactive "p") + (unless (gnus-group-group-name) + (error "No group on current line")) + (gnus-group-kill-group 1) + (prog1 + (forward-line (- n)) + (gnus-group-yank-group) + (gnus-group-position-point))) + +(defun gnus-group-kill-all-zombies () + "Kill all zombie newsgroups." + (interactive) + (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) + (setq gnus-zombie-list nil) + (gnus-dribble-touch) + (gnus-group-list-groups)) + +(defun gnus-group-kill-region (begin end) + "Kill newsgroups in current region (excluding current point). +The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." + (interactive "r") + (let ((lines + ;; Count lines. + (save-excursion + (count-lines + (progn + (goto-char begin) + (beginning-of-line) + (point)) + (progn + (goto-char end) + (beginning-of-line) + (point)))))) + (goto-char begin) + (beginning-of-line) ;Important when LINES < 1 + (gnus-group-kill-group lines))) + +(defun gnus-group-kill-group (&optional n discard) + "Kill the next N groups. +The killed newsgroups can be yanked by using \\[gnus-group-yank-group]. +However, only groups that were alive can be yanked; already killed +groups or zombie groups can't be yanked. +The return value is the name of the group that was killed, or a list +of groups killed." + (interactive "P") + (let ((buffer-read-only nil) + (groups (gnus-group-process-prefix n)) + group entry level out) + (if (< (length groups) 10) + ;; This is faster when there are few groups. + (while groups + (push (setq group (pop groups)) out) + (gnus-group-remove-mark group) + (setq level (gnus-group-group-level)) + (gnus-delete-line) + (when (and (not discard) + (setq entry (gnus-gethash group gnus-newsrc-hashtb))) + (gnus-undo-register + `(progn + (gnus-group-goto-group ,(gnus-group-group-name)) + (gnus-group-yank-group))) + (push (cons (car entry) (nth 2 entry)) + gnus-list-of-killed-groups)) + (gnus-group-change-level + (if entry entry group) gnus-level-killed (if entry nil level))) + ;; If there are lots and lots of groups to be killed, we use + ;; this thing instead. + (let (entry) + (setq groups (nreverse groups)) + (while groups + (gnus-group-remove-mark (setq group (pop groups))) + (gnus-delete-line) + (push group gnus-killed-list) + (setq gnus-newsrc-alist + (delq (assoc group gnus-newsrc-alist) + gnus-newsrc-alist)) + (when gnus-group-change-level-function + (funcall gnus-group-change-level-function group 9 3)) + (cond + ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (push (cons (car entry) (nth 2 entry)) + gnus-list-of-killed-groups) + (setcdr (cdr entry) (cdddr entry))) + ((member group gnus-zombie-list) + (setq gnus-zombie-list (delete group gnus-zombie-list))))) + (gnus-make-hashtable-from-newsrc-alist))) + + (gnus-group-position-point) + (if (< (length out) 2) (car out) (nreverse out)))) + +(defun gnus-group-yank-group (&optional arg) + "Yank the last newsgroups killed with \\[gnus-group-kill-group], +inserting it before the current newsgroup. The numeric ARG specifies +how many newsgroups are to be yanked. The name of the newsgroup yanked +is returned, or (if several groups are yanked) a list of yanked groups +is returned." + (interactive "p") + (setq arg (or arg 1)) + (let (info group prev out) + (while (>= (decf arg) 0) + (when (not (setq info (pop gnus-list-of-killed-groups))) + (error "No more newsgroups to yank")) + (push (setq group (nth 1 info)) out) + ;; Find which newsgroup to insert this one before - search + ;; backward until something suitable is found. If there are no + ;; other newsgroups in this buffer, just make this newsgroup the + ;; first newsgroup. + (setq prev (gnus-group-group-name)) + (gnus-group-change-level + info (gnus-info-level (cdr info)) gnus-level-killed + (and prev (gnus-gethash prev gnus-newsrc-hashtb)) + t) + (gnus-group-insert-group-line-info group) + (gnus-undo-register + `(when (gnus-group-goto-group ,group) + (gnus-group-kill-group 1)))) + (forward-line -1) + (gnus-group-position-point) + (if (< (length out) 2) (car out) (nreverse out)))) + +(defun gnus-group-kill-level (level) + "Kill all groups that is on a certain LEVEL." + (interactive "nKill all groups on level: ") + (cond + ((= level gnus-level-zombie) + (setq gnus-killed-list + (nconc gnus-zombie-list gnus-killed-list)) + (setq gnus-zombie-list nil)) + ((and (< level gnus-level-zombie) + (> level 0) + (or gnus-expert-user + (gnus-yes-or-no-p + (format + "Do you really want to kill all groups on level %d? " + level)))) + (let* ((prev gnus-newsrc-alist) + (alist (cdr prev))) + (while alist + (if (= (gnus-info-level (car alist)) level) + (progn + (push (gnus-info-group (car alist)) gnus-killed-list) + (setcdr prev (cdr alist))) + (setq prev alist)) + (setq alist (cdr alist))) + (gnus-make-hashtable-from-newsrc-alist) + (gnus-group-list-groups))) + (t + (error "Can't kill; illegal level: %d" level)))) + +(defun gnus-group-list-all-groups (&optional arg) + "List all newsgroups with level ARG or lower. +Default is gnus-level-unsubscribed, which lists all subscribed and most +unsubscribed groups." + (interactive "P") + (gnus-group-list-groups (or arg gnus-level-unsubscribed) t)) + +;; Redefine this to list ALL killed groups if prefix arg used. +;; Rewritten by engstrom@src.honeywell.com (Eric Engstrom). +(defun gnus-group-list-killed (&optional arg) + "List all killed newsgroups in the group buffer. +If ARG is non-nil, list ALL killed groups known to Gnus. This may +entail asking the server for the groups." + (interactive "P") + ;; Find all possible killed newsgroups if arg. + (when arg + (gnus-get-killed-groups)) + (if (not gnus-killed-list) + (gnus-message 6 "No killed groups") + (let (gnus-group-list-mode) + (funcall gnus-group-prepare-function + gnus-level-killed t gnus-level-killed)) + (goto-char (point-min))) + (gnus-group-position-point)) + +(defun gnus-group-list-zombies () + "List all zombie newsgroups in the group buffer." + (interactive) + (if (not gnus-zombie-list) + (gnus-message 6 "No zombie groups") + (let (gnus-group-list-mode) + (funcall gnus-group-prepare-function + gnus-level-zombie t gnus-level-zombie)) + (goto-char (point-min))) + (gnus-group-position-point)) + +(defun gnus-group-list-active () + "List all groups that are available from the server(s)." + (interactive) + ;; First we make sure that we have really read the active file. + (unless (gnus-read-active-file-p) + (let ((gnus-read-active-file t)) + (gnus-read-active-file))) + ;; Find all groups and sort them. + (let ((groups + (sort + (let (list) + (mapatoms + (lambda (sym) + (and (boundp sym) + (symbol-value sym) + (push (symbol-name sym) list))) + gnus-active-hashtb) + list) + 'string<)) + (buffer-read-only nil) + group) + (erase-buffer) + (while groups + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " *: " + (setq group (pop groups)) "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level (inline (gnus-group-level group))))) + (goto-char (point-min)))) + +(defun gnus-activate-all-groups (level) + "Activate absolutely all groups." + (interactive (list 7)) + (let ((gnus-activate-level level) + (gnus-activate-foreign-newsgroups level)) + (gnus-group-get-new-news))) + +(defun gnus-group-get-new-news (&optional arg) + "Get newly arrived articles. +If ARG is a number, it specifies which levels you are interested in +re-scanning. If ARG is non-nil and not a number, this will force +\"hard\" re-reading of the active files from all servers." + (interactive "P") + (let ((gnus-inhibit-demon t)) + (run-hooks 'gnus-get-new-news-hook) + + ;; Read any slave files. + (unless gnus-slave + (gnus-master-read-slave-newsrc)) + + ;; We might read in new NoCeM messages here. + (when (and gnus-use-nocem + (null arg)) + (gnus-nocem-scan-groups)) + ;; If ARG is not a number, then we read the active file. + (when (and arg (not (numberp arg))) + (let ((gnus-read-active-file t)) + (gnus-read-active-file)) + (setq arg nil) + + ;; If the user wants it, we scan for new groups. + (when (eq gnus-check-new-newsgroups 'always) + (gnus-find-new-newsgroups))) + + (setq arg (gnus-group-default-level arg t)) + (if (and gnus-read-active-file (not arg)) + (progn + (gnus-read-active-file) + (gnus-get-unread-articles arg)) + (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) + (gnus-get-unread-articles arg))) + (run-hooks 'gnus-after-getting-new-news-hook) + (gnus-group-list-groups (and (numberp arg) + (max (car gnus-group-list-mode) arg))))) + +(defun gnus-group-get-new-news-this-group (&optional n dont-scan) + "Check for newly arrived news in the current group (and the N-1 next groups). +The difference between N and the number of newsgroup checked is returned. +If N is negative, this group and the N-1 previous groups will be checked." + (interactive "P") + (let* ((groups (gnus-group-process-prefix n)) + (ret (if (numberp n) (- n (length groups)) 0)) + (beg (unless n + (point))) + group) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + ;; Bypass any previous denials from the server. + (gnus-remove-denial (gnus-find-method-for-group group)) + (if (gnus-activate-group group (if dont-scan nil 'scan)) + (progn + (gnus-get-unread-articles-in-group + (gnus-get-info group) (gnus-active group) t) + (unless (gnus-virtual-group-p group) + (gnus-close-group group)) + (gnus-group-update-group group)) + (if (eq (gnus-server-status (gnus-find-method-for-group group)) + 'denied) + (gnus-error 3 "Server denied access") + (gnus-error 3 "%s error: %s" group (gnus-status-message group))))) + (when beg + (goto-char beg)) + (when gnus-goto-next-group-when-activating + (gnus-group-next-unread-group 1 t)) + (gnus-summary-position-point) + ret)) + +(defun gnus-group-fetch-faq (group &optional faq-dir) + "Fetch the FAQ for the current group. +If given a prefix argument, prompt for the FAQ dir +to use." + (interactive + (list + (gnus-group-group-name) + (when current-prefix-arg + (completing-read + "Faq dir: " (and (listp gnus-group-faq-directory) + (mapcar (lambda (file) (list file)) + gnus-group-faq-directory)))))) + (unless group + (error "No group name given")) + (let ((dirs (or faq-dir gnus-group-faq-directory)) + dir found file) + (unless (listp dirs) + (setq dirs (list dirs))) + (while (and (not found) + (setq dir (pop dirs))) + (setq file (concat (file-name-as-directory dir) + (gnus-group-real-name group))) + (if (not (file-exists-p file)) + (gnus-message 1 "No such file: %s" file) + (let ((enable-local-variables nil)) + (find-file file) + (setq found t)))))) + +(defun gnus-group-describe-group (force &optional group) + "Display a description of the current newsgroup." + (interactive (list current-prefix-arg (gnus-group-group-name))) + (let* ((method (gnus-find-method-for-group group)) + (mname (gnus-group-prefixed-name "" method)) + desc) + (when (and force + gnus-description-hashtb) + (gnus-sethash mname nil gnus-description-hashtb)) + (unless group + (error "No group name given")) + (when (or (and gnus-description-hashtb + ;; We check whether this group's method has been + ;; queried for a description file. + (gnus-gethash mname gnus-description-hashtb)) + (setq desc (gnus-group-get-description group)) + (gnus-read-descriptions-file method)) + (gnus-message 1 + (or desc (gnus-gethash group gnus-description-hashtb) + "No description available"))))) + +;; Suggested by Per Abrahamsen . +(defun gnus-group-describe-all-groups (&optional force) + "Pop up a buffer with descriptions of all newsgroups." + (interactive "P") + (when force + (setq gnus-description-hashtb nil)) + (when (not (or gnus-description-hashtb + (gnus-read-all-descriptions-files))) + (error "Couldn't request descriptions file")) + (let ((buffer-read-only nil) + b) + (erase-buffer) + (mapatoms + (lambda (group) + (setq b (point)) + (insert (format " *: %-20s %s\n" (symbol-name group) + (symbol-value group))) + (gnus-add-text-properties + b (1+ b) (list 'gnus-group group + 'gnus-unread t 'gnus-marked nil + 'gnus-level (1+ gnus-level-subscribed)))) + gnus-description-hashtb) + (goto-char (point-min)) + (gnus-group-position-point))) + +;; Suggested by Daniel Quinlan . +(defun gnus-group-apropos (regexp &optional search-description) + "List all newsgroups that have names that match a regexp." + (interactive "sGnus apropos (regexp): ") + (let ((prev "") + (obuf (current-buffer)) + groups des) + ;; Go through all newsgroups that are known to Gnus. + (mapatoms + (lambda (group) + (and (symbol-name group) + (string-match regexp (symbol-name group)) + (push (symbol-name group) groups))) + gnus-active-hashtb) + ;; Also go through all descriptions that are known to Gnus. + (when search-description + (mapatoms + (lambda (group) + (and (string-match regexp (symbol-value group)) + (gnus-active (symbol-name group)) + (push (symbol-name group) groups))) + gnus-description-hashtb)) + (if (not groups) + (gnus-message 3 "No groups matched \"%s\"." regexp) + ;; Print out all the groups. + (save-excursion + (pop-to-buffer "*Gnus Help*") + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (setq groups (sort groups 'string<)) + (while groups + ;; Groups may be entered twice into the list of groups. + (when (not (string= (car groups) prev)) + (insert (setq prev (car groups)) "\n") + (when (and gnus-description-hashtb + (setq des (gnus-gethash (car groups) + gnus-description-hashtb))) + (insert " " des "\n"))) + (setq groups (cdr groups))) + (goto-char (point-min)))) + (pop-to-buffer obuf))) + +(defun gnus-group-description-apropos (regexp) + "List all newsgroups that have names or descriptions that match a regexp." + (interactive "sGnus description apropos (regexp): ") + (when (not (or gnus-description-hashtb + (gnus-read-all-descriptions-files))) + (error "Couldn't request descriptions file")) + (gnus-group-apropos regexp t)) + +;; Suggested by Per Abrahamsen . +(defun gnus-group-list-matching (level regexp &optional all lowest) + "List all groups with unread articles that match REGEXP. +If the prefix LEVEL is non-nil, it should be a number that says which +level to cut off listing groups. +If ALL, also list groups with no unread articles. +If LOWEST, don't list groups with level lower than LOWEST. + +This command may read the active file." + (interactive "P\nsList newsgroups matching: ") + ;; First make sure active file has been read. + (when (and level + (> (prefix-numeric-value level) gnus-level-killed)) + (gnus-get-killed-groups)) + (gnus-group-prepare-flat + (or level gnus-level-subscribed) all (or lowest 1) regexp) + (goto-char (point-min)) + (gnus-group-position-point)) + +(defun gnus-group-list-all-matching (level regexp &optional lowest) + "List all groups that match REGEXP. +If the prefix LEVEL is non-nil, it should be a number that says which +level to cut off listing groups. +If LOWEST, don't list groups with level lower than LOWEST." + (interactive "P\nsList newsgroups matching: ") + (when level + (setq level (prefix-numeric-value level))) + (gnus-group-list-matching (or level gnus-level-killed) regexp t lowest)) + +;; Suggested by Jack Vinson . +(defun gnus-group-save-newsrc (&optional force) + "Save the Gnus startup files. +If FORCE, force saving whether it is necessary or not." + (interactive "P") + (gnus-save-newsrc-file force)) + +(defun gnus-group-restart (&optional arg) + "Force Gnus to read the .newsrc file." + (interactive "P") + (when (gnus-yes-or-no-p + (format "Are you sure you want to restart Gnus? ")) + (gnus-save-newsrc-file) + (gnus-clear-system) + (gnus))) + +(defun gnus-group-read-init-file () + "Read the Gnus elisp init file." + (interactive) + (gnus-read-init-file) + (gnus-message 5 "Read %s" gnus-init-file)) + +(defun gnus-group-check-bogus-groups (&optional silent) + "Check bogus newsgroups. +If given a prefix, don't ask for confirmation before removing a bogus +group." + (interactive "P") + (gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user))) + (gnus-group-list-groups)) + +(defun gnus-group-find-new-groups (&optional arg) + "Search for new groups and add them. +Each new group will be treated with `gnus-subscribe-newsgroup-method.' +If ARG (the prefix), use the `ask-server' method to query +the server for new groups." + (interactive "P") + (gnus-find-new-newsgroups arg) + (gnus-group-list-groups)) + +(defun gnus-group-edit-global-kill (&optional article group) + "Edit the global kill file. +If GROUP, edit that local kill file instead." + (interactive "P") + (setq gnus-current-kill-article article) + (gnus-kill-file-edit-file group) + (gnus-message + 6 + (substitute-command-keys + (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)" + (if group "local" "global"))))) + +(defun gnus-group-edit-local-kill (article group) + "Edit a local kill file." + (interactive (list nil (gnus-group-group-name))) + (gnus-group-edit-global-kill article group)) + +(defun gnus-group-force-update () + "Update `.newsrc' file." + (interactive) + (gnus-save-newsrc-file)) + +(defun gnus-group-suspend () + "Suspend the current Gnus session. +In fact, cleanup buffers except for group mode buffer. +The hook gnus-suspend-gnus-hook is called before actually suspending." + (interactive) + (run-hooks 'gnus-suspend-gnus-hook) + ;; Kill Gnus buffers except for group mode buffer. + (let* ((group-buf (get-buffer gnus-group-buffer)) + ;; Do this on a separate list in case the user does a ^G before we finish + (gnus-buffer-list + (delete group-buf (delete gnus-dribble-buffer + (append gnus-buffer-list nil))))) + (while gnus-buffer-list + (gnus-kill-buffer (pop gnus-buffer-list))) + (gnus-kill-gnus-frames) + (when group-buf + (setq gnus-buffer-list (list group-buf)) + (bury-buffer group-buf) + (delete-windows-on group-buf t)))) + +(defun gnus-group-clear-dribble () + "Clear all information from the dribble buffer." + (interactive) + (gnus-dribble-clear) + (gnus-message 7 "Cleared dribble buffer")) + +(defun gnus-group-exit () + "Quit reading news after updating .newsrc.eld and .newsrc. +The hook `gnus-exit-gnus-hook' is called before actually exiting." + (interactive) + (when + (or noninteractive ;For gnus-batch-kill + (not gnus-interactive-exit) ;Without confirmation + gnus-expert-user + (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) + (run-hooks 'gnus-exit-gnus-hook) + ;; Offer to save data from non-quitted summary buffers. + (gnus-offer-save-summaries) + ;; Save the newsrc file(s). + (gnus-save-newsrc-file) + ;; Kill-em-all. + (gnus-close-backends) + ;; Reset everything. + (gnus-clear-system) + ;; Allow the user to do things after cleaning up. + (run-hooks 'gnus-after-exiting-gnus-hook))) + +(defun gnus-group-quit () + "Quit reading news without updating .newsrc.eld or .newsrc. +The hook `gnus-exit-gnus-hook' is called before actually exiting." + (interactive) + (when (or noninteractive ;For gnus-batch-kill + (zerop (buffer-size)) + (not (gnus-server-opened gnus-select-method)) + gnus-expert-user + (not gnus-current-startup-file) + (gnus-yes-or-no-p + (format "Quit reading news without saving %s? " + (file-name-nondirectory gnus-current-startup-file)))) + (run-hooks 'gnus-exit-gnus-hook) + (gnus-configure-windows 'group t) + (gnus-dribble-save) + (gnus-close-backends) + (gnus-clear-system) + (gnus-kill-buffer gnus-group-buffer) + ;; Allow the user to do things after cleaning up. + (run-hooks 'gnus-after-exiting-gnus-hook))) + +(defun gnus-group-describe-briefly () + "Give a one line description of the group mode commands." + (interactive) + (gnus-message 7 (substitute-command-keys "\\\\[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"))) + +(defun gnus-group-browse-foreign-server (method) + "Browse a foreign news server. +If called interactively, this function will ask for a select method + (nntp, nnspool, etc.) and a server address (eg. nntp.some.where). +If not, METHOD should be a list where the first element is the method +and the second element is the address." + (interactive + (list (let ((how (completing-read + "Which backend: " + (append gnus-valid-select-methods gnus-server-alist) + nil t (cons "nntp" 0) 'gnus-method-history))) + ;; We either got a backend name or a virtual server name. + ;; If the first, we also need an address. + (if (assoc how gnus-valid-select-methods) + (list (intern how) + ;; Suggested by mapjph@bath.ac.uk. + (completing-read + "Address: " + (mapcar (lambda (server) (list server)) + gnus-secondary-servers))) + ;; We got a server name. + how)))) + (gnus-browse-foreign-server method)) + +(defun gnus-group-set-info (info &optional method-only-group part) + (let* ((entry (gnus-gethash + (or method-only-group (gnus-info-group info)) + gnus-newsrc-hashtb)) + (part-info info) + (info (if method-only-group (nth 2 entry) info)) + method) + (when method-only-group + (unless entry + (error "Trying to change non-existent group %s" method-only-group)) + ;; We have received parts of the actual group info - either the + ;; select method or the group parameters. We first check + ;; whether we have to extend the info, and if so, do that. + (let ((len (length info)) + (total (if (eq part 'method) 5 6))) + (when (< len total) + (setcdr (nthcdr (1- len) info) + (make-list (- total len) nil))) + ;; Then we enter the new info. + (setcar (nthcdr (1- total) info) part-info))) + (unless entry + ;; This is a new group, so we just create it. + (save-excursion + (set-buffer gnus-group-buffer) + (setq method (gnus-info-method info)) + (when (gnus-server-equal method "native") + (setq method nil)) + (save-excursion + (set-buffer gnus-group-buffer) + (if method + ;; It's a foreign group... + (gnus-group-make-group + (gnus-group-real-name (gnus-info-group info)) + (if (stringp method) method + (prin1-to-string (car method))) + (and (consp method) + (nth 1 (gnus-info-method info)))) + ;; It's a native group. + (gnus-group-make-group (gnus-info-group info)))) + (gnus-message 6 "Note: New group created") + (setq entry + (gnus-gethash (gnus-group-prefixed-name + (gnus-group-real-name (gnus-info-group info)) + (or (gnus-info-method info) gnus-select-method)) + gnus-newsrc-hashtb)))) + ;; Whether it was a new group or not, we now have the entry, so we + ;; can do the update. + (if entry + (progn + (setcar (nthcdr 2 entry) info) + (when (and (not (eq (car entry) t)) + (gnus-active (gnus-info-group info))) + (setcar entry (length (gnus-list-of-unread-articles (car info)))))) + (error "No such group: %s" (gnus-info-group info))))) + +(defun gnus-group-set-method-info (group select-method) + (gnus-group-set-info select-method group 'method)) + +(defun gnus-group-set-params-info (group params) + (gnus-group-set-info params group 'params)) + +(defun gnus-add-marked-articles (group type articles &optional info force) + ;; Add ARTICLES of TYPE to the info of GROUP. + ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't + ;; add, but replace marked articles of TYPE with ARTICLES. + (let ((info (or info (gnus-get-info group))) + (uncompressed '(score bookmark killed)) + marked m) + (or (not info) + (and (not (setq marked (nthcdr 3 info))) + (or (null articles) + (setcdr (nthcdr 2 info) + (list (list (cons type (gnus-compress-sequence + articles t))))))) + (and (not (setq m (assq type (car marked)))) + (or (null articles) + (setcar marked + (cons (cons type (gnus-compress-sequence articles t) ) + (car marked))))) + (if force + (if (null articles) + (setcar (nthcdr 3 info) + (delq (assq type (car marked)) (car marked))) + (setcdr m (gnus-compress-sequence articles t))) + (setcdr m (gnus-compress-sequence + (sort (nconc (gnus-uncompress-range (cdr m)) + (copy-sequence articles)) '<) t)))))) + +;;; +;;; Group timestamps +;;; + +(defun gnus-group-set-timestamp () + "Change the timestamp of the current group to the current time. +This function can be used in hooks like `gnus-select-group-hook' +or `gnus-group-catchup-group-hook'." + (when gnus-newsgroup-name + (let ((time (current-time))) + (setcdr (cdr time) nil) + (gnus-group-set-parameter gnus-newsgroup-name 'timestamp time)))) + +(defsubst gnus-group-timestamp (group) + "Return the timestamp for GROUP." + (gnus-group-get-parameter group 'timestamp)) + +(defun gnus-group-timestamp-delta (group) + "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." + (let* ((time (or (gnus-group-timestamp group) + (list 0 0))) + (delta (gnus-time-minus (current-time) time))) + (+ (* (nth 0 delta) 65536.0) + (nth 1 delta)))) + +(defun gnus-group-timestamp-string (group) + "Return a string of the timestamp for GROUP." + (let ((time (gnus-group-timestamp group))) + (if (not time) + "" + (gnus-time-iso8601 time)))) + +(provide 'gnus-group) + +;;; gnus-group.el ends here diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el new file mode 100644 index 0000000..1fc205b --- /dev/null +++ b/lisp/gnus-int.el @@ -0,0 +1,475 @@ +;;; gnus-int.el --- backend interface functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) + +(defcustom gnus-open-server-hook nil + "Hook called just before opening connection to the news server." + :group 'gnus-start + :type 'hook) + +;;; +;;; Server Communication +;;; + +(defun gnus-start-news-server (&optional confirm) + "Open a method for getting news. +If CONFIRM is non-nil, the user will be asked for an NNTP server." + (let (how) + (if gnus-current-select-method + ;; Stream is already opened. + nil + ;; Open NNTP server. + (unless gnus-nntp-service + (setq gnus-nntp-server nil)) + (when confirm + ;; Read server name with completion. + (setq gnus-nntp-server + (completing-read "NNTP server: " + (mapcar (lambda (server) (list server)) + (cons (list gnus-nntp-server) + gnus-secondary-servers)) + nil nil gnus-nntp-server))) + + (when (and gnus-nntp-server + (stringp gnus-nntp-server) + (not (string= gnus-nntp-server ""))) + (setq gnus-select-method + (cond ((or (string= gnus-nntp-server "") + (string= gnus-nntp-server "::")) + (list 'nnspool (system-name))) + ((string-match "^:" gnus-nntp-server) + (list 'nnmh gnus-nntp-server + (list 'nnmh-directory + (file-name-as-directory + (expand-file-name + (concat "~/" (substring + gnus-nntp-server 1))))) + (list 'nnmh-get-new-mail nil))) + (t + (list 'nntp gnus-nntp-server))))) + + (setq how (car gnus-select-method)) + (cond + ((eq how 'nnspool) + (require 'nnspool) + (gnus-message 5 "Looking up local news spool...")) + ((eq how 'nnmh) + (require 'nnmh) + (gnus-message 5 "Looking up mh spool...")) + (t + (require 'nntp))) + (setq gnus-current-select-method gnus-select-method) + (run-hooks 'gnus-open-server-hook) + (or + ;; gnus-open-server-hook might have opened it + (gnus-server-opened gnus-select-method) + (gnus-open-server gnus-select-method) + (gnus-y-or-n-p + (format + "%s (%s) open error: '%s'. Continue? " + (car gnus-select-method) (cadr gnus-select-method) + (gnus-status-message gnus-select-method))) + (gnus-error 1 "Couldn't open server on %s" + (nth 1 gnus-select-method)))))) + +(defun gnus-check-group (group) + "Try to make sure that the server where GROUP exists is alive." + (let ((method (gnus-find-method-for-group group))) + (or (gnus-server-opened method) + (gnus-open-server method)))) + +(defun gnus-check-server (&optional method silent) + "Check whether the connection to METHOD is down. +If METHOD is nil, use `gnus-select-method'. +If it is down, start it up (again)." + (let ((method (or method gnus-select-method))) + ;; Transform virtual server names into select methods. + (when (stringp method) + (setq method (gnus-server-to-method method))) + (if (gnus-server-opened method) + ;; The stream is already opened. + t + ;; Open the server. + (unless silent + (gnus-message 5 "Opening %s server%s..." (car method) + (if (equal (nth 1 method) "") "" + (format " on %s" (nth 1 method))))) + (run-hooks 'gnus-open-server-hook) + (prog1 + (gnus-open-server method) + (unless silent + (message "")))))) + +(defun gnus-get-function (method function &optional noerror) + "Return a function symbol based on METHOD and FUNCTION." + ;; Translate server names into methods. + (unless method + (error "Attempted use of a nil select method")) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let ((func (intern (format "%s-%s" (if gnus-agent + (gnus-agent-get-function method) + (car method)) + function)))) + ;; If the functions isn't bound, we require the backend in + ;; question. + (unless (fboundp func) + (require (car method)) + (when (and (not (fboundp func)) + (not noerror)) + ;; This backend doesn't implement this function. + (error "No such function: %s" func))) + func)) + + +;;; +;;; Interface functions to the backends. +;;; + +(defun gnus-open-server (gnus-command-method) + "Open a connection to GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let ((elem (assoc gnus-command-method gnus-opened-servers))) + ;; If this method was previously denied, we just return nil. + (if (eq (nth 1 elem) 'denied) + (progn + (gnus-message 1 "Denied server") + nil) + ;; Open the server. + (let ((result + (funcall (gnus-get-function gnus-command-method 'open-server) + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)))) + ;; If this hasn't been opened before, we add it to the list. + (unless elem + (setq elem (list gnus-command-method nil) + gnus-opened-servers (cons elem gnus-opened-servers))) + ;; Set the status of this server. + (setcar (cdr elem) (if result 'ok 'denied)) + ;; Return the result from the "open" call. + result)))) + +(defun gnus-close-server (gnus-command-method) + "Close the connection to GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'close-server) + (nth 1 gnus-command-method))) + +(defun gnus-request-list (gnus-command-method) + "Request the active file from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-list) + (nth 1 gnus-command-method))) + +(defun gnus-request-list-newsgroups (gnus-command-method) + "Request the newsgroups file from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-list-newsgroups) + (nth 1 gnus-command-method))) + +(defun gnus-request-newgroups (date gnus-command-method) + "Request all new groups since DATE from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let ((func (gnus-get-function gnus-command-method 'request-newgroups t))) + (when func + (funcall func date (nth 1 gnus-command-method))))) + +(defun gnus-server-opened (gnus-command-method) + "Check whether a connection to GNUS-COMMAND-METHOD has been opened." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (inline (gnus-get-function gnus-command-method 'server-opened)) + (nth 1 gnus-command-method))) + +(defun gnus-status-message (gnus-command-method) + "Return the status message from GNUS-COMMAND-METHOD. +If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method +this group uses will be queried." + (let ((gnus-command-method + (if (stringp gnus-command-method) + (gnus-find-method-for-group gnus-command-method) + gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'status-message) + (nth 1 gnus-command-method)))) + +(defun gnus-request-regenerate (gnus-command-method) + "Request a data generation from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-regenerate) + (nth 1 gnus-command-method))) + +(defun gnus-request-group (group &optional dont-check gnus-command-method) + "Request GROUP. If DONT-CHECK, no information is required." + (let ((gnus-command-method + (or gnus-command-method (inline (gnus-find-method-for-group group))))) + (when (stringp gnus-command-method) + (setq gnus-command-method + (inline (gnus-server-to-method gnus-command-method)))) + (funcall (inline (gnus-get-function gnus-command-method 'request-group)) + (gnus-group-real-name group) (nth 1 gnus-command-method) + dont-check))) + +(defun gnus-list-active-group (group) + "Request active information on GROUP." + (let ((gnus-command-method (gnus-find-method-for-group group)) + (func 'list-active-group)) + (when (gnus-check-backend-function func group) + (funcall (gnus-get-function gnus-command-method func) + (gnus-group-real-name group) (nth 1 gnus-command-method))))) + +(defun gnus-request-group-description (group) + "Request a description of GROUP." + (let ((gnus-command-method (gnus-find-method-for-group group)) + (func 'request-group-description)) + (when (gnus-check-backend-function func group) + (funcall (gnus-get-function gnus-command-method func) + (gnus-group-real-name group) (nth 1 gnus-command-method))))) + +(defun gnus-close-group (group) + "Request the GROUP be closed." + (let ((gnus-command-method (inline (gnus-find-method-for-group group)))) + (funcall (gnus-get-function gnus-command-method 'close-group) + (gnus-group-real-name group) (nth 1 gnus-command-method)))) + +(defun gnus-retrieve-headers (articles group &optional fetch-old) + "Request headers for ARTICLES in GROUP. +If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (and gnus-use-cache (numberp (car articles))) + (gnus-cache-retrieve-headers articles group fetch-old) + (funcall (gnus-get-function gnus-command-method 'retrieve-headers) + articles (gnus-group-real-name group) + (nth 1 gnus-command-method) fetch-old)))) + +(defun gnus-retrieve-articles (articles group) + "Request ARTICLES in GROUP." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'retrieve-articles) + articles (gnus-group-real-name group) + (nth 1 gnus-command-method)))) + +(defun gnus-retrieve-groups (groups gnus-command-method) + "Request active information on GROUPS from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'retrieve-groups) + groups (nth 1 gnus-command-method))) + +(defun gnus-request-type (group &optional article) + "Return the type (`post' or `mail') of GROUP (and ARTICLE)." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-type (car gnus-command-method))) + 'unknown + (funcall (gnus-get-function gnus-command-method 'request-type) + (gnus-group-real-name group) article)))) + +(defun gnus-request-update-mark (group article mark) + "Return the type (`post' or `mail') of GROUP (and ARTICLE)." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-update-mark (car gnus-command-method))) + mark + (funcall (gnus-get-function gnus-command-method 'request-update-mark) + (gnus-group-real-name group) article mark)))) + +(defun gnus-request-article (article group &optional buffer) + "Request the ARTICLE in GROUP. +ARTICLE can either be an article number or an article Message-ID. +If BUFFER, insert the article in that group." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-article) + article (gnus-group-real-name group) + (nth 1 gnus-command-method) buffer))) + +(defun gnus-request-head (article group) + "Request the head of ARTICLE in GROUP." + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (head (gnus-get-function gnus-command-method 'request-head t)) + res clean-up) + (cond + ;; Check the cache. + ((and gnus-use-cache + (numberp article) + (gnus-cache-request-article article group)) + (setq res (cons group article) + clean-up t)) + ;; Use `head' function. + ((fboundp head) + (setq res (funcall head article (gnus-group-real-name group) + (nth 1 gnus-command-method)))) + ;; Use `article' function. + (t + (setq res (gnus-request-article article group) + clean-up t))) + (when clean-up + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (1- (point)) (point-max))) + (nnheader-fold-continuation-lines))) + res)) + +(defun gnus-request-body (article group) + "Request the body of ARTICLE in GROUP." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-body) + article (gnus-group-real-name group) + (nth 1 gnus-command-method)))) + +(defun gnus-request-post (gnus-command-method) + "Post the current buffer using GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-post) + (nth 1 gnus-command-method))) + +(defun gnus-request-scan (group gnus-command-method) + "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD. +If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." + (let ((gnus-command-method + (if group (gnus-find-method-for-group group) gnus-command-method)) + (gnus-inhibit-demon t)) + (funcall (gnus-get-function gnus-command-method 'request-scan) + (and group (gnus-group-real-name group)) + (nth 1 gnus-command-method)))) + +(defsubst gnus-request-update-info (info gnus-command-method) + "Request that GNUS-COMMAND-METHOD update INFO." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (when (gnus-check-backend-function + 'request-update-info (car gnus-command-method)) + (funcall (gnus-get-function gnus-command-method 'request-update-info) + (gnus-group-real-name (gnus-info-group info)) + info (nth 1 gnus-command-method)))) + +(defun gnus-request-expire-articles (articles group &optional force) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-expire-articles) + articles (gnus-group-real-name group) (nth 1 gnus-command-method) + force))) + +(defun gnus-request-move-article + (article group server accept-function &optional last) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-move-article) + article (gnus-group-real-name group) + (nth 1 gnus-command-method) accept-function last))) + +(defun gnus-request-accept-article (group &optional gnus-command-method last) + ;; Make sure there's a newline at the end of the article. + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (when (and (not gnus-command-method) + (stringp group)) + (setq gnus-command-method (gnus-group-name-to-method group))) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (let ((func (car (or gnus-command-method + (gnus-find-method-for-group group))))) + (funcall (intern (format "%s-request-accept-article" func)) + (if (stringp group) (gnus-group-real-name group) group) + (cadr gnus-command-method) + last))) + +(defun gnus-request-replace-article (article group buffer) + (let ((func (car (gnus-group-name-to-method group)))) + (funcall (intern (format "%s-request-replace-article" func)) + article (gnus-group-real-name group) buffer))) + +(defun gnus-request-associate-buffer (group) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-associate-buffer) + (gnus-group-real-name group)))) + +(defun gnus-request-restore-buffer (article group) + "Request a new buffer restored to the state of ARTICLE." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-restore-buffer) + article (gnus-group-real-name group) + (nth 1 gnus-command-method)))) + +(defun gnus-request-create-group (group &optional gnus-command-method args) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let ((gnus-command-method + (or gnus-command-method (gnus-find-method-for-group group)))) + (funcall (gnus-get-function gnus-command-method 'request-create-group) + (gnus-group-real-name group) (nth 1 gnus-command-method) args))) + +(defun gnus-request-delete-group (group &optional force) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-delete-group) + (gnus-group-real-name group) force (nth 1 gnus-command-method)))) + +(defun gnus-request-rename-group (group new-name) + (let ((gnus-command-method (gnus-find-method-for-group group))) + (funcall (gnus-get-function gnus-command-method 'request-rename-group) + (gnus-group-real-name group) + (gnus-group-real-name new-name) (nth 1 gnus-command-method)))) + +(defun gnus-close-backends () + ;; Send a close request to all backends that support such a request. + (let ((methods gnus-valid-select-methods) + (gnus-inhibit-demon t) + func gnus-command-method) + (while (setq gnus-command-method (pop methods)) + (when (fboundp (setq func (intern + (concat (car gnus-command-method) + "-request-close")))) + (funcall func))))) + +(defun gnus-asynchronous-p (gnus-command-method) + (let ((func (gnus-get-function gnus-command-method 'asynchronous-p t))) + (when (fboundp func) + (funcall func)))) + +(defun gnus-remove-denial (gnus-command-method) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (let* ((elem (assoc gnus-command-method gnus-opened-servers)) + (status (cadr elem))) + ;; If this hasn't been opened before, we add it to the list. + (when (eq status 'denied) + ;; Set the status of this server. + (setcar (cdr elem) 'closed)))) + +(provide 'gnus-int) + +;;; gnus-int.el ends here diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el new file mode 100644 index 0000000..f2fad66 --- /dev/null +++ b/lisp/gnus-kill.el @@ -0,0 +1,719 @@ +;;; gnus-kill.el --- kill commands for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-art) +(require 'gnus-range) + +(defcustom gnus-kill-file-mode-hook nil + "Hook for Gnus kill file mode." + :group 'gnus-score-kill + :type 'hook) + +(defcustom gnus-kill-expiry-days 7 + "*Number of days before expiring unused kill file entries." + :group 'gnus-score-kill + :group 'gnus-score-expire + :type 'integer) + +(defcustom gnus-kill-save-kill-file nil + "*If non-nil, will save kill files after processing them." + :group 'gnus-score-kill + :type 'boolean) + +(defcustom gnus-winconf-kill-file nil + "What does this do, Lars?" + :group 'gnus-score-kill + :type 'sexp) + +(defcustom gnus-kill-killed t + "*If non-nil, Gnus will apply kill files to already killed articles. +If it is nil, Gnus will never apply kill files to articles that have +already been through the scoring process, which might very well save lots +of time." + :group 'gnus-score-kill + :type 'boolean) + + + +(defmacro gnus-raise (field expression level) + `(gnus-kill ,field ,expression + (function (gnus-summary-raise-score ,level)) t)) + +(defmacro gnus-lower (field expression level) + `(gnus-kill ,field ,expression + (function (gnus-summary-raise-score (- ,level))) t)) + +;;; +;;; Gnus Kill File Mode +;;; + +(defvar gnus-kill-file-mode-map nil) + +(unless gnus-kill-file-mode-map + (gnus-define-keymap (setq gnus-kill-file-mode-map + (copy-keymap emacs-lisp-mode-map)) + "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject + "\C-c\C-k\C-a" gnus-kill-file-kill-by-author + "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread + "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref + "\C-c\C-a" gnus-kill-file-apply-buffer + "\C-c\C-e" gnus-kill-file-apply-last-sexp + "\C-c\C-c" gnus-kill-file-exit)) + +(defun gnus-kill-file-mode () + "Major mode for editing kill files. + +If you are using this mode - you probably shouldn't. Kill files +perform badly and paint with a pretty broad brush. Score files, on +the other hand, are vastly faster (40x speedup) and give you more +control over what to do. + +In addition to Emacs-Lisp Mode, the following commands are available: + +\\{gnus-kill-file-mode-map} + + A kill file contains Lisp expressions to be applied to a selected +newsgroup. The purpose is to mark articles as read on the basis of +some set of regexps. A global kill file is applied to every newsgroup, +and a local kill file is applied to a specified newsgroup. Since a +global kill file is applied to every newsgroup, for better performance +use a local one. + + A kill file can contain any kind of Emacs Lisp expressions expected +to be evaluated in the Summary buffer. Writing Lisp programs for this +purpose is not so easy because the internal working of Gnus must be +well-known. For this reason, Gnus provides a general function which +does this easily for non-Lisp programmers. + + The `gnus-kill' function executes commands available in Summary Mode +by their key sequences. `gnus-kill' should be called with FIELD, +REGEXP and optional COMMAND and ALL. FIELD is a string representing +the header field or an empty string. If FIELD is an empty string, the +entire article body is searched for. REGEXP is a string which is +compared with FIELD value. COMMAND is a string representing a valid +key sequence in Summary mode or Lisp expression. COMMAND defaults to +'(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is +executed in the Summary buffer. If the second optional argument ALL +is non-nil, the COMMAND is applied to articles which are already +marked as read or unread. Articles which are marked are skipped over +by default. + + For example, if you want to mark articles of which subjects contain +the string `AI' as read, a possible kill file may look like: + + (gnus-kill \"Subject\" \"AI\") + + If you want to mark articles with `D' instead of `X', you can use +the following expression: + + (gnus-kill \"Subject\" \"AI\" \"d\") + +In this example it is assumed that the command +`gnus-summary-mark-as-read-forward' is assigned to `d' in Summary Mode. + + It is possible to delete unnecessary headers which are marked with +`X' in a kill file as follows: + + (gnus-expunge \"X\") + + If the Summary buffer is empty after applying kill files, Gnus will +exit the selected newsgroup normally. If headers which are marked +with `D' are deleted in a kill file, it is impossible to read articles +which are marked as read in the previous Gnus sessions. Marks other +than `D' should be used for articles which should really be deleted. + +Entry to this mode calls emacs-lisp-mode-hook and +gnus-kill-file-mode-hook with no arguments, if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map gnus-kill-file-mode-map) + (set-syntax-table emacs-lisp-mode-syntax-table) + (setq major-mode 'gnus-kill-file-mode) + (setq mode-name "Kill") + (lisp-mode-variables nil) + (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) + +(defun gnus-kill-file-edit-file (newsgroup) + "Begin editing a kill file for NEWSGROUP. +If NEWSGROUP is nil, the global kill file is selected." + (interactive "sNewsgroup: ") + (let ((file (gnus-newsgroup-kill-file newsgroup))) + (gnus-make-directory (file-name-directory file)) + ;; Save current window configuration if this is first invocation. + (or (and (get-file-buffer file) + (get-buffer-window (get-file-buffer file))) + (setq gnus-winconf-kill-file (current-window-configuration))) + ;; Hack windows. + (let ((buffer (find-file-noselect file))) + (cond ((get-buffer-window buffer) + (pop-to-buffer buffer)) + ((eq major-mode 'gnus-group-mode) + (gnus-configure-windows 'group) ;Take all windows. + (pop-to-buffer buffer)) + ((eq major-mode 'gnus-summary-mode) + (gnus-configure-windows 'article) + (pop-to-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer) + (switch-to-buffer buffer)) + (t ;No good rules. + (find-file-other-window file)))) + (gnus-kill-file-mode))) + +;; Fix by Sudish Joseph . +(defun gnus-kill-set-kill-buffer () + (let* ((file (gnus-newsgroup-kill-file gnus-newsgroup-name)) + (buffer (find-file-noselect file))) + (set-buffer buffer) + (gnus-kill-file-mode) + (bury-buffer buffer))) + +(defun gnus-kill-file-enter-kill (field regexp &optional dont-move) + ;; Enter kill file entry. + ;; FIELD: String containing the name of the header field to kill. + ;; REGEXP: The string to kill. + (save-excursion + (let (string) + (unless (eq major-mode 'gnus-kill-file-mode) + (gnus-kill-set-kill-buffer)) + (unless dont-move + (goto-char (point-max))) + (insert (setq string (format "(gnus-kill %S %S)\n" field regexp))) + (gnus-kill-file-apply-string string)))) + +(defun gnus-kill-file-kill-by-subject () + "Kill by subject." + (interactive) + (gnus-kill-file-enter-kill + "Subject" + (if (vectorp gnus-current-headers) + (regexp-quote + (gnus-simplify-subject (mail-header-subject gnus-current-headers))) + "") + t)) + +(defun gnus-kill-file-kill-by-author () + "Kill by author." + (interactive) + (gnus-kill-file-enter-kill + "From" + (if (vectorp gnus-current-headers) + (regexp-quote (mail-header-from gnus-current-headers)) + "") t)) + +(defun gnus-kill-file-kill-by-thread () + "Kill by author." + (interactive) + (gnus-kill-file-enter-kill + "References" + (if (vectorp gnus-current-headers) + (regexp-quote (mail-header-id gnus-current-headers)) + ""))) + +(defun gnus-kill-file-kill-by-xref () + "Kill by Xref." + (interactive) + (let ((xref (and (vectorp gnus-current-headers) + (mail-header-xref gnus-current-headers))) + (start 0) + group) + (if xref + (while (string-match " \\([^ \t]+\\):" xref start) + (setq start (match-end 0)) + (when (not (string= + (setq group + (substring xref (match-beginning 1) (match-end 1))) + gnus-newsgroup-name)) + (gnus-kill-file-enter-kill + "Xref" (concat " " (regexp-quote group) ":") t))) + (gnus-kill-file-enter-kill "Xref" "" t)))) + +(defun gnus-kill-file-raise-followups-to-author (level) + "Raise score for all followups to the current author." + (interactive "p") + (let ((name (mail-header-from gnus-current-headers)) + string) + (save-excursion + (gnus-kill-set-kill-buffer) + (goto-char (point-min)) + (setq name (read-string (concat "Add " level + " to followup articles to: ") + (regexp-quote name))) + (setq + string + (format + "(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n" + "From" name level)) + (insert string) + (gnus-kill-file-apply-string string)) + (gnus-message + 6 "Added temporary score file entry for followups to %s." name))) + +(defun gnus-kill-file-apply-buffer () + "Apply current buffer to current newsgroup." + (interactive) + (if (and gnus-current-kill-article + (get-buffer gnus-summary-buffer)) + ;; Assume newsgroup is selected. + (gnus-kill-file-apply-string (buffer-string)) + (ding) (gnus-message 2 "No newsgroup is selected."))) + +(defun gnus-kill-file-apply-string (string) + "Apply STRING to current newsgroup." + (interactive) + (let ((string (concat "(progn \n" string "\n)"))) + (save-excursion + (save-window-excursion + (pop-to-buffer gnus-summary-buffer) + (eval (car (read-from-string string))))))) + +(defun gnus-kill-file-apply-last-sexp () + "Apply sexp before point in current buffer to current newsgroup." + (interactive) + (if (and gnus-current-kill-article + (get-buffer gnus-summary-buffer)) + ;; Assume newsgroup is selected. + (let ((string + (buffer-substring + (save-excursion (forward-sexp -1) (point)) (point)))) + (save-excursion + (save-window-excursion + (pop-to-buffer gnus-summary-buffer) + (eval (car (read-from-string string)))))) + (ding) (gnus-message 2 "No newsgroup is selected."))) + +(defun gnus-kill-file-exit () + "Save a kill file, then return to the previous buffer." + (interactive) + (save-buffer) + (let ((killbuf (current-buffer))) + ;; We don't want to return to article buffer. + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) + ;; Delete the KILL file windows. + (delete-windows-on killbuf) + ;; Restore last window configuration if available. + (when gnus-winconf-kill-file + (set-window-configuration gnus-winconf-kill-file)) + (setq gnus-winconf-kill-file nil) + ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu. + (kill-buffer killbuf))) + +;; For kill files + +(defun gnus-Newsgroup-kill-file (newsgroup) + "Return the name of a kill file for NEWSGROUP. +If NEWSGROUP is nil, return the global kill file instead." + (cond ((or (null newsgroup) + (string-equal newsgroup "")) + ;; The global kill file is placed at top of the directory. + (expand-file-name gnus-kill-file-name gnus-kill-files-directory)) + (gnus-use-long-file-name + ;; Append ".KILL" to capitalized newsgroup name. + (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup) + "." gnus-kill-file-name) + gnus-kill-files-directory)) + (t + ;; Place "KILL" under the hierarchical directory. + (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) + "/" gnus-kill-file-name) + gnus-kill-files-directory)))) + +(defun gnus-expunge (marks) + "Remove lines marked with MARKS." + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-limit-to-marks marks 'reverse))) + +(defun gnus-apply-kill-file-unless-scored () + "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." + (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) + ;; Ignores global KILL. + (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) + (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" + gnus-newsgroup-name)) + 0) + ((or (file-exists-p (gnus-newsgroup-kill-file nil)) + (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) + (gnus-apply-kill-file-internal)) + (t + 0))) + +(defun gnus-apply-kill-file-internal () + "Apply a kill file to the current newsgroup. +Returns the number of articles marked as read." + (let* ((kill-files (list (gnus-newsgroup-kill-file nil) + (gnus-newsgroup-kill-file gnus-newsgroup-name))) + (unreads (length gnus-newsgroup-unreads)) + (gnus-summary-inhibit-highlight t) + beg) + (setq gnus-newsgroup-kill-headers nil) + ;; If there are any previously scored articles, we remove these + ;; from the `gnus-newsgroup-headers' list that the score functions + ;; will see. This is probably pretty wasteful when it comes to + ;; conses, but is, I think, faster than having to assq in every + ;; single score function. + (let ((files kill-files)) + (while files + (if (file-exists-p (car files)) + (let ((headers gnus-newsgroup-headers)) + (if gnus-kill-killed + (setq gnus-newsgroup-kill-headers + (mapcar (lambda (header) (mail-header-number header)) + headers)) + (while headers + (unless (gnus-member-of-range + (mail-header-number (car headers)) + gnus-newsgroup-killed) + (push (mail-header-number (car headers)) + gnus-newsgroup-kill-headers)) + (setq headers (cdr headers)))) + (setq files nil)) + (setq files (cdr files))))) + (if (not gnus-newsgroup-kill-headers) + () + (save-window-excursion + (save-excursion + (while kill-files + (if (not (file-exists-p (car kill-files))) + () + (gnus-message 6 "Processing kill file %s..." (car kill-files)) + (find-file (car kill-files)) + (gnus-add-current-to-buffer-list) + (goto-char (point-min)) + + (if (consp (ignore-errors (read (current-buffer)))) + (gnus-kill-parse-gnus-kill-file) + (gnus-kill-parse-rn-kill-file)) + + (gnus-message + 6 "Processing kill file %s...done" (car kill-files))) + (setq kill-files (cdr kill-files))))) + + (gnus-set-mode-line 'summary) + + (if beg + (let ((nunreads (- unreads (length gnus-newsgroup-unreads)))) + (or (eq nunreads 0) + (gnus-message 6 "Marked %d articles as read" nunreads)) + nunreads) + 0)))) + +;; Parse a Gnus killfile. +(defun gnus-score-insert-help (string alist idx) + (save-excursion + (pop-to-buffer "*Score Help*") + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert string ":\n\n") + (while alist + (insert (format " %c: %s\n" (caar alist) (nth idx (car alist)))) + (setq alist (cdr alist))))) + +(defun gnus-kill-parse-gnus-kill-file () + (goto-char (point-min)) + (gnus-kill-file-mode) + (let (beg form) + (while (progn + (setq beg (point)) + (setq form (ignore-errors (read (current-buffer))))) + (unless (listp form) + (error "Illegal kill entry (possibly rn kill file?): %s" form)) + (if (or (eq (car form) 'gnus-kill) + (eq (car form) 'gnus-raise) + (eq (car form) 'gnus-lower)) + (progn + (delete-region beg (point)) + (insert (or (eval form) ""))) + (save-excursion + (set-buffer gnus-summary-buffer) + (ignore-errors (eval form))))) + (and (buffer-modified-p) + gnus-kill-save-kill-file + (save-buffer)) + (set-buffer-modified-p nil))) + +;; Parse an rn killfile. +(defun gnus-kill-parse-rn-kill-file () + (goto-char (point-min)) + (gnus-kill-file-mode) + (let ((mod-to-header + '((?a . "") + (?h . "") + (?f . "from") + (?: . "subject"))) + (com-to-com + '((?m . " ") + (?j . "X"))) + pattern modifier commands) + (while (not (eobp)) + (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)")) + () + (setq pattern (buffer-substring (match-beginning 1) (match-end 1))) + (setq modifier (if (match-beginning 2) (char-after (match-beginning 2)) + ?s)) + (setq commands (buffer-substring (match-beginning 3) (match-end 3))) + + ;; The "f:+" command marks everything *but* the matches as read, + ;; so we simply first match everything as read, and then unmark + ;; PATTERN later. + (when (string-match "\\+" commands) + (gnus-kill "from" ".") + (setq commands "m")) + + (gnus-kill + (or (cdr (assq modifier mod-to-header)) "subject") + pattern + (if (string-match "m" commands) + '(gnus-summary-mark-as-unread nil " ") + '(gnus-summary-mark-as-read nil "X")) + nil t)) + (forward-line 1)))) + +;; Kill changes and new format by suggested by JWZ and Sudish Joseph +;; . +(defun gnus-kill (field regexp &optional exe-command all silent) + "If FIELD of an article matches REGEXP, execute COMMAND. +Optional 1st argument COMMAND is default to + (gnus-summary-mark-as-read nil \"X\"). +If optional 2nd argument ALL is non-nil, articles marked are also applied to. +If FIELD is an empty string (or nil), entire article body is searched for. +COMMAND must be a lisp expression or a string representing a key sequence." + ;; We don't want to change current point nor window configuration. + (let ((old-buffer (current-buffer))) + (save-excursion + (save-window-excursion + ;; Selected window must be summary buffer to execute keyboard + ;; macros correctly. See command_loop_1. + (switch-to-buffer gnus-summary-buffer 'norecord) + (goto-char (point-min)) ;From the beginning. + (let ((kill-list regexp) + (date (current-time-string)) + (command (or exe-command '(gnus-summary-mark-as-read + nil gnus-kill-file-mark))) + kill kdate prev) + (if (listp kill-list) + ;; It is a list. + (if (not (consp (cdr kill-list))) + ;; It's on the form (regexp . date). + (if (zerop (gnus-execute field (car kill-list) + command nil (not all))) + (when (> (gnus-days-between date (cdr kill-list)) + gnus-kill-expiry-days) + (setq regexp nil)) + (setcdr kill-list date)) + (while (setq kill (car kill-list)) + (if (consp kill) + ;; It's a temporary kill. + (progn + (setq kdate (cdr kill)) + (if (zerop (gnus-execute + field (car kill) command nil (not all))) + (when (> (gnus-days-between date kdate) + gnus-kill-expiry-days) + ;; Time limit has been exceeded, so we + ;; remove the match. + (if prev + (setcdr prev (cdr kill-list)) + (setq regexp (cdr regexp)))) + ;; Successful kill. Set the date to today. + (setcdr kill date))) + ;; It's a permanent kill. + (gnus-execute field kill command nil (not all))) + (setq prev kill-list) + (setq kill-list (cdr kill-list)))) + (gnus-execute field kill-list command nil (not all)))))) + (switch-to-buffer old-buffer) + (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) + (gnus-pp-gnus-kill + (nconc (list 'gnus-kill field + (if (consp regexp) (list 'quote regexp) regexp)) + (when (or exe-command all) + (list (list 'quote exe-command))) + (if all (list t) nil)))))) + +(defun gnus-pp-gnus-kill (object) + (if (or (not (consp (nth 2 object))) + (not (consp (cdr (nth 2 object)))) + (and (eq 'quote (car (nth 2 object))) + (not (consp (cdadr (nth 2 object)))))) + (concat "\n" (gnus-prin1-to-string object)) + (save-excursion + (set-buffer (get-buffer-create "*Gnus PP*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) + (let ((klist (cadr (nth 2 object))) + (first t)) + (while klist + (insert (if first (progn (setq first nil) "") "\n ") + (gnus-prin1-to-string (car klist))) + (setq klist (cdr klist)))) + (insert ")") + (and (nth 3 object) + (insert "\n " + (if (and (consp (nth 3 object)) + (not (eq 'quote (car (nth 3 object))))) + "'" "") + (gnus-prin1-to-string (nth 3 object)))) + (when (nth 4 object) + (insert "\n t")) + (insert ")") + (prog1 + (buffer-substring (point-min) (point-max)) + (kill-buffer (current-buffer)))))) + +(defun gnus-execute-1 (function regexp form header) + (save-excursion + (let (did-kill) + (if (null header) + nil ;Nothing to do. + (if function + ;; Compare with header field. + (let (value) + (and header + (progn + (setq value (funcall function header)) + ;; Number (Lines:) or symbol must be converted to string. + (unless (stringp value) + (setq value (gnus-prin1-to-string value))) + (setq did-kill (string-match regexp value))) + (cond ((stringp form) ;Keyboard macro. + (execute-kbd-macro form)) + ((gnus-functionp form) + (funcall form)) + (t + (eval form))))) + ;; Search article body. + (let ((gnus-current-article nil) ;Save article pointer. + (gnus-last-article nil) + (gnus-break-pages nil) ;No need to break pages. + (gnus-mark-article-hook nil)) ;Inhibit marking as read. + (gnus-message + 6 "Searching for article: %d..." (mail-header-number header)) + (gnus-article-setup-buffer) + (gnus-article-prepare (mail-header-number header) t) + (when (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (setq did-kill (re-search-forward regexp nil t))) + (cond ((stringp form) ;Keyboard macro. + (execute-kbd-macro form)) + ((gnus-functionp form) + (funcall form)) + (t + (eval form))))))) + did-kill))) + +(defun gnus-execute (field regexp form &optional backward unread) + "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). +If FIELD is an empty string (or nil), entire article body is searched for. +If optional 1st argument BACKWARD is non-nil, do backward instead. +If optional 2nd argument UNREAD is non-nil, articles which are +marked as read or ticked are ignored." + (save-excursion + (let ((killed-no 0) + function article header) + (cond + ;; Search body. + ((or (null field) + (string-equal field "")) + (setq function nil)) + ;; Get access function of header field. + ((fboundp + (setq function + (intern-soft + (concat "mail-header-" (downcase field))))) + (setq function `(lambda (h) (,function h)))) + ;; Signal error. + (t + (error "Unknown header field: \"%s\"" field))) + ;; Starting from the current article. + (while (or + ;; First article. + (and (not article) + (setq article (gnus-summary-article-number))) + ;; Find later articles. + (setq article + (gnus-summary-search-forward unread nil backward))) + (and (or (null gnus-newsgroup-kill-headers) + (memq article gnus-newsgroup-kill-headers)) + (vectorp (setq header (gnus-summary-article-header article))) + (gnus-execute-1 function regexp form header) + (setq killed-no (1+ killed-no)))) + ;; Return the number of killed articles. + killed-no))) + +;;;###autoload +(defalias 'gnus-batch-kill 'gnus-batch-score) +;;;###autoload +(defun gnus-batch-score () + "Run batched scoring. +Usage: emacs -batch -l gnus -f gnus-batch-score ... +Newsgroups is a list of strings in Bnews format. If you want to score +the comp hierarchy, you'd say \"comp.all\". If you would not like to +score the alt hierarchy, you'd say \"!alt.all\"." + (interactive) + (let* ((gnus-newsrc-options-n + (gnus-newsrc-parse-options + (concat "options -n " + (mapconcat 'identity command-line-args-left " ")))) + (gnus-expert-user t) + (nnmail-spool-file nil) + (gnus-use-dribble-file nil) + (gnus-batch-mode t) + group newsrc entry + ;; Disable verbose message. + gnus-novice-user gnus-large-newsgroup + gnus-options-subscribe gnus-auto-subscribed-groups + gnus-options-not-subscribe) + ;; Eat all arguments. + (setq command-line-args-left nil) + (gnus-slave) + ;; Apply kills to specified newsgroups in command line arguments. + (setq newsrc (cdr gnus-newsrc-alist)) + (while (setq group (car (pop newsrc))) + (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed) + (and (car entry) + (or (eq (car entry) t) + (not (zerop (car entry))))) + ;;(eq (gnus-matches-options-n group) 'subscribe) + ) + (gnus-summary-read-group group nil t nil t) + (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) + (gnus-summary-exit)))) + ;; Exit Emacs. + (switch-to-buffer gnus-group-buffer) + (gnus-group-save-newsrc))) + +(provide 'gnus-kill) + +;;; gnus-kill.el ends here diff --git a/lisp/gnus-load.el b/lisp/gnus-load.el new file mode 100644 index 0000000..978f272 --- /dev/null +++ b/lisp/gnus-load.el @@ -0,0 +1,103 @@ +;;; gnus-load.el --- automatically extracted custom dependencies +;; +;;; Code: + +(put 'nnmail 'custom-loads '("nnmail")) +(put 'gnus-article-emphasis 'custom-loads '("gnus-art")) +(put 'gnus-article-headers 'custom-loads '("gnus-sum" "gnus-art")) +(put 'nnmail-procmail 'custom-loads '("nnmail")) +(put 'gnus-score-kill 'custom-loads '("gnus-kill")) +(put 'gnus-visual 'custom-loads '("smiley" "gnus" "gnus-picon" "gnus-art" "earcon")) +(put 'gnus-score-expire 'custom-loads '("gnus-score" "gnus-kill")) +(put 'gnus-summary-maneuvering 'custom-loads '("gnus-sum")) +(put 'gnus-start 'custom-loads '("gnus" "gnus-util" "gnus-start" "gnus-int" "gnus-group")) +(put 'gnus-extract-view 'custom-loads '("gnus-uu" "gnus-sum")) +(put 'gnus-various 'custom-loads '("gnus-sum")) +(put 'gnus-article-washing 'custom-loads '("gnus-art")) +(put 'gnus-score-files 'custom-loads '("gnus-score")) +(put 'message-news 'custom-loads '("message")) +(put 'gnus-thread 'custom-loads '("gnus-sum")) +(put 'languages 'custom-loads '("cus-edit")) +(put 'development 'custom-loads '("cus-edit")) +(put 'gnus-treading 'custom-loads '("gnus-sum")) +(put 'nnmail-various 'custom-loads '("nnmail")) +(put 'extensions 'custom-loads '("wid-edit")) +(put 'message-various 'custom-loads '("message")) +(put 'gnus-summary-exit 'custom-loads '("gnus-sum")) +(put 'news 'custom-loads '("message" "gnus")) +(put 'gnus 'custom-loads '("nnmail" "gnus" "gnus-win" "gnus-uu" "gnus-eform" "gnus-dup" "gnus-demon" "gnus-cache" "gnus-async" "gnus-art")) +(put 'gnus-summary-visual 'custom-loads '("gnus-sum")) +(put 'gnus-group-listing 'custom-loads '("gnus-group")) +(put 'gnus-score 'custom-loads '("gnus" "gnus-nocem")) +(put 'gnus-group-select 'custom-loads '("gnus-sum")) +(put 'message-buffers 'custom-loads '("message")) +(put 'gnus-threading 'custom-loads '("gnus-sum")) +(put 'gnus-score-decay 'custom-loads '("gnus-score")) +(put 'help 'custom-loads '("cus-edit")) +(put 'gnus-nocem 'custom-loads '("gnus-nocem")) +(put 'gnus-cite 'custom-loads '("gnus-cite")) +(put 'gnus-demon 'custom-loads '("gnus-demon")) +(put 'gnus-message 'custom-loads '("message")) +(put 'gnus-score-default 'custom-loads '("gnus-sum" "gnus-score")) +(put 'nnmail-duplicate 'custom-loads '("nnmail")) +(put 'message-interface 'custom-loads '("message")) +(put 'nnmail-files 'custom-loads '("nnmail")) +(put 'gnus-edit-form 'custom-loads '("gnus-eform")) +(put 'emacs 'custom-loads '("cus-edit")) +(put 'gnus-summary-mail 'custom-loads '("gnus-sum")) +(put 'gnus-topic 'custom-loads '("gnus-topic")) +(put 'wp 'custom-loads '("cus-edit")) +(put 'gnus-summary-choose 'custom-loads '("gnus-sum")) +(put 'widget-browse 'custom-loads '("wid-browse")) +(put 'external 'custom-loads '("cus-edit")) +(put 'message-headers 'custom-loads '("message")) +(put 'message-forwarding 'custom-loads '("message")) +(put 'message-faces 'custom-loads '("message")) +(put 'environment 'custom-loads '("cus-edit")) +(put 'gnus-article-mime 'custom-loads '("gnus-sum" "gnus-art")) +(put 'gnus-duplicate 'custom-loads '("gnus-dup")) +(put 'nnmail-retrieve 'custom-loads '("nnmail")) +(put 'widgets 'custom-loads '("wid-edit" "wid-browse")) +(put 'earcon 'custom-loads '("earcon")) +(put 'hypermedia 'custom-loads '("wid-edit")) +(put 'gnus-group-levels 'custom-loads '("gnus-group")) +(put 'gnus-summary-format 'custom-loads '("gnus-sum")) +(put 'gnus-files 'custom-loads '("nnmail" "gnus")) +(put 'gnus-windows 'custom-loads '("gnus-win")) +(put 'gnus-article-buttons 'custom-loads '("gnus-art")) +(put 'gnus-summary 'custom-loads '("gnus" "gnus-sum")) +(put 'gnus-article-hiding 'custom-loads '("gnus-sum" "gnus-art")) +(put 'gnus-group 'custom-loads '("gnus" "gnus-topic")) +(put 'gnus-article-various 'custom-loads '("gnus-sum" "gnus-art")) +(put 'gnus-summary-marks 'custom-loads '("gnus-sum")) +(put 'gnus-article-saving 'custom-loads '("gnus-art")) +(put 'nnmail-expire 'custom-loads '("nnmail")) +(put 'message-mail 'custom-loads '("message")) +(put 'faces 'custom-loads '("wid-edit" "cus-edit" "message" "gnus")) +(put 'gnus-summary-various 'custom-loads '("gnus-sum")) +(put 'applications 'custom-loads '("cus-edit")) +(put 'gnus-extract-archive 'custom-loads '("gnus-uu")) +(put 'message 'custom-loads '("message")) +(put 'message-sending 'custom-loads '("message")) +(put 'editing 'custom-loads '("cus-edit")) +(put 'gnus-score-adapt 'custom-loads '("gnus-score")) +(put 'message-insertion 'custom-loads '("message")) +(put 'gnus-extract-post 'custom-loads '("gnus-uu")) +(put 'mail 'custom-loads '("message" "gnus")) +(put 'gnus-summary-sort 'custom-loads '("gnus-sum")) +(put 'customize 'custom-loads '("wid-edit" "custom" "cus-face" "cus-edit")) +(put 'nnmail-split 'custom-loads '("nnmail")) +(put 'gnus-asynchronous 'custom-loads '("gnus-async")) +(put 'gnus-article-highlight 'custom-loads '("gnus-art")) +(put 'gnus-extract 'custom-loads '("gnus-uu")) +(put 'gnus-article 'custom-loads '("gnus-cite" "gnus-art")) +(put 'gnus-group-foreign 'custom-loads '("gnus-group")) +(put 'programming 'custom-loads '("cus-edit")) +(put 'nnmail-prepare 'custom-loads '("nnmail")) +(put 'picons 'custom-loads '("gnus-picon")) +(put 'gnus-article-signature 'custom-loads '("gnus-art")) +(put 'gnus-group-various 'custom-loads '("gnus-group")) + +(provide 'gnus-load) + +;;; gnus-load.el ends here diff --git a/lisp/gnus-logic.el b/lisp/gnus-logic.el new file mode 100644 index 0000000..106fde5 --- /dev/null +++ b/lisp/gnus-logic.el @@ -0,0 +1,229 @@ +;;; gnus-logic.el --- advanced scoring code for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-score) +(require 'gnus-util) + +;;; Internal variables. + +(defvar gnus-advanced-headers nil) + +;; To avoid having 8-bit characters in the source file. +(defvar gnus-advanced-not (intern (format "%c" 172))) + +(defconst gnus-advanced-index + ;; Name to index alist. + '(("number" 0 gnus-advanced-integer) + ("subject" 1 gnus-advanced-string) + ("from" 2 gnus-advanced-string) + ("date" 3 gnus-advanced-date) + ("message-id" 4 gnus-advanced-string) + ("references" 5 gnus-advanced-string) + ("chars" 6 gnus-advanced-integer) + ("lines" 7 gnus-advanced-integer) + ("xref" 8 gnus-advanced-string) + ("head" nil gnus-advanced-body) + ("body" nil gnus-advanced-body) + ("all" nil gnus-advanced-body))) + +(eval-and-compile + (autoload 'parse-time-string "parse-time")) + +(defun gnus-score-advanced (rule &optional trace) + "Apply advanced scoring RULE to all the articles in the current group." + (let ((headers gnus-newsgroup-headers) + gnus-advanced-headers score) + (while (setq gnus-advanced-headers (pop headers)) + (when (gnus-advanced-score-rule (car rule)) + ;; This rule was successful, so we add the score to + ;; this article. + (if (setq score (assq (mail-header-number gnus-advanced-headers) + gnus-newsgroup-scored)) + (setcdr score + (+ (cdr score) + (or (nth 1 rule) + gnus-score-interactive-default-score))) + (push (cons (mail-header-number gnus-advanced-headers) + (or (nth 1 rule) + gnus-score-interactive-default-score)) + gnus-newsgroup-scored) + (when trace + (push (cons "A file" rule) + gnus-score-trace))))))) + +(defun gnus-advanced-score-rule (rule) + "Apply RULE to `gnus-advanced-headers'." + (let ((type (car rule))) + (cond + ;; "And" rule. + ((or (eq type '&) (eq type 'and)) + (pop rule) + (if (not rule) + t ; Empty rule is true. + (while (and rule + (gnus-advanced-score-rule (car rule))) + (pop rule)) + ;; If all the rules were true, then `rule' should be nil. + (not rule))) + ;; "Or" rule. + ((or (eq type '|) (eq type 'or)) + (pop rule) + (if (not rule) + nil + (while (and rule + (not (gnus-advanced-score-rule (car rule)))) + (pop rule)) + ;; If one of the rules returned true, then `rule' should be non-nil. + rule)) + ;; "Not" rule. + ((or (eq type '!) (eq type 'not) (eq type gnus-advanced-not)) + (not (gnus-advanced-score-rule (nth 1 rule)))) + ;; This is a `1-'-type redirection rule. + ((and (symbolp type) + (string-match "^[0-9]+-$\\|^\\^+$" (symbol-name type))) + (let ((gnus-advanced-headers + (gnus-parent-headers + gnus-advanced-headers + (if (string-match "^\\([0-9]+\\)-$" (symbol-name type)) + ;; 1- type redirection. + (string-to-number + (substring (symbol-name type) + (match-beginning 0) (match-end 0))) + ;; ^^^ type redirection. + (length (symbol-name type)))))) + (when gnus-advanced-headers + (gnus-advanced-score-rule (nth 1 rule))))) + ;; Plain scoring rule. + ((stringp type) + (gnus-advanced-score-article rule)) + ;; Bug-out time! + (t + (error "Unknown advanced score type: %s" rule))))) + +(defun gnus-advanced-score-article (rule) + ;; `rule' is a semi-normal score rule, so we find out + ;; what function that's supposed to do the actual + ;; processing. + (let* ((header (car rule)) + (func (assoc (downcase header) gnus-advanced-index))) + (if (not func) + (error "No such header: %s" rule) + ;; Call the score function. + (funcall (caddr func) (or (cadr func) header) + (cadr rule) (caddr rule))))) + +(defun gnus-advanced-string (index match type) + "See whether string MATCH of TYPE matches `gnus-advanced-headers' in INDEX." + (let* ((type (or type 's)) + (case-fold-search (not (eq (downcase (symbol-name type)) + (symbol-name type)))) + (header (aref gnus-advanced-headers index))) + (cond + ((memq type '(r R regexp Regexp)) + (string-match match header)) + ((memq type '(s S string String)) + (string-match (regexp-quote match) header)) + ((memq type '(e E exact Exact)) + (string= match header)) + ((memq type '(f F fuzzy Fuzzy)) + (string-match (regexp-quote (gnus-simplify-subject-fuzzy match)) + header)) + (t + (error "No such string match type: %s" type))))) + +(defun gnus-advanced-integer (index match type) + (if (not (memq type '(< > <= >= =))) + (error "No such integer score type: %s" type) + (funcall type match (or (aref gnus-advanced-headers index) 0)))) + +(defun gnus-advanced-date (index match type) + (let ((date (encode-time (parse-time-string + (aref gnus-advanced-headers index)))) + (match (encode-time (parse-time-string match)))) + (cond + ((eq type 'at) + (equal date match)) + ((eq type 'before) + (gnus-time-less match date)) + ((eq type 'after) + (gnus-time-less date match)) + (t + (error "No such date score type: %s" type))))) + +(defun gnus-advanced-body (header match type) + (when (string= header "all") + (setq header "article")) + (save-excursion + (set-buffer nntp-server-buffer) + (let* ((request-func (cond ((string= "head" header) + 'gnus-request-head) + ((string= "body" header) + 'gnus-request-body) + (t 'gnus-request-article))) + ofunc article) + ;; Not all backends support partial fetching. In that case, + ;; we just fetch the entire article. + (unless (gnus-check-backend-function + (intern (concat "request-" header)) + gnus-newsgroup-name) + (setq ofunc request-func) + (setq request-func 'gnus-request-article)) + (setq article (mail-header-number gnus-advanced-headers)) + (gnus-message 7 "Scoring article %s..." article) + (when (funcall request-func article gnus-newsgroup-name) + (goto-char (point-min)) + ;; If just parts of the article is to be searched and the + ;; backend didn't support partial fetching, we just narrow + ;; to the relevant parts. + (when ofunc + (if (eq ofunc 'gnus-request-head) + (narrow-to-region + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) + (let* ((case-fold-search (not (eq (downcase (symbol-name type)) + (symbol-name type)))) + (search-func + (cond ((memq type '(r R regexp Regexp)) + 're-search-forward) + ((memq type '(s S string String)) + 'search-forward) + (t + (error "Illegal match type: %s" type))))) + (goto-char (point-min)) + (prog1 + (funcall search-func match nil t) + (widen))))))) + +(provide 'gnus-logic) + +;;; gnus-logic.el ends here. diff --git a/lisp/gnus-mh.el b/lisp/gnus-mh.el new file mode 100644 index 0000000..0cf74b1 --- /dev/null +++ b/lisp/gnus-mh.el @@ -0,0 +1,105 @@ +;;; gnus-mh.el --- mh-e interface for Gnus +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Send mail using mh-e. + +;; The following mh-e interface is all cooperative works of +;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP +;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki +;; SHINGU). + +;;; Code: + +(require 'gnus) +(require 'mh-e) +(require 'mh-comp) +(require 'gnus-msg) +(require 'gnus-sum) + +(defun gnus-summary-save-article-folder (&optional arg) + "Append the current article to an mh folder. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (let ((gnus-default-article-saver 'gnus-summary-save-in-folder)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-in-folder (&optional folder) + "Save this article to MH folder (using `rcvstore' in MH library). +Optional argument FOLDER specifies folder name." + ;; Thanks to yuki@flab.Fujitsu.JUNET and ohm@kaba.junet. + (mh-find-path) + (let ((folder + (cond ((and (eq folder 'default) + gnus-newsgroup-last-folder) + gnus-newsgroup-last-folder) + (folder folder) + (t (mh-prompt-for-folder + "Save article in" + (funcall gnus-folder-save-name gnus-newsgroup-name + gnus-current-headers gnus-newsgroup-last-folder) + t)))) + (errbuf (get-buffer-create " *Gnus rcvstore*")) + ;; Find the rcvstore program. + (exec-path (if mh-lib (cons mh-lib exec-path) exec-path))) + (gnus-eval-in-buffer-window gnus-original-article-buffer + (save-restriction + (widen) + (unwind-protect + (call-process-region + (point-min) (point-max) "rcvstore" nil errbuf nil folder) + (set-buffer errbuf) + (if (zerop (buffer-size)) + (message "Article saved in folder: %s" folder) + (message "%s" (buffer-string))) + (kill-buffer errbuf)))) + (setq gnus-newsgroup-last-folder folder))) + +(defun gnus-Folder-save-name (newsgroup headers &optional last-folder) + "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER. +If variable `gnus-use-long-file-name' is nil, it is +News.group. +Otherwise, it is like +news/group." + (or last-folder + (concat "+" + (if gnus-use-long-file-name + (gnus-capitalize-newsgroup newsgroup) + (gnus-newsgroup-directory-form newsgroup))))) + +(defun gnus-folder-save-name (newsgroup headers &optional last-folder) + "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER. +If variable `gnus-use-long-file-name' is nil, it is +news.group. +Otherwise, it is like +news/group." + (or last-folder + (concat "+" + (if gnus-use-long-file-name + newsgroup + (gnus-newsgroup-directory-form newsgroup))))) + +(provide 'gnus-mh) + +;;; gnus-mh.el ends here diff --git a/lisp/gnus-move.el b/lisp/gnus-move.el new file mode 100644 index 0000000..f00fb3b --- /dev/null +++ b/lisp/gnus-move.el @@ -0,0 +1,178 @@ +;;; gnus-move.el --- commands for moving Gnus from one server to another +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-start) +(require 'gnus-int) +(require 'gnus-range) + +;;; +;;; Moving by comparing Message-ID's. +;;; + +;;;###autoload +(defun gnus-change-server (from-server to-server) + "Move from FROM-SERVER to TO-SERVER. +Update the .newsrc.eld file to reflect the change of nntp server." + (interactive + (list gnus-select-method (gnus-read-method "Move to method: "))) + + ;; First start Gnus. + (let ((gnus-activate-level 0) + (nnmail-spool-file nil)) + (gnus)) + + (save-excursion + ;; Go through all groups and translate. + (let ((newsrc gnus-newsrc-alist) + (nntp-nov-gap nil) + info) + (while (setq info (pop newsrc)) + (when (gnus-group-native-p (gnus-info-group info)) + (gnus-move-group-to-server info from-server to-server)))))) + +(defun gnus-move-group-to-server (info from-server to-server) + "Move group INFO from FROM-SERVER to TO-SERVER." + (let ((group (gnus-info-group info)) + to-active hashtb type mark marks + to-article to-reads to-marks article + act-articles) + (gnus-message 7 "Translating %s..." group) + (when (gnus-request-group group nil to-server) + (setq to-active (gnus-parse-active) + hashtb (gnus-make-hashtable 1024) + act-articles (gnus-uncompress-range to-active)) + ;; Fetch the headers from the `to-server'. + (when (and to-active + act-articles + (setq type (gnus-retrieve-headers + act-articles + group to-server))) + ;; Convert HEAD headers. I don't care. + (when (eq type 'headers) + (nnvirtual-convert-headers)) + ;; Create a mapping from Message-ID to article number. + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while (looking-at + "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") + (gnus-sethash + (buffer-substring (match-beginning 1) (match-end 1)) + (read (current-buffer)) + hashtb) + (forward-line 1)) + ;; Then we read the headers from the `from-server'. + (when (and (gnus-request-group group nil from-server) + (gnus-active group) + (setq type (gnus-retrieve-headers + (gnus-uncompress-range + (gnus-active group)) + group from-server))) + ;; Make it easier to map marks. + (let ((mark-lists (gnus-info-marks info)) + ms type m) + (while mark-lists + (setq type (caar mark-lists) + ms (gnus-uncompress-range (cdr (pop mark-lists)))) + (while ms + (if (setq m (assq (car ms) marks)) + (setcdr m (cons type (cdr m))) + (push (list (car ms) type) marks)) + (pop ms)))) + ;; Convert. + (when (eq type 'headers) + (nnvirtual-convert-headers)) + ;; Go through the headers and map away. + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while (looking-at + "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") + (setq to-article + (gnus-gethash + (buffer-substring (match-beginning 1) (match-end 1)) + hashtb)) + ;; Add this article to the list of read articles. + (push to-article to-reads) + ;; See if there are any marks and then add them. + (when (setq mark (assq (read (current-buffer)) marks)) + (setq marks (delq mark marks)) + (setcar mark to-article) + (push mark to-marks)) + (forward-line 1)) + ;; Now we know what the read articles are and what the + ;; article marks are. We transform the information + ;; into the Gnus info format. + (setq to-reads + (gnus-range-add + (gnus-compress-sequence (and to-reads (sort to-reads '<)) t) + (cons 1 (1- (car to-active))))) + (gnus-info-set-read info to-reads) + ;; Do the marks. I'm sure y'all understand what's + ;; going on down below, so I won't bother with any + ;; further comments. + (let ((mlists gnus-article-mark-lists) + lists ms a) + (while mlists + (push (list (cdr (pop mlists))) lists)) + (while (setq ms (pop marks)) + (setq article (pop ms)) + (while ms + (setcdr (setq a (assq (pop ms) lists)) + (cons article (cdr a))))) + (setq a lists) + (while a + (setcdr (car a) (gnus-compress-sequence + (and (cdar a) (sort (cdar a) '<)))) + (pop a)) + (gnus-info-set-marks info lists t))))) + (gnus-message 7 "Translating %s...done" group))) + +(defun gnus-group-move-group-to-server (info from-server to-server) + "Move the group on the current line from FROM-SERVER to TO-SERVER." + (interactive + (let ((info (gnus-get-info (gnus-group-group-name)))) + (list info (gnus-find-method-for-group (gnus-info-group info)) + (gnus-read-method (format "Move group %s to method: " + (gnus-info-group info)))))) + (save-excursion + (gnus-move-group-to-server info from-server to-server) + ;; We have to update the group info to point use the right server. + (gnus-info-set-method info to-server t) + ;; We also have to change the name of the group and stuff. + (let* ((group (gnus-info-group info)) + (new-name (gnus-group-prefixed-name + (gnus-group-real-name group) to-server))) + (gnus-info-set-group info new-name) + (gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb) + gnus-newsrc-hashtb) + (gnus-sethash group nil gnus-newsrc-hashtb)))) + +(provide 'gnus-move) + +;;; gnus-move.el ends here diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el new file mode 100644 index 0000000..12f06ae --- /dev/null +++ b/lisp/gnus-msg.el @@ -0,0 +1,1063 @@ +;;; gnus-msg.el --- mail and post interface for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-ems) +(require 'message) +(require 'gnus-art) + +;; Added by Sudish Joseph . +(defvar gnus-post-method nil + "*Preferred method for posting USENET news. +If this variable is nil, Gnus will use the current method to decide +which method to use when posting. If it is non-nil, it will override +the current method. This method will not be used in mail groups and +the like, only in \"real\" newsgroups. + +The value must be a valid method as discussed in the documentation of +`gnus-select-method'. It can also be a list of methods. If that is +the case, the user will be queried for what select method to use when +posting.") + +(defvar gnus-outgoing-message-group nil + "*All outgoing messages will be put in this group. +If you want to store all your outgoing mail and articles in the group +\"nnml:archive\", you set this variable to that value. This variable +can also be a list of group names. + +If you want to have greater control over what group to put each +message in, you can set this variable to a function that checks the +current newsgroup name and then returns a suitable group name (or list +of names).") + +(defvar gnus-mailing-list-groups nil + "*Regexp matching groups that are really mailing lists. +This is useful when you're reading a mailing list that has been +gatewayed to a newsgroup, and you want to followup to an article in +the group.") + +(defvar gnus-add-to-list nil + "*If non-nil, add a `to-list' parameter automatically.") + +(defvar gnus-sent-message-ids-file + (nnheader-concat gnus-directory "Sent-Message-IDs") + "File where Gnus saves a cache of sent message ids.") + +(defvar gnus-sent-message-ids-length 1000 + "The number of sent Message-IDs to save.") + +(defvar gnus-crosspost-complaint + "Hi, + +You posted the article below with the following Newsgroups header: + +Newsgroups: %s + +The %s group, at least, was an inappropriate recipient +of this message. Please trim your Newsgroups header to exclude this +group before posting in the future. + +Thank you. + +" + "Format string to be inserted when complaining about crossposts. +The first %s will be replaced by the Newsgroups header; +the second with the current group name.") + +(defvar gnus-message-setup-hook nil + "Hook run after setting up a message buffer.") + +;;; Internal variables. + +(defvar gnus-message-buffer "*Mail Gnus*") +(defvar gnus-article-copy nil) +(defvar gnus-last-posting-server nil) +(defvar gnus-message-group-art nil) + +(defconst gnus-bug-message + "Sending a bug report to the Gnus Towers. +======================================== + +The buffer below is a mail buffer. When you press `C-c C-c', it will +be sent to the Gnus Bug Exterminators. + +At the bottom of the buffer you'll see lots of variable settings. +Please do not delete those. They will tell the Bug People what your +environment is, so that it will be easier to locate the bugs. + +If you have found a bug that makes Emacs go \"beep\", set +debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') +and include the backtrace in your bug report. + +Please describe the bug in annoying, painstaking detail. + +Thank you for your help in stamping out bugs. +") + +(eval-and-compile + (autoload 'gnus-uu-post-news "gnus-uu" nil t) + (autoload 'news-setup "rnewspost") + (autoload 'news-reply-mode "rnewspost") + (autoload 'rmail-dont-reply-to "mail-utils") + (autoload 'rmail-output "rmailout")) + + +;;; +;;; Gnus Posting Functions +;;; + +(gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) + "p" gnus-summary-post-news + "f" gnus-summary-followup + "F" gnus-summary-followup-with-original + "c" gnus-summary-cancel-article + "s" gnus-summary-supersede-article + "r" gnus-summary-reply + "R" gnus-summary-reply-with-original + "w" gnus-summary-wide-reply + "W" gnus-summary-wide-reply-with-original + "n" gnus-summary-followup-to-mail + "N" gnus-summary-followup-to-mail-with-original + "m" gnus-summary-mail-other-window + "u" gnus-uu-post-news + "\M-c" gnus-summary-mail-crosspost-complaint + "om" gnus-summary-mail-forward + "op" gnus-summary-post-forward + "Om" gnus-uu-digest-mail-forward + "Op" gnus-uu-digest-post-forward) + +(gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) + "b" gnus-summary-resend-bounced-mail + ;; "c" gnus-summary-send-draft + "r" gnus-summary-resend-message) + +;;; Internal functions. + +(defvar gnus-article-reply nil) +(defmacro gnus-setup-message (config &rest forms) + (let ((winconf (make-symbol "gnus-setup-message-winconf")) + (buffer (make-symbol "gnus-setup-message-buffer")) + (article (make-symbol "gnus-setup-message-article"))) + `(let ((,winconf (current-window-configuration)) + (,buffer (buffer-name (current-buffer))) + (,article (and gnus-article-reply (gnus-summary-article-number))) + (message-header-setup-hook + (copy-sequence message-header-setup-hook))) + (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) + (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) + (unwind-protect + (progn + ,@forms) + (gnus-inews-add-send-actions ,winconf ,buffer ,article) + (setq gnus-message-buffer (current-buffer)) + (set (make-local-variable 'gnus-message-group-art) + (cons ,gnus-newsgroup-name ,article)) + (make-local-variable 'gnus-newsgroup-name) + (run-hooks 'gnus-message-setup-hook)) + (gnus-configure-windows ,config t) + (set-buffer-modified-p nil)))) + +(defun gnus-inews-add-send-actions (winconf buffer article) + (make-local-hook 'message-sent-hook) + (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) + (setq message-post-method + `(lambda (arg) + (gnus-post-method arg ,gnus-newsgroup-name))) + (setq message-newsreader (setq message-mailer (gnus-extended-version))) + (message-add-action + `(set-window-configuration ,winconf) 'exit 'postpone 'kill) + (message-add-action + `(when (buffer-name (get-buffer ,buffer)) + (save-excursion + (set-buffer (get-buffer ,buffer)) + ,(when article + `(gnus-summary-mark-article-as-replied ,article)))) + 'send)) + +(put 'gnus-setup-message 'lisp-indent-function 1) +(put 'gnus-setup-message 'edebug-form-spec '(form body)) + +;;; Post news commands of Gnus group mode and summary mode + +(defun gnus-group-mail () + "Start composing a mail." + (interactive) + (gnus-setup-message 'message + (message-mail))) + +(defun gnus-group-post-news (&optional arg) + "Start composing a news message. +If ARG, post to the group under point. +If ARG is 1, prompt for a group name." + (interactive "P") + ;; Bind this variable here to make message mode hooks + ;; work ok. + (let ((gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Newsgroup: " gnus-active-hashtb nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + ""))) + (gnus-post-news 'post gnus-newsgroup-name))) + +(defun gnus-summary-post-news () + "Start composing a news message." + (interactive) + (gnus-set-global-variables) + (gnus-post-news 'post gnus-newsgroup-name)) + +(defun gnus-summary-followup (yank &optional force-news) + "Compose a followup to an article. +If prefix argument YANK is non-nil, original article is yanked automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-set-global-variables) + (when yank + (gnus-summary-goto-subject (car yank))) + (save-window-excursion + (gnus-summary-select-article)) + (let ((headers (gnus-summary-article-header (gnus-summary-article-number))) + (gnus-newsgroup-name gnus-newsgroup-name)) + ;; Send a followup. + (gnus-post-news nil gnus-newsgroup-name + headers gnus-article-buffer + yank nil force-news))) + +(defun gnus-summary-followup-with-original (n &optional force-news) + "Compose a followup to an article and include the original article." + (interactive "P") + (gnus-summary-followup (gnus-summary-work-articles n) force-news)) + +(defun gnus-summary-followup-to-mail (&optional arg) + "Followup to the current mail message via news." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-followup arg t)) + +(defun gnus-summary-followup-to-mail-with-original (&optional arg) + "Followup to the current mail message via news." + (interactive "P") + (gnus-summary-followup (gnus-summary-work-articles arg) t)) + +(defun gnus-inews-yank-articles (articles) + (let (beg article) + (message-goto-body) + (while (setq article (pop articles)) + (save-window-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-select-article nil nil nil article) + (gnus-summary-remove-process-mark article)) + (gnus-copy-article-buffer) + (let ((message-reply-buffer gnus-article-copy) + (message-reply-headers gnus-current-headers)) + (message-yank-original) + (setq beg (or beg (mark t)))) + (when articles + (insert "\n"))) + (push-mark) + (goto-char beg))) + +(defun gnus-summary-cancel-article (n) + "Cancel an article you posted." + (interactive "P") + (gnus-set-global-variables) + (let ((articles (gnus-summary-work-articles n)) + (message-post-method + `(lambda (arg) + (gnus-post-method nil ,gnus-newsgroup-name))) + article) + (while (setq article (pop articles)) + (when (gnus-summary-select-article t nil nil article) + (when (gnus-eval-in-buffer-window gnus-original-article-buffer + (message-cancel-news)) + (gnus-summary-mark-as-read article gnus-canceled-mark) + (gnus-cache-remove-article 1)) + (gnus-article-hide-headers-if-wanted)) + (gnus-summary-remove-process-mark article)))) + +(defun gnus-summary-supersede-article () + "Compose an article that will supersede a previous article. +This is done simply by taking the old article and adding a Supersedes +header line with the old Message-ID." + (interactive) + (gnus-set-global-variables) + (let ((article (gnus-summary-article-number))) + (gnus-setup-message 'reply-yank + (gnus-summary-select-article t) + (set-buffer gnus-original-article-buffer) + (message-supersede) + (push + `((lambda () + (when (buffer-name (get-buffer ,gnus-summary-buffer)) + (save-excursion + (set-buffer (get-buffer ,gnus-summary-buffer)) + (gnus-cache-possibly-remove-article ,article nil nil nil t) + (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) + message-send-actions)))) + + + +(defun gnus-copy-article-buffer (&optional article-buffer) + ;; make a copy of the article buffer with all text properties removed + ;; this copy is in the buffer gnus-article-copy. + ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used + ;; this buffer should be passed to all mail/news reply/post routines. + (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) + (buffer-disable-undo gnus-article-copy) + (or (memq gnus-article-copy gnus-buffer-list) + (push gnus-article-copy gnus-buffer-list)) + (let ((article-buffer (or article-buffer gnus-article-buffer)) + end beg contents) + (if (not (and (get-buffer article-buffer) + (buffer-name (get-buffer article-buffer)))) + (error "Can't find any article buffer") + (save-excursion + (set-buffer article-buffer) + (save-restriction + ;; Copy over the (displayed) article buffer, delete + ;; hidden text and remove text properties. + (widen) + (copy-to-buffer gnus-article-copy (point-min) (point-max)) + (set-buffer gnus-article-copy) + (gnus-article-delete-text-of-type 'annotation) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next) + (insert + (prog1 + (format "%s" (buffer-string)) + (erase-buffer))) + ;; Find the original headers. + (set-buffer gnus-original-article-buffer) + (goto-char (point-min)) + (while (looking-at message-unix-mail-delimiter) + (forward-line 1)) + (setq beg (point)) + (setq end (or (search-forward "\n\n" nil t) (point))) + ;; Delete the headers from the displayed articles. + (set-buffer gnus-article-copy) + (delete-region (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point))) + ;; Insert the original article headers. + (insert-buffer-substring gnus-original-article-buffer beg end) + (gnus-article-decode-rfc1522))) + gnus-article-copy))) + +(defun gnus-post-news (post &optional group header article-buffer yank subject + force-news) + (when article-buffer + (gnus-copy-article-buffer)) + (let ((gnus-article-reply article-buffer) + (add-to-list gnus-add-to-list)) + (gnus-setup-message (cond (yank 'reply-yank) + (article-buffer 'reply) + (t 'message)) + (let* ((group (or group gnus-newsgroup-name)) + (pgroup group) + to-address to-group mailing-list to-list + newsgroup-p) + (when group + (setq to-address (gnus-group-find-parameter group 'to-address) + to-group (gnus-group-find-parameter group 'to-group) + to-list (gnus-group-find-parameter group 'to-list) + newsgroup-p (gnus-group-find-parameter group 'newsgroup) + mailing-list (when gnus-mailing-list-groups + (string-match gnus-mailing-list-groups group)) + group (gnus-group-real-name group))) + (if (or (and to-group + (gnus-news-group-p to-group)) + newsgroup-p + force-news + (and (gnus-news-group-p + (or pgroup gnus-newsgroup-name) + (if header (mail-header-number header) + gnus-current-article)) + (not mailing-list) + (not to-list) + (not to-address))) + ;; This is news. + (if post + (message-news (or to-group group)) + (set-buffer gnus-article-copy) + (message-followup (if (or newsgroup-p force-news) nil to-group))) + ;; The is mail. + (if post + (progn + (message-mail (or to-address to-list)) + ;; Arrange for mail groups that have no `to-address' to + ;; get that when the user sends off the mail. + (when (and (not to-list) + (not to-address) + add-to-list) + (push (list 'gnus-inews-add-to-address pgroup) + message-send-actions))) + (set-buffer gnus-article-copy) + (message-wide-reply to-address + (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to)))) + (when yank + (gnus-inews-yank-articles yank)))))) + +(defun gnus-post-method (arg group &optional silent) + "Return the posting method based on GROUP and ARG. +If SILENT, don't prompt the user." + (let ((group-method (gnus-find-method-for-group group))) + (cond + ;; If the group-method is nil (which shouldn't happen) we use + ;; the default method. + ((null group-method) + (or gnus-post-method gnus-select-method message-post-method)) + ;; We want this group's method. + ((and arg (not (eq arg 0))) + group-method) + ;; We query the user for a post method. + ((or arg + (and gnus-post-method + (listp (car gnus-post-method)))) + (let* ((methods + ;; Collect all methods we know about. + (append + (when gnus-post-method + (if (listp (car gnus-post-method)) + gnus-post-method + (list gnus-post-method))) + gnus-secondary-select-methods + (list gnus-select-method) + (list group-method))) + method-alist post-methods method) + ;; Weed out all mail methods. + (while methods + (setq method (gnus-server-get-method "" (pop methods))) + (when (or (gnus-method-option-p method 'post) + (gnus-method-option-p method 'post-mail)) + (push method post-methods))) + ;; Create a name-method alist. + (setq method-alist + (mapcar + (lambda (m) + (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)) + post-methods)) + ;; Query the user. + (cadr + (assoc + (setq gnus-last-posting-server + (if (and silent + gnus-last-posting-server) + ;; Just use the last value. + gnus-last-posting-server + (completing-read + "Posting method: " method-alist nil t + (cons (or gnus-last-posting-server "") 0)))) + method-alist)))) + ;; Override normal method. + (gnus-post-method + gnus-post-method) + ;; Use the normal select method. + (t gnus-select-method)))) + +;;; +;;; Check whether the message has been sent already. +;;; + +(defvar gnus-inews-sent-ids nil) + +(defun gnus-inews-reject-message () + "Check whether this message has already been sent." + (when gnus-sent-message-ids-file + (let ((message-id (save-restriction (message-narrow-to-headers) + (mail-fetch-field "message-id"))) + end) + (when message-id + (unless gnus-inews-sent-ids + (ignore-errors + (load t t t))) + (if (member message-id gnus-inews-sent-ids) + ;; Reject this message. + (not (gnus-yes-or-no-p + (format "Message %s already sent. Send anyway? " + message-id))) + (push message-id gnus-inews-sent-ids) + ;; Chop off the last Message-IDs. + (when (setq end (nthcdr gnus-sent-message-ids-length + gnus-inews-sent-ids)) + (setcdr end nil)) + (nnheader-temp-write gnus-sent-message-ids-file + (gnus-prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids))) + nil))))) + + + +;; Dummy to avoid byte-compile warning. +(defvar nnspool-rejected-article-hook) +(defvar xemacs-codename) + +;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might +;;; as well include the Emacs version as well. +;;; The following function works with later GNU Emacs, and XEmacs. +(defun gnus-extended-version () + "Stringified Gnus version and Emacs version" + (interactive) + (concat + gnus-version + "/" + (cond + ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) + (concat "Emacs " (substring emacs-version + (match-beginning 1) + (match-end 1)))) + ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" + emacs-version) + (concat (substring emacs-version + (match-beginning 1) + (match-end 1)) + (format " %d.%d" emacs-major-version emacs-minor-version) + (if (match-beginning 3) + (substring emacs-version + (match-beginning 3) + (match-end 3)) + "") + (if (boundp 'xemacs-codename) + (concat " - \"" xemacs-codename "\"")))) + (t emacs-version)))) + +;; Written by "Mr. Per Persson" . +(defun gnus-inews-insert-mime-headers () + (goto-char (point-min)) + (let ((mail-header-separator + (progn + (goto-char (point-min)) + (if (and (search-forward (concat "\n" mail-header-separator "\n") + nil t) + (not (search-backward "\n\n" nil t))) + mail-header-separator + "")))) + (or (mail-position-on-field "Mime-Version") + (insert "1.0") + (cond ((save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward "[\200-\377]" nil t)) + (or (mail-position-on-field "Content-Type") + (insert "text/plain; charset=ISO-8859-1")) + (or (mail-position-on-field "Content-Transfer-Encoding") + (insert "8bit"))) + (t (or (mail-position-on-field "Content-Type") + (insert "text/plain; charset=US-ASCII")) + (or (mail-position-on-field "Content-Transfer-Encoding") + (insert "7bit"))))))) + + +;;; +;;; Gnus Mail Functions +;;; + +;;; Mail reply commands of Gnus summary mode + +(defun gnus-summary-reply (&optional yank wide) + "Start composing a reply mail to the current message. +If prefix argument YANK is non-nil, the original article is yanked +automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + ;; Stripping headers should be specified with mail-yank-ignored-headers. + (gnus-set-global-variables) + (when yank + (gnus-summary-goto-subject (car yank))) + (let ((gnus-article-reply t)) + (gnus-setup-message (if yank 'reply-yank 'reply) + (gnus-summary-select-article) + (set-buffer (gnus-copy-article-buffer)) + (message-reply nil wide (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to)) + (when yank + (gnus-inews-yank-articles yank))))) + +(defun gnus-summary-reply-with-original (n &optional wide) + "Start composing a reply mail to the current message. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply (gnus-summary-work-articles n) wide)) + +(defun gnus-summary-wide-reply (&optional yank) + "Start composing a wide reply mail to the current message. +If prefix argument YANK is non-nil, the original article is yanked +automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-reply yank t)) + +(defun gnus-summary-wide-reply-with-original (n) + "Start composing a wide reply mail to the current message. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply-with-original n t)) + +(defun gnus-summary-mail-forward (&optional full-headers post) + "Forward the current message to another user. +If FULL-HEADERS (the prefix), include full headers when forwarding." + (interactive "P") + (gnus-set-global-variables) + (gnus-setup-message 'forward + (gnus-summary-select-article) + (set-buffer gnus-original-article-buffer) + (let ((message-included-forward-headers + (if full-headers "" message-included-forward-headers))) + (message-forward post)))) + +(defun gnus-summary-resend-message (address n) + "Resend the current article to ADDRESS." + (interactive "sResend message(s) to: \nP") + (let ((articles (gnus-summary-work-articles n)) + article) + (while (setq article (pop articles)) + (gnus-summary-select-article nil nil nil article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (message-resend address))))) + +(defun gnus-summary-post-forward (&optional full-headers) + "Forward the current article to a newsgroup. +If FULL-HEADERS (the prefix), include full headers when forwarding." + (interactive "P") + (gnus-summary-mail-forward full-headers t)) + +(defvar gnus-nastygram-message + "The following article was inappropriately posted to %s.\n\n" + "Format string to insert in nastygrams. +The current group name will be inserted at \"%s\".") + +(defun gnus-summary-mail-nastygram (n) + "Send a nastygram to the author of the current article." + (interactive "P") + (when (or gnus-expert-user + (gnus-y-or-n-p + "Really send a nastygram to the author of the current article? ")) + (let ((group gnus-newsgroup-name)) + (gnus-summary-reply-with-original n) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-nastygram-message group)) + (message-send-and-exit)))) + +(defun gnus-summary-mail-crosspost-complaint (n) + "Send a complaint about crossposting to the current article(s)." + (interactive "P") + (let ((articles (gnus-summary-work-articles n)) + article) + (while (setq article (pop articles)) + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-subject article) + (let ((group (gnus-group-real-name gnus-newsgroup-name)) + newsgroups followup-to) + (gnus-summary-select-article) + (set-buffer gnus-original-article-buffer) + (if (and (<= (length (message-tokenize-header + (setq newsgroups (mail-fetch-field "newsgroups")) + ", ")) + 1) + (or (not (setq followup-to (mail-fetch-field "followup-to"))) + (not (member group (message-tokenize-header + followup-to ", "))))) + (if followup-to + (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Not a crossposted article")) + (set-buffer gnus-summary-buffer) + (gnus-summary-reply-with-original 1) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-crosspost-complaint newsgroups group)) + (message-goto-subject) + (re-search-forward " *$") + (replace-match " (crosspost notification)" t t) + (gnus-deactivate-mark) + (when (gnus-y-or-n-p "Send this complaint? ") + (message-send-and-exit))))))) + +(defun gnus-summary-mail-other-window () + "Compose mail in other window." + (interactive) + (gnus-setup-message 'message + (message-mail))) + +(defun gnus-mail-parse-comma-list () + (let (accumulated + beg) + (skip-chars-forward " ") + (while (not (eobp)) + (setq beg (point)) + (skip-chars-forward "^,") + (while (zerop + (save-excursion + (save-restriction + (let ((i 0)) + (narrow-to-region beg (point)) + (goto-char beg) + (logand (progn + (while (search-forward "\"" nil t) + (incf i)) + (if (zerop i) 2 i)) + 2))))) + (skip-chars-forward ",") + (skip-chars-forward "^,")) + (skip-chars-backward " ") + (push (buffer-substring beg (point)) + accumulated) + (skip-chars-forward "^,") + (skip-chars-forward ", ")) + accumulated)) + +(defun gnus-inews-add-to-address (group) + (let ((to-address (mail-fetch-field "to"))) + (when (and to-address + (gnus-alive-p)) + ;; This mail group doesn't have a `to-list', so we add one + ;; here. Magic! + (when (gnus-y-or-n-p + (format "Do you want to add this as `to-list': %s " to-address)) + (gnus-group-add-parameter group (cons 'to-list to-address)))))) + +(defun gnus-put-message () + "Put the current message in some group and return to Gnus." + (interactive) + (let ((reply gnus-article-reply) + (winconf gnus-prev-winconf) + (group gnus-newsgroup-name)) + + (or (and group (not (gnus-group-read-only-p group))) + (setq group (read-string "Put in group: " nil + (gnus-writable-groups)))) + (when (gnus-gethash group gnus-newsrc-hashtb) + (error "No such group: %s" group)) + + (save-excursion + (save-restriction + (widen) + (message-narrow-to-headers) + (let (gnus-deletable-headers) + (if (message-news-p) + (message-generate-headers message-required-news-headers) + (message-generate-headers message-required-mail-headers))) + (goto-char (point-max)) + (insert "Gcc: " group "\n") + (widen))) + + (gnus-inews-do-gcc) + + (when (get-buffer gnus-group-buffer) + (when (gnus-buffer-exists-p (car-safe reply)) + (set-buffer (car reply)) + (and (cdr reply) + (gnus-summary-mark-article-as-replied + (cdr reply)))) + (when winconf + (set-window-configuration winconf))))) + +(defun gnus-article-mail (yank) + "Send a reply to the address near point. +If YANK is non-nil, include the original article." + (interactive "P") + (let ((address + (buffer-substring + (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point))) + (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point)))))) + (when address + (message-reply address) + (when yank + (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) + +(defvar nntp-server-type) +(defun gnus-bug () + "Send a bug report to the Gnus maintainers." + (interactive) + (unless (gnus-alive-p) + (error "Gnus has been shut down")) + (gnus-setup-message 'bug + (delete-other-windows) + (switch-to-buffer (get-buffer-create "*Gnus Help Bug*")) + (erase-buffer) + (insert gnus-bug-message) + (goto-char (point-min)) + (message-pop-to-buffer "*Gnus Bug*") + (message-setup `((To . ,gnus-maintainer) (Subject . ""))) + (push `(gnus-bug-kill-buffer) message-send-actions) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (insert (gnus-version) "\n") + (insert (emacs-version) "\n") + (when (and (boundp 'nntp-server-type) + (stringp nntp-server-type)) + (insert nntp-server-type)) + (insert "\n\n\n\n\n") + (gnus-debug) + (goto-char (point-min)) + (search-forward "Subject: " nil t) + (message ""))) + +(defun gnus-bug-kill-buffer () + (when (get-buffer "*Gnus Help Bug*") + (kill-buffer "*Gnus Help Bug*"))) + +(defun gnus-debug () + "Attempts to go through the Gnus source file and report what variables have been changed. +The source file has to be in the Emacs load path." + (interactive) + (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el" + "gnus-art.el" "gnus-start.el" "gnus-async.el" + "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" + "nnmail.el" "message.el")) + file expr olist sym) + (gnus-message 4 "Please wait while we snoop your variables...") + (sit-for 0) + ;; Go through all the files looking for non-default values for variables. + (save-excursion + (set-buffer (get-buffer-create " *gnus bug info*")) + (buffer-disable-undo (current-buffer)) + (while files + (erase-buffer) + (when (and (setq file (locate-library (pop files))) + (file-exists-p file)) + (insert-file-contents file) + (goto-char (point-min)) + (if (not (re-search-forward "^;;* *Internal variables" nil t)) + (gnus-message 4 "Malformed sources in file %s" file) + (narrow-to-region (point-min) (point)) + (goto-char (point-min)) + (while (setq expr (ignore-errors (read (current-buffer)))) + (ignore-errors + (and (or (eq (car expr) 'defvar) + (eq (car expr) 'defcustom)) + (stringp (nth 3 expr)) + (or (not (boundp (nth 1 expr))) + (not (equal (eval (nth 2 expr)) + (symbol-value (nth 1 expr))))) + (push (nth 1 expr) olist))))))) + (kill-buffer (current-buffer))) + (when (setq olist (nreverse olist)) + (insert "------------------ Environment follows ------------------\n\n")) + (while olist + (if (boundp (car olist)) + (condition-case () + (pp `(setq ,(car olist) + ,(if (or (consp (setq sym (symbol-value (car olist)))) + (and (symbolp sym) + (not (or (eq sym nil) + (eq sym t))))) + (list 'quote (symbol-value (car olist))) + (symbol-value (car olist)))) + (current-buffer)) + (error + (format "(setq %s 'whatever)\n" (car olist)))) + (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) + (setq olist (cdr olist))) + (insert "\n\n") + ;; Remove any null chars - they seem to cause trouble for some + ;; mailers. (Byte-compiled output from the stuff above.) + (goto-char (point-min)) + (while (re-search-forward "[\000\200]" nil t) + (replace-match "" t t)))) + +;;; Treatment of rejected articles. +;;; Bounced mail. + +(defun gnus-summary-resend-bounced-mail (&optional fetch) + "Re-mail the current message. +This only makes sense if the current message is a bounce message than +contains some mail you have written which has been bounced back to +you. +If FETCH, try to fetch the article that this is a reply to, if indeed +this is a reply." + (interactive "P") + (gnus-summary-select-article t) + (set-buffer gnus-original-article-buffer) + (gnus-setup-message 'compose-bounce + (let* ((references (mail-fetch-field "references")) + (parent (and references (gnus-parent-id references)))) + (message-bounce) + ;; If there are references, we fetch the article we answered to. + (and fetch parent + (gnus-summary-refer-article parent) + (gnus-summary-show-all-headers))))) + +;;; Gcc handling. + +;; Do Gcc handling, which copied the message over to some group. +(defun gnus-inews-do-gcc (&optional gcc) + (interactive) + (when (gnus-alive-p) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (let ((gcc (or gcc (mail-fetch-field "gcc" nil t))) + (cur (current-buffer)) + groups group method) + (when gcc + (message-remove-header "gcc") + (widen) + (setq groups (message-tokenize-header gcc " ,")) + ;; Copy the article over to some group(s). + (while (setq group (pop groups)) + (gnus-check-server + (setq method + (cond ((and (null (gnus-get-info group)) + (eq (car gnus-message-archive-method) + (car + (gnus-server-to-method + (gnus-group-method group))))) + ;; If the group doesn't exist, we assume + ;; it's an archive group... + gnus-message-archive-method) + ;; Use the method. + ((gnus-info-method (gnus-get-info group)) + (gnus-info-method (gnus-get-info group))) + ;; Find the method. + (t (gnus-group-method group))))) + (gnus-check-server method) + (unless (gnus-request-group group t method) + (gnus-request-create-group group method)) + (save-excursion + (nnheader-set-temp-buffer " *acc*") + (insert-buffer-substring cur) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) + (unless (gnus-request-accept-article group method t) + (gnus-message 1 "Couldn't store article in group %s: %s" + group (gnus-status-message method)) + (sit-for 2)) + (kill-buffer (current-buffer)))))))))) + +(defun gnus-inews-insert-gcc () + "Insert Gcc headers based on `gnus-outgoing-message-group'." + (save-excursion + (save-restriction + (message-narrow-to-headers) + (let* ((group gnus-outgoing-message-group) + (gcc (cond + ((gnus-functionp group) + (funcall group)) + ((or (stringp group) (list group)) + group)))) + (when gcc + (insert "Gcc: " + (if (stringp gcc) gcc + (mapconcat 'identity gcc " ")) + "\n")))))) + +(defun gnus-inews-insert-archive-gcc (&optional group) + "Insert the Gcc to say where the article is to be archived." + (let* ((var gnus-message-archive-group) + (group (or group gnus-newsgroup-name "")) + result + gcc-self-val + (groups + (cond + ((null gnus-message-archive-method) + ;; Ignore. + nil) + ((stringp var) + ;; Just a single group. + (list var)) + ((null var) + ;; We don't want this. + nil) + ((and (listp var) (stringp (car var))) + ;; A list of groups. + var) + ((gnus-functionp var) + ;; A function. + (funcall var group)) + (t + ;; An alist of regexps/functions/forms. + (while (and var + (not + (setq result + (cond + ((stringp (caar var)) + ;; Regexp. + (when (string-match (caar var) group) + (cdar var))) + ((gnus-functionp (car var)) + ;; Function. + (funcall (car var) group)) + (t + (eval (car var))))))) + (setq var (cdr var))) + result))) + name) + (when groups + (when (stringp groups) + (setq groups (list groups))) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (goto-char (point-max)) + (insert "Gcc: ") + (if (and gnus-newsgroup-name + (setq gcc-self-val + (gnus-group-find-parameter + gnus-newsgroup-name 'gcc-self))) + (progn + (insert + (if (stringp gcc-self-val) + gcc-self-val + group)) + (if (not (eq gcc-self-val 'none)) + (insert "\n") + (progn + (beginning-of-line) + (kill-line)))) + (while (setq name (pop groups)) + (insert (if (string-match ":" name) + name + (gnus-group-prefixed-name + name gnus-message-archive-method))) + (when groups + (insert " "))) + (insert "\n"))))))) + +(gnus-add-shutdown 'gnus-inews-close 'gnus) + +(defun gnus-inews-close () + (setq gnus-inews-sent-ids nil)) + +;;; Allow redefinition of functions. + +(gnus-ems-redefine) + +(provide 'gnus-msg) + +;;; gnus-msg.el ends here diff --git a/lisp/gnus-nocem.el b/lisp/gnus-nocem.el new file mode 100644 index 0000000..80f04b0 --- /dev/null +++ b/lisp/gnus-nocem.el @@ -0,0 +1,352 @@ +;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'nnmail) +(require 'gnus-art) +(require 'gnus-sum) +(require 'gnus-range) + +(defgroup gnus-nocem nil + "NoCeM pseudo-cancellation treatment" + :group 'gnus-score) + +(defcustom gnus-nocem-groups + '("news.lists.filters" "news.admin.net-abuse.bulletins" + "alt.nocem.misc" "news.admin.net-abuse.announce") + "List of groups that will be searched for NoCeM messages." + :group 'gnus-nocem + :type '(repeat (string :tag "Group"))) + +(defcustom gnus-nocem-issuers + '("AutoMoose-1" "Automoose-1" ; CancelMoose[tm] + "rbraver@ohww.norman.ok.us" ; Robert Braver + "clewis@ferret.ocunix.on.ca" ; Chris Lewis + "jem@xpat.com" ; Despammer from Korea + "snowhare@xmission.com" ; Benjamin "Snowhare" Franz + "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM! + ) + "List of NoCeM issuers to pay attention to. + +This can also be a list of `(ISSUER CONDITIONS)' elements." + :group 'gnus-nocem + :type '(repeat string)) + +(defcustom gnus-nocem-directory + (nnheader-concat gnus-article-save-directory "NoCeM/") + "*Directory where NoCeM files will be stored." + :group 'gnus-nocem + :type 'directory) + +(defcustom gnus-nocem-expiry-wait 15 + "*Number of days to keep NoCeM headers in the cache." + :group 'gnus-nocem + :type 'integer) + +(defcustom gnus-nocem-verifyer 'mc-verify + "*Function called to verify that the NoCeM message is valid. +One likely value is `mc-verify'. If the function in this variable +isn't bound, the message will be used unconditionally." + :group 'gnus-nocem + :type '(radio (function-item mc-verify) + (function :tag "other"))) + +(defcustom gnus-nocem-liberal-fetch nil + "*If t try to fetch all messages which have @@NCM in the subject. +Otherwise don't fetch messages which have references or whose message-id +matches an previously scanned and verified nocem message." + :group 'gnus-nocem + :type 'boolean) + +;;; Internal variables + +(defvar gnus-nocem-active nil) +(defvar gnus-nocem-alist nil) +(defvar gnus-nocem-touched-alist nil) +(defvar gnus-nocem-hashtb nil) +(defvar gnus-nocem-seen-message-ids nil) + +;;; Functions + +(defun gnus-nocem-active-file () + (concat (file-name-as-directory gnus-nocem-directory) "active")) + +(defun gnus-nocem-cache-file () + (concat (file-name-as-directory gnus-nocem-directory) "cache")) + +;; +;; faster lookups for group names: +;; + +(defvar gnus-nocem-real-group-hashtb nil + "Real-name mappings of subscribed groups.") + +(defun gnus-fill-real-hashtb () + "Fill up a hash table with the real-name mappings from the user's +active file." + (setq gnus-nocem-real-group-hashtb (gnus-make-hashtable + (length gnus-newsrc-alist))) + (mapcar (lambda (group) + (setq group (gnus-group-real-name (car group))) + (gnus-sethash group t gnus-nocem-real-group-hashtb)) + gnus-newsrc-alist)) + +(defun gnus-nocem-scan-groups () + "Scan all NoCeM groups for new NoCeM messages." + (interactive) + (let ((groups gnus-nocem-groups) + (gnus-inhibit-demon t) + group active gactive articles) + (gnus-make-directory gnus-nocem-directory) + ;; Load any previous NoCeM headers. + (gnus-nocem-load-cache) + ;; Get the group name mappings: + (gnus-fill-real-hashtb) + ;; Read the active file if it hasn't been read yet. + (and (file-exists-p (gnus-nocem-active-file)) + (not gnus-nocem-active) + (ignore-errors + (load (gnus-nocem-active-file) t t t))) + ;; Go through all groups and see whether new articles have + ;; arrived. + (while (setq group (pop groups)) + (if (not (setq gactive (gnus-activate-group group))) + () ; This group doesn't exist. + (setq active (nth 1 (assoc group gnus-nocem-active))) + (when (and (not (< (cdr gactive) (car gactive))) ; Empty group. + (or (not active) + (< (cdr active) (cdr gactive)))) + ;; Ok, there are new articles in this group, se we fetch the + ;; headers. + (save-excursion + (let ((dependencies (make-vector 10 nil)) + headers header) + (nnheader-temp-write nil + (setq headers + (if (eq 'nov + (gnus-retrieve-headers + (setq articles + (gnus-uncompress-range + (cons + (if active (1+ (cdr active)) + (car gactive)) + (cdr gactive)))) + group)) + (gnus-get-newsgroup-headers-xover + articles nil dependencies) + (gnus-get-newsgroup-headers dependencies))) + (while (setq header (pop headers)) + ;; We take a closer look on all articles that have + ;; "@@NCM" in the subject. Unless we already read + ;; this cross posted message. Nocem messages + ;; are not allowed to have references, so we can + ;; ignore scanning followups. + (and (string-match "@@NCM" (mail-header-subject header)) + (or gnus-nocem-liberal-fetch + (and (or (string= "" (mail-header-references + header)) + (null (mail-header-references header))) + (not (member (mail-header-message-id header) + gnus-nocem-seen-message-ids)))) + (gnus-nocem-check-article group header))))))) + (setq gnus-nocem-active + (cons (list group gactive) + (delq (assoc group gnus-nocem-active) + gnus-nocem-active))))) + ;; Save the results, if any. + (gnus-nocem-save-cache) + (gnus-nocem-save-active))) + +(defun gnus-nocem-check-article (group header) + "Check whether the current article is an NCM article and that we want it." + ;; Get the article. + (gnus-message 7 "Checking article %d in %s for NoCeM..." + (mail-header-number header) group) + (let ((date (mail-header-date header)) + issuer b e type) + (when (or (not date) + (nnmail-time-less + (nnmail-time-since (nnmail-date-to-time date)) + (nnmail-days-to-time gnus-nocem-expiry-wait))) + (gnus-request-article-this-buffer (mail-header-number header) group) + (goto-char (point-min)) + (when (re-search-forward "-----BEGIN PGP MESSAGE-----" nil t) + (delete-region (point-min) (match-beginning 0))) + (when (re-search-forward "-----END PGP MESSAGE-----\n?" nil t) + (delete-region (match-end 0) (point-max))) + (goto-char (point-min)) + ;; The article has to have proper NoCeM headers. + (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t)) + (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) + ;; We get the name of the issuer. + (narrow-to-region b e) + (setq issuer (mail-fetch-field "issuer") + type (mail-fetch-field "issuer")) + (widen) + (if (not (gnus-nocem-message-wanted-p issuer type)) + (message "invalid NoCeM issuer: %s" issuer) + (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is. + (gnus-nocem-enter-article) ; We gobble the message. + (push (mail-header-message-id header) ; But don't come back for + gnus-nocem-seen-message-ids))))))) ; second helpings. + +(defun gnus-nocem-message-wanted-p (issuer type) + (let ((issuers gnus-nocem-issuers) + wanted conditions condition) + (cond + ;; Do the quick check first. + ((member issuer issuers) + t) + ((setq conditions (cdr (assoc issuer issuers))) + ;; Check whether we want this type. + (while (setq condition (pop conditions)) + (cond + ((stringp condition) + (setq wanted (string-match condition) type)) + ((and (consp condition) + (eq (car condition) 'not) + (stringp (cadr condition))) + (setq wanted (not (string-match (cadr condition) type)))) + (t + (error "Invalid NoCeM condition: %S" condition)))) + wanted)))) + +(defun gnus-nocem-verify-issuer (person) + "Verify using PGP that the canceler is who she says she is." + (if (fboundp gnus-nocem-verifyer) + (ignore-errors + (funcall gnus-nocem-verifyer)) + ;; If we don't have Mailcrypt, then we use the message anyway. + t)) + +(defun gnus-nocem-enter-article () + "Enter the current article into the NoCeM cache." + (goto-char (point-min)) + (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) + (e (search-forward "\n@@END NCM BODY\n" nil t)) + (buf (current-buffer)) + ncm id group) + (when (and b e) + (narrow-to-region b (1+ (match-beginning 0))) + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (cond + ((not (ignore-errors + (setq group (let ((obarray gnus-active-hashtb)) (read buf))))) + ;; An error. + ) + ((not (symbolp group)) + ;; Ignore invalid entries. + ) + ((not (boundp group)) + ;; Make sure all entries in the hashtb are bound. + (set group nil)) + (t + (when (gnus-gethash (gnus-group-real-name (symbol-name group)) + gnus-nocem-real-group-hashtb) + ;; Valid group. + (beginning-of-line) + (while (= (following-char) ?\t) + (forward-line -1)) + (setq id (buffer-substring (point) (1- (search-forward "\t")))) + (unless (gnus-gethash id gnus-nocem-hashtb) + ;; only store if not already present + (gnus-sethash id t gnus-nocem-hashtb) + (push id ncm)) + (forward-line 1) + (while (= (following-char) ?\t) + (forward-line 1)))))) + (when ncm + (setq gnus-nocem-touched-alist t) + (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) + ncm) + gnus-nocem-alist)) + t))) + +(defun gnus-nocem-load-cache () + "Load the NoCeM cache." + (interactive) + (unless gnus-nocem-alist + ;; The buffer doesn't exist, so we create it and load the NoCeM + ;; cache. + (when (file-exists-p (gnus-nocem-cache-file)) + (load (gnus-nocem-cache-file) t t t) + (gnus-nocem-alist-to-hashtb)))) + +(defun gnus-nocem-save-cache () + "Save the NoCeM cache." + (when (and gnus-nocem-alist + gnus-nocem-touched-alist) + (nnheader-temp-write (gnus-nocem-cache-file) + (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist))) + (setq gnus-nocem-touched-alist nil))) + +(defun gnus-nocem-save-active () + "Save the NoCeM active file." + (nnheader-temp-write (gnus-nocem-active-file) + (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active)))) + +(defun gnus-nocem-alist-to-hashtb () + "Create a hashtable from the Message-IDs we have." + (let* ((alist gnus-nocem-alist) + (pprev (cons nil alist)) + (prev pprev) + (expiry (nnmail-days-to-time gnus-nocem-expiry-wait)) + entry) + (setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51))) + (while (setq entry (car alist)) + (if (not (nnmail-time-less (nnmail-time-since (car entry)) expiry)) + ;; This entry has expired, so we remove it. + (setcdr prev (cdr alist)) + (setq prev alist) + ;; This is ok, so we enter it into the hashtable. + (setq entry (cdr entry)) + (while entry + (gnus-sethash (car entry) t gnus-nocem-hashtb) + (setq entry (cdr entry)))) + (setq alist (cdr alist))))) + +(gnus-add-shutdown 'gnus-nocem-close 'gnus) + +(defun gnus-nocem-close () + "Clear internal NoCeM variables." + (setq gnus-nocem-alist nil + gnus-nocem-hashtb nil + gnus-nocem-active nil + gnus-nocem-touched-alist nil + gnus-nocem-seen-message-ids nil + gnus-nocem-real-group-hashtb nil)) + +(defun gnus-nocem-unwanted-article-p (id) + "Say whether article ID in the current group is wanted." + (gnus-gethash id gnus-nocem-hashtb)) + +(provide 'gnus-nocem) + +;;; gnus-nocem.el ends here diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el new file mode 100644 index 0000000..cf511bb --- /dev/null +++ b/lisp/gnus-picon.el @@ -0,0 +1,743 @@ +;;; gnus-picon.el --- displaying pretty icons in Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Wes Hardaker +;; Keywords: news xpm annotation glyph faces + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'xpm) +(require 'annotations) +(require 'custom) +(require 'gnus-art) +(require 'gnus-win) + +;;; User variables: + +(defgroup picons nil + "Show pictures of people, domains, and newsgroups (XEmacs). +For this to work, you must add gnus-group-display-picons to the +gnus-summary-display-hook or to the gnus-article-display-hook +depending on what gnus-picons-display-where is set to. You must +also add gnus-article-display-picons to gnus-article-display-hook." + :group 'gnus-visual) + +(defcustom gnus-picons-display-where 'picons + "Where to display the group and article icons. +Legal values are `article' and `picons'." + :type '(choice symbol string) + :group 'picons) + +(defcustom gnus-picons-has-modeline-p t + "Wether the picons window should have a modeline. +This is only useful if `gnus-picons-display-where' is `picons'." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-database "/usr/local/faces" + "Defines the location of the faces database. +For information on obtaining this database of pretty pictures, please +see http://www.cs.indiana.edu/picons/ftp/index.html" + :type 'directory + :group 'picons) + +(defcustom gnus-picons-news-directories '("news") + "Sub-directory of the faces database containing the icons for newsgroups." + :type '(repeat string) + :group 'picons) +(define-obsolete-variable-alias 'gnus-picons-news-directory + 'gnus-picons-news-directories) + +(defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc") + "List of directories to search for user faces." + :type '(repeat string) + :group 'picons) + +(defcustom gnus-picons-domain-directories '("domains") + "List of directories to search for domain faces. +Some people may want to add \"unknown\" to this list." + :type '(repeat string) + :group 'picons) + +(defcustom gnus-picons-refresh-before-display nil + "If non-nil, display the article buffer before computing the picons." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-x-face-file-name + (format "/tmp/picon-xface.%s.xbm" (user-login-name)) + "The name of the file in which to store the converted X-face header." + :type 'string + :group 'picons) + +(defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name) + "Command to convert the x-face header into a xbm file." + :type 'string + :group 'picons) + +(defcustom gnus-picons-display-as-address t + "*If t display textual email addresses along with pictures." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-file-suffixes + (when (featurep 'x) + (let ((types (list "xbm"))) + (when (featurep 'gif) + (push "gif" types)) + (when (featurep 'xpm) + (push "xpm" types)) + types)) + "List of suffixes on picon file names to try." + :type '(repeat string) + :group 'picons) + +(defcustom gnus-picons-display-article-move-p t + "*Whether to move point to first empty line when displaying picons. +This has only an effect if `gnus-picons-display-where' has value `article'." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-clear-cache-on-shutdown t + "*Whether to clear the picons cache when exiting gnus. +Gnus caches every picons it finds while it is running. This saves +some time in the search process but eats some memory. If this +variable is set to nil, Gnus will never clear the cache itself; you +will have to manually call `gnus-picons-clear-cache' to clear it. +Otherwise the cache will be cleared every time you exit Gnus." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-piconsearch-url nil + "*The url to query for picons. Setting this to nil will disable it. +The only publicly available address currently known is +http://www.cs.indiana.edu:800/piconsearch. If you know of any other, +please tell me so that we can list it." + :type '(choice (const :tag "Disable" :value nil) + (const :tag "www.cs.indiana.edu" + :value "http://www.cs.indiana.edu:800/piconsearch") + (string)) + :group 'picons) + +;;; Internal variables: + +(defvar gnus-picons-processes-alist nil + "Picons processes currently running and their environment.") +(defvar gnus-picons-glyph-alist nil + "Picons glyphs cache. +List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") +(defvar gnus-picons-url-alist nil + "Picons file names cache. +List of pairs (KEY . NAME) where KEY is (USER HOST DBS) and NAME is an URL.") + +(defvar gnus-group-annotations nil + "List of annotations added/removed when selecting/exiting a group") +(defvar gnus-article-annotations nil + "List of annotations added/removed when selecting an article") +(defvar gnus-x-face-annotations nil + "List of annotations added/removed when selecting an article with an +X-Face.") + +(defvar gnus-picons-jobs-alist nil + "List of jobs that still need be done. +This is a list of (SYM-ANN TAG ARGS...) where SYM-ANN three annotations list, +TAG is one of `picon' or `search' indicating that the job should query a +picon or do a search for picons file names, and ARGS is some additionnal +arguments necessary for the job.") + +(defvar gnus-picons-job-already-running nil + "Lock to ensure only one stream of http requests is running.") + +;;; Functions: + +(defun gnus-picons-remove (symbol) + "Remove all annotations in variable named SYMBOL. +This function is careful to set it to nil before removing anything so that +asynchronous process don't get crazy." + (setq gnus-picons-jobs-alist (remassq symbol gnus-picons-jobs-alist)) + ;; notify running job that it may have been preempted + (if (eq (car gnus-picons-job-already-running) symbol) + (setq gnus-picons-job-already-running t)) + ;; clear all annotations + (mapc (function (lambda (item) + (if (annotationp item) + (delete-annotation item)))) + (prog1 (symbol-value symbol) + (set symbol nil)))) + +(defun gnus-picons-remove-all () + "Removes all picons from the Gnus display(s)." + (interactive) + (gnus-picons-remove 'gnus-article-annotations) + (gnus-picons-remove 'gnus-group-annotations) + (gnus-picons-remove 'gnus-x-face-annotations)) + +(defun gnus-get-buffer-name (variable) + "Returns the buffer name associated with the contents of a variable." + (cond ((symbolp variable) (let ((newvar (cdr (assq variable + gnus-window-to-buffer)))) + (cond ((symbolp newvar) + (symbol-value newvar)) + ((stringp newvar) newvar)))) + ((stringp variable) variable))) + +(defun gnus-picons-set-buffer () + (set-buffer + (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where))) + (gnus-add-current-to-buffer-list) + (goto-char (point-min)) + (if (and (eq gnus-picons-display-where 'article) + gnus-picons-display-article-move-p) + (if (search-forward "\n\n" nil t) + (forward-line -1) + (goto-char (point-max))) + (setq buffer-read-only t) + (unless gnus-picons-has-modeline-p + (set-specifier has-modeline-p + (list (list (current-buffer) + (cons nil gnus-picons-has-modeline-p))))))) + +(defun gnus-picons-prepare-for-annotations (annotations) + "Prepare picons buffer for puting annotations memorized in ANNOTATIONS. +ANNOTATIONS should be a symbol naming a variable wich contains a list of +annotations. Sets buffer to `gnus-picons-display-where'." + ;; let drawing catch up + (when gnus-picons-refresh-before-display + (sit-for 0)) + (gnus-picons-set-buffer) + (gnus-picons-remove annotations)) + +(defsubst gnus-picons-make-annotation (&rest args) + (let ((annot (apply 'make-annotation args))) + (set-extent-property annot 'duplicable nil) + annot)) + +(defun gnus-picons-article-display-x-face () + "Display the x-face header bitmap in the 'gnus-picons-display-where buffer." + ;; delete any old ones. + ;; This is needed here because gnus-picons-display-x-face will not + ;; be called if there is no X-Face header + (gnus-picons-remove 'gnus-x-face-annotations) + ;; display the new one. + (let ((gnus-article-x-face-command 'gnus-picons-display-x-face)) + (gnus-article-display-x-face))) + +(defun gnus-picons-x-face-sentinel (process event) + (let* ((env (assq process gnus-picons-processes-alist)) + (annot (cdr env))) + (setq gnus-picons-processes-alist (remassq process + gnus-picons-processes-alist)) + (when annot + (set-annotation-glyph annot + (make-glyph gnus-picons-x-face-file-name)) + (if (memq annot gnus-x-face-annotations) + (delete-file gnus-picons-x-face-file-name))))) + +(defun gnus-picons-display-x-face (beg end) + "Function to display the x-face header in the picons window. +To use: (setq gnus-article-x-face-command 'gnus-picons-display-x-face)" + (interactive) + (if (featurep 'xface) + ;; Use builtin support + (let ((buf (current-buffer))) + (save-excursion + (gnus-picons-prepare-for-annotations 'gnus-x-face-annotations) + (setq gnus-x-face-annotations + (cons (gnus-picons-make-annotation + (vector 'xface + :data (concat "X-Face: " + (buffer-substring beg end buf))) + nil 'text) + gnus-x-face-annotations)))) + ;; convert the x-face header to a .xbm file + (let* ((process-connection-type nil) + (annot (save-excursion + (gnus-picons-prepare-for-annotations + 'gnus-x-face-annotations) + (gnus-picons-make-annotation nil nil 'text))) + (process (start-process-shell-command "gnus-x-face" nil + gnus-picons-convert-x-face))) + (push annot gnus-x-face-annotations) + (push (cons process annot) gnus-picons-processes-alist) + (process-kill-without-query process) + (set-process-sentinel process 'gnus-picons-x-face-sentinel) + (process-send-region process beg end) + (process-send-eof process)))) + +(defun gnus-article-display-picons () + "Display faces for an author and his/her domain in gnus-picons-display-where." + (interactive) + (let (from at-idx) + (when (and (featurep 'xpm) + (or (not (fboundp 'device-type)) (equal (device-type) 'x)) + (setq from (mail-fetch-field "from")) + (setq from (downcase (or (cadr (mail-extract-address-components + from)) + ""))) + (or (setq at-idx (string-match "@" from)) + (setq at-idx (length from)))) + (save-excursion + (let ((username (downcase (substring from 0 at-idx))) + (addrs (if (eq at-idx (length from)) + (if gnus-local-domain + (message-tokenize-header gnus-local-domain ".")) + (message-tokenize-header (substring from (1+ at-idx)) + ".")))) + (gnus-picons-prepare-for-annotations 'gnus-article-annotations) + ;; if display in article buffer, the group annotations + ;; wrongly placed. Move them here + (if (eq gnus-picons-display-where 'article) + (dolist (ext gnus-group-annotations) + (set-extent-endpoints ext (point) (point)))) + (if (null gnus-picons-piconsearch-url) + (setq gnus-article-annotations + (nconc gnus-article-annotations + (gnus-picons-display-pairs + (gnus-picons-lookup-pairs + addrs gnus-picons-domain-directories) + gnus-picons-display-as-address + "." t) + (if (and gnus-picons-display-as-address addrs) + (list (gnus-picons-make-annotation + [string :data "@"] nil + 'text nil nil nil t))) + (gnus-picons-display-picon-or-name + (gnus-picons-lookup-user username addrs) + username t))) + (push (list 'gnus-article-annotations 'search username addrs + gnus-picons-domain-directories t) + gnus-picons-jobs-alist) + (gnus-picons-next-job)) + + (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) + +(defun gnus-group-display-picons () + "Display icons for the group in the gnus-picons-display-where buffer." + (interactive) + (when (and (featurep 'xpm) + (or (not (fboundp 'device-type)) (equal (device-type) 'x))) + (save-excursion + (gnus-picons-prepare-for-annotations 'gnus-group-annotations) + (if (null gnus-picons-piconsearch-url) + (setq gnus-group-annotations + (gnus-picons-display-pairs + (gnus-picons-lookup-pairs (reverse (message-tokenize-header + (gnus-group-real-name gnus-newsgroup-name) + ".")) + gnus-picons-news-directories) + t ".")) + (push (list 'gnus-group-annotations 'search nil + (message-tokenize-header + (gnus-group-real-name gnus-newsgroup-name) ".") + (if (listp gnus-picons-news-directories) + gnus-picons-news-directories + (list gnus-picons-news-directories)) + nil) + gnus-picons-jobs-alist) + (gnus-picons-next-job)) + + (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) + +(defsubst gnus-picons-lookup-internal (addrs dir) + (setq dir (expand-file-name dir gnus-picons-database)) + (gnus-picons-try-face (dolist (part (reverse addrs) dir) + (setq dir (expand-file-name part dir))))) + +(defun gnus-picons-lookup (addrs dirs) + "Lookup the picon for ADDRS in databases DIRS. +Returns the picon filename or NIL if none found." + (let (result) + (while (and dirs (null result)) + (setq result (gnus-picons-lookup-internal addrs (pop dirs)))) + result)) + +(defun gnus-picons-lookup-user-internal (user domains) + (let ((dirs gnus-picons-user-directories) + domains-tmp dir picon) + (while (and dirs (null picon)) + (setq domains-tmp domains + dir (pop dirs)) + (while (and domains-tmp + (null (setq picon (gnus-picons-lookup-internal + (cons user domains-tmp) dir)))) + (pop domains-tmp)) + ;; Also make a try in MISC subdir + (unless picon + (setq picon (gnus-picons-lookup-internal (list user "MISC") dir)))) + picon)) + +(defun gnus-picons-lookup-user (user domains) + "Lookup the picon for USER at DOMAINS. +USER is a string containing a name. +DOMAINS is a list of strings from the fully qualified domain name." + (or (gnus-picons-lookup-user-internal user domains) + (gnus-picons-lookup-user-internal "unknown" domains))) + +(defun gnus-picons-lookup-pairs (domains directories) + "Lookup picons for DOMAINS and all its parents in DIRECTORIES. +Returns a list of PAIRS whose CAR is the picon filename or NIL if +none, and whose CDR is the corresponding element of DOMAINS." + (let (picons) + (setq directories (if (listp directories) + directories + (list directories))) + (while domains + (push (list (gnus-picons-lookup (cons "unknown" domains) directories) + (pop domains)) + picons)) + picons)) + +(defun gnus-picons-display-picon-or-name (picon name &optional right-p) + (cond (picon (gnus-picons-display-glyph picon name right-p)) + (gnus-picons-display-as-address (list (gnus-picons-make-annotation + (vector 'string :data name) + nil 'text + nil nil nil right-p))))) + +(defun gnus-picons-display-pairs (pairs &optional bar-p dot-p right-p) + "Display picons in list PAIRS." + (let ((domain-p (and gnus-picons-display-as-address dot-p)) + pair picons) + (if (and bar-p domain-p right-p) + (setq picons (gnus-picons-display-glyph + (gnus-picons-try-face gnus-xmas-glyph-directory + "bar.") + nil right-p))) + (while pairs + (setq pair (pop pairs) + picons (nconc picons + (gnus-picons-display-picon-or-name (car pair) + (cadr pair) + right-p) + (if (and domain-p pairs) + (list (gnus-picons-make-annotation + (vector 'string :data dot-p) + nil 'text nil nil nil right-p)))))) + (if (and bar-p domain-p (not right-p)) + (setq picons (nconc picons + (gnus-picons-display-glyph + (gnus-picons-try-face gnus-xmas-glyph-directory + "bar.") + nil right-p)))) + picons)) + +(defun gnus-picons-try-face (dir &optional filebase) + (let* ((dir (file-name-as-directory dir)) + (filebase (or filebase "face.")) + (key (concat dir filebase)) + (glyph (cdr (assoc key gnus-picons-glyph-alist))) + (suffixes gnus-picons-file-suffixes) + f) + (while (and suffixes (null glyph)) + (when (file-exists-p (setq f (expand-file-name (concat filebase + (pop suffixes)) + dir))) + (setq glyph (make-glyph f)) + (push (cons key glyph) gnus-picons-glyph-alist))) + glyph)) + +(defun gnus-picons-display-glyph (glyph &optional part rightp) + (let ((new (gnus-picons-make-annotation glyph (point) + 'text nil nil nil rightp))) + (when (and part gnus-picons-display-as-address) + (set-annotation-data new (cons new + (make-glyph (vector 'string :data part)))) + (set-annotation-action new 'gnus-picons-action-toggle)) + (nconc + (list new) + (if (and (eq major-mode 'gnus-article-mode) + (not gnus-picons-display-as-address) + (not part)) + (list (gnus-picons-make-annotation [string :data " "] (point) + 'text nil nil nil rightp)))))) + +(defun gnus-picons-action-toggle (data) + "Toggle annotation" + (interactive "e") + (let* ((annot (car data)) + (glyph (annotation-glyph annot))) + (set-annotation-glyph annot (cdr data)) + (set-annotation-data annot (cons annot glyph)))) + +(defun gnus-picons-clear-cache () + "Clear the picons cache" + (interactive) + (setq gnus-picons-glyph-alist nil + gnus-picons-url-alist nil)) + +(gnus-add-shutdown 'gnus-picons-close 'gnus) + +(defun gnus-picons-close () + "Shut down the picons." + (if gnus-picons-clear-cache-on-shutdown + (gnus-picons-clear-cache))) + +;;; Query a remote DB. This requires some stuff from w3 ! + +(require 'url) +(require 'w3-forms) + +(defun gnus-picons-url-retrieve (url fn arg) + (let ((old-asynch (default-value 'url-be-asynchronous)) + (url-working-buffer (generate-new-buffer " *picons*")) + (url-package-name "Gnus") + (url-package-version gnus-version-number) + url-request-method) + (setq-default url-be-asynchronous t) + (save-excursion + (set-buffer url-working-buffer) + (setq url-be-asynchronous t + url-current-callback-data arg + url-current-callback-func fn) + (url-retrieve url t)) + (setq-default url-be-asynchronous old-asynch))) + +(defun gnus-picons-make-glyph (type) + "Make a TYPE glyph using current buffer as data. Handles xbm nicely." + (cond ((null type) nil) + ((eq type 'xbm) (let ((fname (make-temp-name "/tmp/picon"))) + (write-region (point-min) (point-max) fname + nil 'quiet) + (prog1 (make-glyph (vector 'xbm :file fname)) + (delete-file fname)))) + (t (make-glyph (vector type :data (buffer-string)))))) + +;;; Parsing of piconsearch result page. + +;; Assumes: +;; 1 - each value field has the form: "key = value" +;; 2 - a "

" separates the keywords from the results +;; 3 - every results begins by the path within the database at the beginning +;; of the line in raw text. +;; 3b - and the href following it is the preferred image type. + +;; if 1 or 2 is not met, it will probably cause an error. The other +;; will go undetected + +(defun gnus-picons-parse-value (name) + (goto-char (point-min)) + (re-search-forward (concat "" + (regexp-quote name) + " *= * *\\([^ <][^<]*\\) *")) + (buffer-substring (match-beginning 1) (match-end 1))) + +(defun gnus-picons-parse-filenames () + ;; returns an alist of ((USER ADDRS DB) . URL) + (let* ((case-fold-search t) + (user (gnus-picons-parse-value "user")) + (host (gnus-picons-parse-value "host")) + (dbs (message-tokenize-header (gnus-picons-parse-value "db") " ")) + (start-re + (concat + ;; dbs + "^\\(" (mapconcat 'identity dbs "\\|") "\\)/" + ;; host + "\\(\\(" (replace-in-string host "\\." "/\\|" t) "/\\|MISC/\\)*\\)" + ;; user + "\\(" (regexp-quote user) "\\|unknown\\)/" + "face\\.")) + cur-db cur-host cur-user types res) + ;; now point will be somewhere in the header. Find beginning of + ;; entries + (re-search-forward "

[ \t\n]*") + (while (re-search-forward start-re nil t) + (setq cur-db (buffer-substring (match-beginning 1) (match-end 1)) + cur-host (buffer-substring (match-beginning 2) (match-end 2)) + cur-user (buffer-substring (match-beginning 4) (match-end 4)) + cur-host (nreverse (message-tokenize-header cur-host "/"))) + ;; XXX - KLUDGE: there is a blank picon in news/MISC/unknown + (unless (and (string-equal cur-db "news") + (string-equal cur-user "unknown") + (equal cur-host '("MISC"))) + ;; ok now we have found an entry (USER HOST DB), find the + ;; corresponding picon URL + (save-restriction + ;; restrict region to this entry + (narrow-to-region (point) (search-forward "
")) + (goto-char (point-min)) + (setq types gnus-picons-file-suffixes) + (while (and types + (not (re-search-forward + (concat " +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +;;; List and range functions + +(defun gnus-last-element (list) + "Return last element of LIST." + (while (cdr list) + (setq list (cdr list))) + (car list)) + +(defun gnus-copy-sequence (list) + "Do a complete, total copy of a list." + (let (out) + (while (consp list) + (if (consp (car list)) + (push (gnus-copy-sequence (pop list)) out) + (push (pop list) out))) + (if list + (nconc (nreverse out) list) + (nreverse out)))) + +(defun gnus-set-difference (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2." + (let ((list1 (copy-sequence list1))) + (while list2 + (setq list1 (delq (car list2) list1)) + (setq list2 (cdr list2))) + list1)) + +(defun gnus-sorted-complement (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2. +Both lists have to be sorted over <." + (let (out) + (if (or (null list1) (null list2)) + (or list1 list2) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq out (cons (car list1) out)) + (setq list1 (cdr list1))) + (t + (setq out (cons (car list2) out)) + (setq list2 (cdr list2))))) + (nconc (nreverse out) (or list1 list2))))) + +(defun gnus-intersection (list1 list2) + (let ((result nil)) + (while list2 + (when (memq (car list2) list1) + (setq result (cons (car list2) result))) + (setq list2 (cdr list2))) + result)) + +(defun gnus-sorted-intersection (list1 list2) + ;; LIST1 and LIST2 have to be sorted over <. + (let (out) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq out (cons (car list1) out) + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (nreverse out))) + +(defun gnus-set-sorted-intersection (list1 list2) + ;; LIST1 and LIST2 have to be sorted over <. + ;; This function modifies LIST1. + (let* ((top (cons nil list1)) + (prev top)) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setcdr prev (cdr list1)) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (setcdr prev nil) + (cdr top))) + +(defun gnus-compress-sequence (numbers &optional always-list) + "Convert list of numbers to a list of ranges or a single range. +If ALWAYS-LIST is non-nil, this function will always release a list of +ranges." + (let* ((first (car numbers)) + (last (car numbers)) + result) + (if (null numbers) + nil + (if (not (listp (cdr numbers))) + numbers + (while numbers + (cond ((= last (car numbers)) nil) ;Omit duplicated number + ((= (1+ last) (car numbers)) ;Still in sequence + (setq last (car numbers))) + (t ;End of one sequence + (setq result + (cons (if (= first last) first + (cons first last)) + result)) + (setq first (car numbers)) + (setq last (car numbers)))) + (setq numbers (cdr numbers))) + (if (and (not always-list) (null result)) + (if (= first last) (list first) (cons first last)) + (nreverse (cons (if (= first last) first (cons first last)) + result))))))) + +(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range) +(defun gnus-uncompress-range (ranges) + "Expand a list of ranges into a list of numbers. +RANGES is either a single range on the form `(num . num)' or a list of +these ranges." + (let (first last result) + (cond + ((null ranges) + nil) + ((not (listp (cdr ranges))) + (setq first (car ranges)) + (setq last (cdr ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first))) + (nreverse result)) + (t + (while ranges + (if (atom (car ranges)) + (when (numberp (car ranges)) + (setq result (cons (car ranges) result))) + (setq first (caar ranges)) + (setq last (cdar ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first)))) + (setq ranges (cdr ranges))) + (nreverse result))))) + +(defun gnus-add-to-range (ranges list) + "Return a list of ranges that has all articles from both RANGES and LIST. +Note: LIST has to be sorted over `<'." + (if (not ranges) + (gnus-compress-sequence list t) + (setq list (copy-sequence list)) + (unless (listp (cdr ranges)) + (setq ranges (list ranges))) + (let ((out ranges) + ilist lowest highest temp) + (while (and ranges list) + (setq ilist list) + (setq lowest (or (and (atom (car ranges)) (car ranges)) + (caar ranges))) + (while (and list (cdr list) (< (cadr list) lowest)) + (setq list (cdr list))) + (when (< (car ilist) lowest) + (setq temp list) + (setq list (cdr list)) + (setcdr temp nil) + (setq out (nconc (gnus-compress-sequence ilist t) out))) + (setq highest (or (and (atom (car ranges)) (car ranges)) + (cdar ranges))) + (while (and list (<= (car list) highest)) + (setq list (cdr list))) + (setq ranges (cdr ranges))) + (when list + (setq out (nconc (gnus-compress-sequence list t) out))) + (setq out (sort out (lambda (r1 r2) + (< (or (and (atom r1) r1) (car r1)) + (or (and (atom r2) r2) (car r2)))))) + (setq ranges out) + (while ranges + (if (atom (car ranges)) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (car ranges)) (cadr ranges)) + (setcar ranges (cons (car ranges) + (cadr ranges))) + (setcdr ranges (cddr ranges))) + (when (= (1+ (car ranges)) (caadr ranges)) + (setcar (cadr ranges) (car ranges)) + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges))))) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (cdar ranges)) (cadr ranges)) + (setcdr (car ranges) (cadr ranges)) + (setcdr ranges (cddr ranges))) + (when (= (1+ (cdar ranges)) (caadr ranges)) + (setcdr (car ranges) (cdadr ranges)) + (setcdr ranges (cddr ranges)))))) + (setq ranges (cdr ranges))) + out))) + +(defun gnus-remove-from-range (ranges list) + "Return a list of ranges that has all articles from LIST removed from RANGES. +Note: LIST has to be sorted over `<'." + ;; !!! This function shouldn't look like this, but I've got a headache. + (gnus-compress-sequence + (gnus-sorted-complement + (gnus-uncompress-range ranges) list))) + +(defun gnus-member-of-range (number ranges) + (if (not (listp (cdr ranges))) + (and (>= number (car ranges)) + (<= number (cdr ranges))) + (let ((not-stop t)) + (while (and ranges + (if (numberp (car ranges)) + (>= number (car ranges)) + (>= number (caar ranges))) + not-stop) + (when (if (numberp (car ranges)) + (= number (car ranges)) + (and (>= number (caar ranges)) + (<= number (cdar ranges)))) + (setq not-stop nil)) + (setq ranges (cdr ranges))) + (not not-stop)))) + +(defun gnus-range-length (range) + "Return the length RANGE would have if uncompressed." + (length (gnus-uncompress-range range))) + +(defun gnus-sublist-p (list sublist) + "Test whether all elements in SUBLIST are members of LIST." + (let ((sublistp t)) + (while sublist + (unless (memq (pop sublist) list) + (setq sublistp nil + sublist nil))) + sublistp)) + +(defun gnus-range-add (range1 range2) + "Add RANGE2 to RANGE1 destructively." + (cond + ;; If either are nil, then the job is quite easy. + ((or (null range1) (null range2)) + (or range1 range2)) + (t + ;; I don't like thinking. + (gnus-compress-sequence + (sort + (nconc + (gnus-uncompress-range range1) + (gnus-uncompress-range range2)) + '<))))) + +(provide 'gnus-range) + +;;; gnus-range.el ends here diff --git a/lisp/gnus-salt.el b/lisp/gnus-salt.el new file mode 100644 index 0000000..955d203 --- /dev/null +++ b/lisp/gnus-salt.el @@ -0,0 +1,1014 @@ +;;; gnus-salt.el --- alternate summary mode interfaces for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-sum) + +;;; +;;; gnus-pick-mode +;;; + +(defvar gnus-pick-mode nil + "Minor mode for providing a pick-and-read interface in Gnus summary buffers.") + +(defcustom gnus-pick-display-summary nil + "*Display summary while reading." + :type 'boolean + :group 'gnus-summary-pick) + +(defcustom gnus-pick-mode-hook nil + "Hook run in summary pick mode buffers." + :type 'hook + :group 'gnus-summary-pick) + +(defcustom gnus-mark-unpicked-articles-as-read nil + "*If non-nil, mark all unpicked articles as read." + :type 'boolean + :group 'gnus-summary-pick) + +(defcustom gnus-pick-elegant-flow t + "If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked." + :type 'boolean + :group 'gnus-summary-pick) + +(defcustom gnus-summary-pick-line-format + "%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + "*The format specification of the lines in pick buffers. +It accepts the same format specs that `gnus-summary-line-format' does." + :type 'string + :group 'gnus-summary-pick) + +;;; Internal variables. + +(defvar gnus-pick-mode-map nil) + +(unless gnus-pick-mode-map + (setq gnus-pick-mode-map (make-sparse-keymap)) + + (gnus-define-keys gnus-pick-mode-map + "t" gnus-uu-mark-thread + "T" gnus-uu-unmark-thread + " " gnus-pick-next-page + "u" gnus-summary-unmark-as-processable + "U" gnus-summary-unmark-all-processable + "v" gnus-uu-mark-over + "r" gnus-uu-mark-region + "R" gnus-uu-unmark-region + "e" gnus-uu-mark-by-regexp + "E" gnus-uu-mark-by-regexp + "b" gnus-uu-mark-buffer + "B" gnus-uu-unmark-buffer + "." gnus-pick-article + gnus-down-mouse-2 gnus-pick-mouse-pick-region + ;;gnus-mouse-2 gnus-pick-mouse-pick + "X" gnus-pick-start-reading + "\r" gnus-pick-start-reading)) + +(defun gnus-pick-make-menu-bar () + (unless (boundp 'gnus-pick-menu) + (easy-menu-define + gnus-pick-menu gnus-pick-mode-map "" + '("Pick" + ("Pick" + ["Article" gnus-summary-mark-as-processable t] + ["Thread" gnus-uu-mark-thread t] + ["Region" gnus-uu-mark-region t] + ["Regexp" gnus-uu-mark-regexp t] + ["Buffer" gnus-uu-mark-buffer t]) + ("Unpick" + ["Article" gnus-summary-unmark-as-processable t] + ["Thread" gnus-uu-unmark-thread t] + ["Region" gnus-uu-unmark-region t] + ["Regexp" gnus-uu-unmark-regexp t] + ["Buffer" gnus-uu-unmark-buffer t]) + ["Start reading" gnus-pick-start-reading t] + ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) + +(defun gnus-pick-mode (&optional arg) + "Minor mode for providing a pick-and-read interface in Gnus summary buffers. + +\\{gnus-pick-mode-map}" + (interactive "P") + (when (eq major-mode 'gnus-summary-mode) + (if (not (set (make-local-variable 'gnus-pick-mode) + (if (null arg) (not gnus-pick-mode) + (> (prefix-numeric-value arg) 0)))) + (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) + ;; Make sure that we don't select any articles upon group entry. + (set (make-local-variable 'gnus-auto-select-first) nil) + ;; Change line format. + (setq gnus-summary-line-format gnus-summary-pick-line-format) + (setq gnus-summary-line-format-spec nil) + (gnus-update-format-specifications nil 'summary) + (gnus-update-summary-mark-positions) + (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) + (set (make-local-variable 'gnus-summary-goto-unread) 'never) + ;; Set up the menu. + (when (gnus-visual-p 'pick-menu 'menu) + (gnus-pick-make-menu-bar)) + (gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) + (run-hooks 'gnus-pick-mode-hook)))) + +(defun gnus-pick-setup-message () + "Make Message do the right thing on exit." + (when (and (gnus-buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-pick-mode)) + (message-add-action + '(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill))) + +(defvar gnus-pick-line-number 1) +(defun gnus-pick-line-number () + "Return the current line number." + (if (bobp) + (setq gnus-pick-line-number 1) + (incf gnus-pick-line-number))) + +(defun gnus-pick-start-reading (&optional catch-up) + "Start reading the picked articles. +If given a prefix, mark all unpicked articles as read." + (interactive "P") + (if gnus-newsgroup-processable + (progn + (gnus-summary-limit-to-articles nil) + (when (or catch-up gnus-mark-unpicked-articles-as-read) + (gnus-summary-limit-mark-excluded-as-read)) + (gnus-summary-first-article) + (gnus-configure-windows + (if gnus-pick-display-summary 'article 'pick) t)) + (if gnus-pick-elegant-flow + (progn + (when (or catch-up gnus-mark-unpicked-articles-as-read) + (gnus-summary-catchup nil t)) + (if (gnus-group-quit-config gnus-newsgroup-name) + (gnus-summary-exit) + (gnus-summary-next-group))) + (error "No articles have been picked")))) + +(defun gnus-pick-article (&optional arg) + "Pick the article on the current line. +If ARG, pick the article on that line instead." + (interactive "P") + (when arg + (let (pos) + (save-excursion + (goto-char (point-min)) + (when (zerop (forward-line (1- (prefix-numeric-value arg)))) + (setq pos (point)))) + (if (not pos) + (gnus-error 2 "No such line: %s" arg) + (goto-char pos)))) + (gnus-summary-mark-as-processable 1)) + +(defun gnus-pick-mouse-pick (e) + (interactive "e") + (mouse-set-point e) + (save-excursion + (gnus-summary-mark-as-processable 1))) + +(defun gnus-pick-mouse-pick-region (start-event) + "Pick articles that the mouse is dragged over. +This must be bound to a button-down mouse event." + (interactive "e") + (mouse-minibuffer-check start-event) + (let* ((echo-keystrokes 0) + (start-posn (event-start start-event)) + (start-point (posn-point start-posn)) + (start-line (1+ (count-lines 1 start-point))) + (start-window (posn-window start-posn)) + (start-frame (window-frame start-window)) + (bounds (window-edges start-window)) + (top (nth 1 bounds)) + (bottom (if (window-minibuffer-p start-window) + (nth 3 bounds) + ;; Don't count the mode line. + (1- (nth 3 bounds)))) + (click-count (1- (event-click-count start-event)))) + (setq mouse-selection-click-count click-count) + (setq mouse-selection-click-count-buffer (current-buffer)) + (mouse-set-point start-event) + ;; In case the down click is in the middle of some intangible text, + ;; use the end of that text, and put it in START-POINT. + (when (< (point) start-point) + (goto-char start-point)) + (gnus-pick-article) + (setq start-point (point)) + ;; end-of-range is used only in the single-click case. + ;; It is the place where the drag has reached so far + ;; (but not outside the window where the drag started). + (let (event end end-point last-end-point (end-of-range (point))) + (track-mouse + (while (progn + (setq event (read-event)) + (or (mouse-movement-p event) + (eq (car-safe event) 'switch-frame))) + (if (eq (car-safe event) 'switch-frame) + nil + (setq end (event-end event) + end-point (posn-point end)) + (when end-point + (setq last-end-point end-point)) + + (cond + ;; Are we moving within the original window? + ((and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + ;; Go to START-POINT first, so that when we move to END-POINT, + ;; if it's in the middle of intangible text, + ;; point jumps in the direction away from START-POINT. + (goto-char start-point) + (goto-char end-point) + (gnus-pick-article) + ;; In case the user moved his mouse really fast, pick + ;; articles on the line between this one and the last one. + (let* ((this-line (1+ (count-lines 1 end-point))) + (min-line (min this-line start-line)) + (max-line (max this-line start-line))) + (while (< min-line max-line) + (goto-line min-line) + (gnus-pick-article) + (setq min-line (1+ min-line))) + (setq start-line this-line)) + (when (zerop (% click-count 3)) + (setq end-of-range (point)))) + (t + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top))) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window + (1+ (- mouse-row bottom))))))))))) + (when (consp event) + (let ((fun (key-binding (vector (car event))))) + ;; Run the binding of the terminating up-event, if possible. + ;; In the case of a multiple click, it gives the wrong results, + ;; because it would fail to set up a region. + (when nil + ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun)) + ;; In this case, we can just let the up-event execute normally. + (let ((end (event-end event))) + ;; Set the position in the event before we replay it, + ;; because otherwise it may have a position in the wrong + ;; buffer. + (setcar (cdr end) end-of-range) + ;; Delete the overlay before calling the function, + ;; because delete-overlay increases buffer-modified-tick. + (push event unread-command-events)))))))) + +(defun gnus-pick-next-page () + "Go to the next page. If at the end of the buffer, start reading articles." + (interactive) + (let ((scroll-in-place nil)) + (condition-case nil + (scroll-up) + (end-of-buffer (gnus-pick-start-reading))))) + +;;; +;;; gnus-binary-mode +;;; + +(defvar gnus-binary-mode nil + "Minor mode for providing a binary group interface in Gnus summary buffers.") + +(defvar gnus-binary-mode-hook nil + "Hook run in summary binary mode buffers.") + +(defvar gnus-binary-mode-map nil) + +(unless gnus-binary-mode-map + (setq gnus-binary-mode-map (make-sparse-keymap)) + + (gnus-define-keys + gnus-binary-mode-map + "g" gnus-binary-show-article)) + +(defun gnus-binary-make-menu-bar () + (unless (boundp 'gnus-binary-menu) + (easy-menu-define + gnus-binary-menu gnus-binary-mode-map "" + '("Pick" + ["Switch binary mode off" gnus-binary-mode t])))) + +(defun gnus-binary-mode (&optional arg) + "Minor mode for providing a binary group interface in Gnus summary buffers." + (interactive "P") + (when (eq major-mode 'gnus-summary-mode) + (make-local-variable 'gnus-binary-mode) + (setq gnus-binary-mode + (if (null arg) (not gnus-binary-mode) + (> (prefix-numeric-value arg) 0))) + (when gnus-binary-mode + ;; Make sure that we don't select any articles upon group entry. + (make-local-variable 'gnus-auto-select-first) + (setq gnus-auto-select-first nil) + (make-local-variable 'gnus-summary-display-article-function) + (setq gnus-summary-display-article-function 'gnus-binary-display-article) + ;; Set up the menu. + (when (gnus-visual-p 'binary-menu 'menu) + (gnus-binary-make-menu-bar)) + (gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) + (run-hooks 'gnus-binary-mode-hook)))) + +(defun gnus-binary-display-article (article &optional all-header) + "Run ARTICLE through the binary decode functions." + (when (gnus-summary-goto-subject article) + (let ((gnus-view-pseudos 'automatic)) + (gnus-uu-decode-uu)))) + +(defun gnus-binary-show-article (&optional arg) + "Bypass the binary functions and show the article." + (interactive "P") + (let (gnus-summary-display-article-function) + (gnus-summary-show-article arg))) + +;;; +;;; gnus-tree-mode +;;; + +(defcustom gnus-tree-line-format "%(%[%3,3n%]%)" + "Format of tree elements." + :type 'string + :group 'gnus-summary-tree) + +(defcustom gnus-tree-minimize-window t + "If non-nil, minimize the tree buffer window. +If a number, never let the tree buffer grow taller than that number of +lines." + :type 'boolean + :group 'gnus-summary-tree) + +(defcustom gnus-selected-tree-face 'modeline + "*Face used for highlighting selected articles in the thread tree." + :type 'face + :group 'gnus-summary-tree) + +(defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\)) + (?\{ . ?\}) (?< . ?>)) + "Brackets used in tree nodes.") + +(defvar gnus-tree-parent-child-edges '(?- ?\\ ?|) + "Characters used to connect parents with children.") + +(defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z" + "*The format specification for the tree mode line." + :type 'string + :group 'gnus-summary-tree) + +(defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree + "*Function for generating a thread tree. +Two predefined functions are available: +`gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'." + :type '(radio (function-item gnus-generate-vertical-tree) + (function-item gnus-generate-horizontal-tree) + (function :tag "Other" nil)) + :group 'gnus-summary-tree) + +(defcustom gnus-tree-mode-hook nil + "*Hook run in tree mode buffers." + :type 'hook + :group 'gnus-summary-tree) + +;;; Internal variables. + +(defvar gnus-tree-line-format-alist + `((?n gnus-tmp-name ?s) + (?f gnus-tmp-from ?s) + (?N gnus-tmp-number ?d) + (?\[ gnus-tmp-open-bracket ?c) + (?\] gnus-tmp-close-bracket ?c) + (?s gnus-tmp-subject ?s))) + +(defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist) + +(defvar gnus-tree-mode-line-format-spec nil) +(defvar gnus-tree-line-format-spec nil) + +(defvar gnus-tree-node-length nil) +(defvar gnus-selected-tree-overlay nil) + +(defvar gnus-tree-displayed-thread nil) + +(defvar gnus-tree-mode-map nil) +(put 'gnus-tree-mode 'mode-class 'special) + +(unless gnus-tree-mode-map + (setq gnus-tree-mode-map (make-keymap)) + (suppress-keymap gnus-tree-mode-map) + (gnus-define-keys + gnus-tree-mode-map + "\r" gnus-tree-select-article + gnus-mouse-2 gnus-tree-pick-article + "\C-?" gnus-tree-read-summary-keys + "h" gnus-tree-show-summary + + "\C-c\C-i" gnus-info-find-node) + + (substitute-key-definition + 'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map)) + +(defun gnus-tree-make-menu-bar () + (unless (boundp 'gnus-tree-menu) + (easy-menu-define + gnus-tree-menu gnus-tree-mode-map "" + '("Tree" + ["Select article" gnus-tree-select-article t])))) + +(defun gnus-tree-mode () + "Major mode for displaying thread trees." + (interactive) + (gnus-set-format 'tree-mode) + (gnus-set-format 'tree t) + (when (gnus-visual-p 'tree-menu 'menu) + (gnus-tree-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq mode-name "Tree") + (setq major-mode 'gnus-tree-mode) + (use-local-map gnus-tree-mode-map) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (setq truncate-lines t) + (save-excursion + (gnus-set-work-buffer) + (gnus-tree-node-insert (make-mail-header "") nil) + (setq gnus-tree-node-length (1- (point)))) + (run-hooks 'gnus-tree-mode-hook)) + +(defun gnus-tree-read-summary-keys (&optional arg) + "Read a summary buffer key sequence and execute it." + (interactive "P") + (let ((buf (current-buffer)) + win) + (gnus-article-read-summary-keys arg nil t) + (when (setq win (get-buffer-window buf)) + (select-window win) + (when gnus-selected-tree-overlay + (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1))) + (gnus-tree-minimize)))) + +(defun gnus-tree-show-summary () + "Reconfigure windows to show summary buffer." + (interactive) + (if (not (gnus-buffer-live-p gnus-summary-buffer)) + (error "There is no summary buffer for this tree buffer") + (gnus-configure-windows 'article) + (gnus-summary-goto-subject gnus-current-article))) + +(defun gnus-tree-select-article (article) + "Select the article under point, if any." + (interactive (list (gnus-tree-article-number))) + (let ((buf (current-buffer))) + (when article + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-article article)) + (select-window (get-buffer-window buf))))) + +(defun gnus-tree-pick-article (e) + "Select the article under the mouse pointer." + (interactive "e") + (mouse-set-point e) + (gnus-tree-select-article (gnus-tree-article-number))) + +(defun gnus-tree-article-number () + (get-text-property (point) 'gnus-number)) + +(defun gnus-tree-article-region (article) + "Return a cons with BEG and END of the article region." + (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article))) + (when pos + (cons pos (next-single-property-change pos 'gnus-number))))) + +(defun gnus-tree-goto-article (article) + (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article))) + (when pos + (goto-char pos)))) + +(defun gnus-tree-recenter () + "Center point in the tree window." + (let ((selected (selected-window)) + (tree-window (get-buffer-window gnus-tree-buffer t))) + (when tree-window + (select-window tree-window) + (when gnus-selected-tree-overlay + (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1))) + (let* ((top (cond ((< (window-height) 4) 0) + ((< (window-height) 7) 1) + (t 2))) + (height (1- (window-height))) + (bottom (save-excursion (goto-char (point-max)) + (forward-line (- height)) + (point)))) + ;; Set the window start to either `bottom', which is the biggest + ;; possible valid number, or the second line from the top, + ;; whichever is the least. + (set-window-start + tree-window (min bottom (save-excursion + (forward-line (- top)) (point))))) + (select-window selected)))) + +(defun gnus-get-tree-buffer () + "Return the tree buffer properly initialized." + (save-excursion + (set-buffer (get-buffer-create gnus-tree-buffer)) + (unless (eq major-mode 'gnus-tree-mode) + (gnus-add-current-to-buffer-list) + (gnus-tree-mode)) + (current-buffer))) + +(defun gnus-tree-minimize () + (when (and gnus-tree-minimize-window + (not (one-window-p))) + (let ((windows 0) + tot-win-height) + (walk-windows (lambda (window) (incf windows))) + (setq tot-win-height + (- (frame-height) + (* window-min-height (1- windows)) + 2)) + (let* ((window-min-height 2) + (height (count-lines (point-min) (point-max))) + (min (max (1- window-min-height) height)) + (tot (if (numberp gnus-tree-minimize-window) + (min gnus-tree-minimize-window min) + min)) + (win (get-buffer-window (current-buffer))) + (wh (and win (1- (window-height win))))) + (setq tot (min tot tot-win-height)) + (when (and win + (not (eq tot wh))) + (let ((selected (selected-window))) + (when (ignore-errors (select-window win)) + (enlarge-window (- tot wh)) + (select-window selected)))))))) + +;;; Generating the tree. + +(defun gnus-tree-node-insert (header sparse &optional adopted) + (let* ((dummy (stringp header)) + (header (if (vectorp header) header + (progn + (setq header (make-mail-header "*****")) + (mail-header-set-number header 0) + (mail-header-set-lines header 0) + (mail-header-set-chars header 0) + header))) + (gnus-tmp-from (mail-header-from header)) + (gnus-tmp-subject (mail-header-subject header)) + (gnus-tmp-number (mail-header-number header)) + (gnus-tmp-name + (cond + ((string-match "(.+)" gnus-tmp-from) + (substring gnus-tmp-from + (1+ (match-beginning 0)) (1- (match-end 0)))) + ((string-match "<[^>]+> *$" gnus-tmp-from) + (let ((beg (match-beginning 0))) + (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) + (substring gnus-tmp-from (1+ (match-beginning 0)) + (1- (match-end 0)))) + (substring gnus-tmp-from 0 beg)))) + ((memq gnus-tmp-number sparse) + "***") + (t gnus-tmp-from))) + (gnus-tmp-open-bracket + (cond ((memq gnus-tmp-number sparse) + (caadr gnus-tree-brackets)) + (dummy (caaddr gnus-tree-brackets)) + (adopted (car (nth 3 gnus-tree-brackets))) + (t (caar gnus-tree-brackets)))) + (gnus-tmp-close-bracket + (cond ((memq gnus-tmp-number sparse) + (cdadr gnus-tree-brackets)) + (adopted (cdr (nth 3 gnus-tree-brackets))) + (dummy + (cdaddr gnus-tree-brackets)) + (t (cdar gnus-tree-brackets)))) + (buffer-read-only nil) + beg end) + (gnus-add-text-properties + (setq beg (point)) + (setq end (progn (eval gnus-tree-line-format-spec) (point))) + (list 'gnus-number gnus-tmp-number)) + (when (or t (gnus-visual-p 'tree-highlight 'highlight)) + (gnus-tree-highlight-node gnus-tmp-number beg end)))) + +(defun gnus-tree-highlight-node (article beg end) + "Highlight current line according to `gnus-summary-highlight'." + (let ((list gnus-summary-highlight) + face) + (save-excursion + (set-buffer gnus-summary-buffer) + (let* ((score (or (cdr (assq article gnus-newsgroup-scored)) + gnus-summary-default-score 0)) + (default gnus-summary-default-score) + (mark (or (gnus-summary-article-mark article) gnus-unread-mark))) + ;; Eval the cars of the lists until we find a match. + (while (and list + (not (eval (caar list)))) + (setq list (cdr list))))) + (unless (eq (setq face (cdar list)) (get-text-property beg 'face)) + (gnus-put-text-property + beg end 'face + (if (boundp face) (symbol-value face) face))))) + +(defun gnus-tree-indent (level) + (insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? ))) + +(defvar gnus-tmp-limit) +(defvar gnus-tmp-sparse) +(defvar gnus-tmp-indent) + +(defun gnus-generate-tree (thread) + "Generate a thread tree for THREAD." + (save-excursion + (set-buffer (gnus-get-tree-buffer)) + (let ((buffer-read-only nil) + (gnus-tmp-indent 0)) + (erase-buffer) + (funcall gnus-generate-tree-function thread 0) + (gnus-set-mode-line 'tree) + (goto-char (point-min)) + (gnus-tree-minimize) + (gnus-tree-recenter) + (let ((selected (selected-window))) + (when (get-buffer-window (set-buffer gnus-tree-buffer) t) + (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t)) + (gnus-horizontal-recenter) + (select-window selected)))))) + +(defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted) + "Generate a horizontal tree." + (let* ((dummy (stringp (car thread))) + (do (or dummy + (and (car thread) + (memq (mail-header-number (car thread)) + gnus-tmp-limit)))) + col beg) + (if (not do) + ;; We don't want this article. + (setq thread (cdr thread)) + (if (not (bolp)) + ;; Not the first article on the line, so we insert a "-". + (insert (car gnus-tree-parent-child-edges)) + ;; If the level isn't zero, then we insert some indentation. + (unless (zerop level) + (gnus-tree-indent level) + (insert (cadr gnus-tree-parent-child-edges)) + (setq col (- (setq beg (point)) (gnus-point-at-bol) 1)) + ;; Draw "|" lines upwards. + (while (progn + (forward-line -1) + (forward-char col) + (= (following-char) ? )) + (delete-char 1) + (insert (caddr gnus-tree-parent-child-edges))) + (goto-char beg))) + (setq dummyp nil) + ;; Insert the article node. + (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)) + (if (null thread) + ;; End of the thread, so we go to the next line. + (unless (bolp) + (insert "\n")) + ;; Recurse downwards in all children of this article. + (while thread + (gnus-generate-horizontal-tree + (pop thread) (if do (1+ level) level) + (or dummyp dummy) dummy))))) + +(defsubst gnus-tree-indent-vertical () + (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) + (- (point) (gnus-point-at-bol))))) + (when (> len 0) + (insert (make-string len ? ))))) + +(defsubst gnus-tree-forward-line (n) + (while (>= (decf n) 0) + (unless (zerop (forward-line 1)) + (end-of-line) + (insert "\n"))) + (end-of-line)) + +(defun gnus-generate-vertical-tree (thread level &optional dummyp adopted) + "Generate a vertical tree." + (let* ((dummy (stringp (car thread))) + (do (or dummy + (and (car thread) + (memq (mail-header-number (car thread)) + gnus-tmp-limit)))) + beg) + (if (not do) + ;; We don't want this article. + (setq thread (cdr thread)) + (if (not (save-excursion (beginning-of-line) (bobp))) + ;; Not the first article on the line, so we insert a "-". + (progn + (gnus-tree-indent-vertical) + (insert (make-string (/ gnus-tree-node-length 2) ? )) + (insert (caddr gnus-tree-parent-child-edges)) + (gnus-tree-forward-line 1)) + ;; If the level isn't zero, then we insert some indentation. + (unless (zerop gnus-tmp-indent) + (gnus-tree-forward-line (1- (* 2 level))) + (gnus-tree-indent-vertical) + (delete-char -1) + (insert (cadr gnus-tree-parent-child-edges)) + (setq beg (point)) + (forward-char -1) + ;; Draw "-" lines leftwards. + (while (= (char-after (1- (point))) ? ) + (delete-char -1) + (insert (car gnus-tree-parent-child-edges)) + (forward-char -1)) + (goto-char beg) + (gnus-tree-forward-line 1))) + (setq dummyp nil) + ;; Insert the article node. + (gnus-tree-indent-vertical) + (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted) + (gnus-tree-forward-line 1)) + (if (null thread) + ;; End of the thread, so we go to the next line. + (progn + (goto-char (point-min)) + (end-of-line) + (incf gnus-tmp-indent)) + ;; Recurse downwards in all children of this article. + (while thread + (gnus-generate-vertical-tree + (pop thread) (if do (1+ level) level) + (or dummyp dummy) dummy))))) + +;;; Interface functions. + +(defun gnus-possibly-generate-tree (article &optional force) + "Generate the thread tree for ARTICLE if it isn't displayed already." + (when (save-excursion + (set-buffer gnus-summary-buffer) + (and gnus-use-trees + gnus-show-threads + (vectorp (gnus-summary-article-header article)))) + (save-excursion + (let ((top (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-cut-thread + (gnus-remove-thread + (mail-header-id + (gnus-summary-article-header article)) + t)))) + (gnus-tmp-limit gnus-newsgroup-limit) + (gnus-tmp-sparse gnus-newsgroup-sparse)) + (when (or force + (not (eq top gnus-tree-displayed-thread))) + (gnus-generate-tree top) + (setq gnus-tree-displayed-thread top)))))) + +(defun gnus-tree-open (group) + (gnus-get-tree-buffer)) + +(defun gnus-tree-close (group) + ;(gnus-kill-buffer gnus-tree-buffer) + ) + +(defun gnus-highlight-selected-tree (article) + "Highlight the selected article in the tree." + (let ((buf (current-buffer)) + region) + (set-buffer gnus-tree-buffer) + (when (setq region (gnus-tree-article-region article)) + (when (or (not gnus-selected-tree-overlay) + (gnus-extent-detached-p gnus-selected-tree-overlay)) + ;; Create a new overlay. + (gnus-overlay-put + (setq gnus-selected-tree-overlay (gnus-make-overlay 1 2)) + 'face gnus-selected-tree-face)) + ;; Move the overlay to the article. + (gnus-move-overlay + gnus-selected-tree-overlay (goto-char (car region)) (cdr region)) + (gnus-tree-minimize) + (gnus-tree-recenter) + (let ((selected (selected-window))) + (when (get-buffer-window (set-buffer gnus-tree-buffer) t) + (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t)) + (gnus-horizontal-recenter) + (select-window selected)))) + ;; If we remove this save-excursion, it updates the wrong mode lines?!? + (save-excursion + (set-buffer gnus-tree-buffer) + (gnus-set-mode-line 'tree)) + (set-buffer buf))) + +(defun gnus-tree-highlight-article (article face) + (save-excursion + (set-buffer (gnus-get-tree-buffer)) + (let (region) + (when (setq region (gnus-tree-article-region article)) + (gnus-put-text-property (car region) (cdr region) 'face face) + (set-window-point + (get-buffer-window (current-buffer) t) (cdr region)))))) + +;;; +;;; gnus-carpal +;;; + +(defvar gnus-carpal-group-buffer-buttons + '(("next" . gnus-group-next-unread-group) + ("prev" . gnus-group-prev-unread-group) + ("read" . gnus-group-read-group) + ("select" . gnus-group-select-group) + ("catch-up" . gnus-group-catchup-current) + ("new-news" . gnus-group-get-new-news-this-group) + ("toggle-sub" . gnus-group-unsubscribe-current-group) + ("subscribe" . gnus-group-unsubscribe-group) + ("kill" . gnus-group-kill-group) + ("yank" . gnus-group-yank-group) + ("describe" . gnus-group-describe-group) + "list" + ("subscribed" . gnus-group-list-groups) + ("all" . gnus-group-list-all-groups) + ("killed" . gnus-group-list-killed) + ("zombies" . gnus-group-list-zombies) + ("matching" . gnus-group-list-matching) + ("post" . gnus-group-post-news) + ("mail" . gnus-group-mail) + ("rescan" . gnus-group-get-new-news) + ("browse-foreign" . gnus-group-browse-foreign) + ("exit" . gnus-group-exit))) + +(defvar gnus-carpal-summary-buffer-buttons + '("mark" + ("read" . gnus-summary-mark-as-read-forward) + ("tick" . gnus-summary-tick-article-forward) + ("clear" . gnus-summary-clear-mark-forward) + ("expirable" . gnus-summary-mark-as-expirable) + "move" + ("scroll" . gnus-summary-next-page) + ("next-unread" . gnus-summary-next-unread-article) + ("prev-unread" . gnus-summary-prev-unread-article) + ("first" . gnus-summary-first-unread-article) + ("best" . gnus-summary-best-unread-article) + "article" + ("headers" . gnus-summary-toggle-header) + ("uudecode" . gnus-uu-decode-uu) + ("enter-digest" . gnus-summary-enter-digest-group) + ("fetch-parent" . gnus-summary-refer-parent-article) + "mail" + ("move" . gnus-summary-move-article) + ("copy" . gnus-summary-copy-article) + ("respool" . gnus-summary-respool-article) + "threads" + ("lower" . gnus-summary-lower-thread) + ("kill" . gnus-summary-kill-thread) + "post" + ("post" . gnus-summary-post-news) + ("mail" . gnus-summary-mail) + ("followup" . gnus-summary-followup-with-original) + ("reply" . gnus-summary-reply-with-original) + ("cancel" . gnus-summary-cancel-article) + "misc" + ("exit" . gnus-summary-exit) + ("fed-up" . gnus-summary-catchup-and-goto-next-group))) + +(defvar gnus-carpal-server-buffer-buttons + '(("add" . gnus-server-add-server) + ("browse" . gnus-server-browse-server) + ("list" . gnus-server-list-servers) + ("kill" . gnus-server-kill-server) + ("yank" . gnus-server-yank-server) + ("copy" . gnus-server-copy-server) + ("exit" . gnus-server-exit))) + +(defvar gnus-carpal-browse-buffer-buttons + '(("subscribe" . gnus-browse-unsubscribe-current-group) + ("exit" . gnus-browse-exit))) + +(defvar gnus-carpal-group-buffer "*Carpal Group*") +(defvar gnus-carpal-summary-buffer "*Carpal Summary*") +(defvar gnus-carpal-server-buffer "*Carpal Server*") +(defvar gnus-carpal-browse-buffer "*Carpal Browse*") + +(defvar gnus-carpal-attached-buffer nil) + +(defvar gnus-carpal-mode-hook nil + "*Hook run in carpal mode buffers.") + +(defvar gnus-carpal-button-face 'bold + "*Face used on carpal buttons.") + +(defvar gnus-carpal-header-face 'bold-italic + "*Face used on carpal buffer headers.") + +(defvar gnus-carpal-mode-map nil) +(put 'gnus-carpal-mode 'mode-class 'special) + +(if gnus-carpal-mode-map + nil + (setq gnus-carpal-mode-map (make-keymap)) + (suppress-keymap gnus-carpal-mode-map) + (define-key gnus-carpal-mode-map " " 'gnus-carpal-select) + (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select) + (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select)) + +(defun gnus-carpal-mode () + "Major mode for clicking buttons. + +All normal editing commands are switched off. +\\ +The following commands are available: + +\\{gnus-carpal-mode-map}" + (interactive) + (kill-all-local-variables) + (setq mode-line-modified (cdr gnus-mode-line-modified)) + (setq major-mode 'gnus-carpal-mode) + (setq mode-name "Gnus Carpal") + (setq mode-line-process nil) + (use-local-map gnus-carpal-mode-map) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (make-local-variable 'gnus-carpal-attached-buffer) + (run-hooks 'gnus-carpal-mode-hook)) + +(defun gnus-carpal-setup-buffer (type) + (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) + (if (get-buffer buffer) + () + (save-excursion + (set-buffer (get-buffer-create buffer)) + (gnus-carpal-mode) + (setq gnus-carpal-attached-buffer + (intern (format "gnus-%s-buffer" type))) + (gnus-add-current-to-buffer-list) + (let ((buttons (symbol-value + (intern (format "gnus-carpal-%s-buffer-buttons" + type)))) + (buffer-read-only nil) + button) + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (if (stringp button) + (gnus-set-text-properties + (point) + (prog2 (insert button) (point) (insert " ")) + (list 'face gnus-carpal-header-face)) + (gnus-set-text-properties + (point) + (prog2 (insert (car button)) (point) (insert " ")) + (list 'gnus-callback (cdr button) + 'face gnus-carpal-button-face + gnus-mouse-face-prop 'highlight)))) + (let ((fill-column (- (window-width) 2))) + (fill-region (point-min) (point-max))) + (set-window-point (get-buffer-window (current-buffer)) + (point-min))))))) + +(defun gnus-carpal-select () + "Select the button under point." + (interactive) + (let ((func (get-text-property (point) 'gnus-callback))) + (if (null func) + () + (pop-to-buffer (symbol-value gnus-carpal-attached-buffer)) + (call-interactively func)))) + +(defun gnus-carpal-mouse-select (event) + "Select the button under the mouse pointer." + (interactive "e") + (mouse-set-point event) + (gnus-carpal-select)) + +;;; Allow redefinition of functions. +(gnus-ems-redefine) + +(provide 'gnus-salt) + +;;; gnus-salt.el ends here diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el new file mode 100644 index 0000000..59d4741 --- /dev/null +++ b/lisp/gnus-score.el @@ -0,0 +1,2840 @@ +1;;; gnus-score.el --- scoring code for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-sum) +(require 'gnus-range) +(require 'message) + +(defcustom gnus-global-score-files nil + "List of global score files and directories. +Set this variable if you want to use people's score files. One entry +for each score file or each score file directory. Gnus will decide +by itself what score files are applicable to which group. + +Say you want to use the single score file +\"/ftp.gnus.org@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all +score files in the \"/ftp.some-where:/pub/score\" directory. + + (setq gnus-global-score-files + '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\" + \"/ftp.some-where:/pub/score\"))" + :group 'gnus-score-files + :type '(repeat file)) + +(defcustom gnus-score-file-single-match-alist nil + "Alist mapping regexps to lists of score files. +Each element of this alist should be of the form + (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... ) + +If the name of a group is matched by REGEXP, the corresponding scorefiles +will be used for that group. +The first match found is used, subsequent matching entries are ignored (to +use multiple matches, see gnus-score-file-multiple-match-alist). + +These score files are loaded in addition to any files returned by +gnus-score-find-score-files-function (which see)." + :group 'gnus-score-files + :type '(repeat (cons regexp (repeat file)))) + +(defcustom gnus-score-file-multiple-match-alist nil + "Alist mapping regexps to lists of score files. +Each element of this alist should be of the form + (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... ) + +If the name of a group is matched by REGEXP, the corresponding scorefiles +will be used for that group. +If multiple REGEXPs match a group, the score files corresponding to each +match will be used (for only one match to be used, see +gnus-score-file-single-match-alist). + +These score files are loaded in addition to any files returned by +gnus-score-find-score-files-function (which see)." + :group 'gnus-score-files + :type '(repeat (cons regexp (repeat file)))) + +(defcustom gnus-score-file-suffix "SCORE" + "Suffix of the score files." + :group 'gnus-score-files + :type 'string) + +(defcustom gnus-adaptive-file-suffix "ADAPT" + "Suffix of the adaptive score files." + :group 'gnus-score-files + :group 'gnus-score-adapt + :type 'string) + +(defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews + "Function used to find score files. +The function will be called with the group name as the argument, and +should return a list of score files to apply to that group. The score +files do not actually have to exist. + +Predefined values are: + +gnus-score-find-single: Only apply the group's own score file. +gnus-score-find-hierarchical: Also apply score files from parent groups. +gnus-score-find-bnews: Apply score files whose names matches. + +See the documentation to these functions for more information. + +This variable can also be a list of functions to be called. Each +function should either return a list of score files, or a list of +score alists." + :group 'gnus-score-files + :type '(radio (function-item gnus-score-find-single) + (function-item gnus-score-find-hierarchical) + (function-item gnus-score-find-bnews) + (function :tag "Other"))) + +(defcustom gnus-score-interactive-default-score 1000 + "*Scoring commands will raise/lower the score with this number as the default." + :group 'gnus-score-default + :type 'integer) + +(defcustom gnus-score-expiry-days 7 + "*Number of days before unused score file entries are expired. +If this variable is nil, no score file entries will be expired." + :group 'gnus-score-expire + :type '(choice (const :tag "never" nil) + number)) + +(defcustom gnus-update-score-entry-dates t + "*In non-nil, update matching score entry dates. +If this variable is nil, then score entries that provide matches +will be expired along with non-matching score entries." + :group 'gnus-score-expire + :type 'boolean) + +(defcustom gnus-orphan-score nil + "*All orphans get this score added. Set in the score file." + :group 'gnus-score-default + :type '(choice (const nil) + integer)) + +(defcustom gnus-decay-scores nil + "*If non-nil, decay non-permanent scores." + :group 'gnus-score-decay + :type 'boolean) + +(defcustom gnus-decay-score-function 'gnus-decay-score + "*Function called to decay a score. +It is called with one parameter -- the score to be decayed." + :group 'gnus-score-decay + :type '(radio (function-item gnus-decay-score) + (function :tag "Other"))) + +(defcustom gnus-score-decay-constant 3 + "*Decay all \"small\" scores with this amount." + :group 'gnus-score-decay + :type 'integer) + +(defcustom gnus-score-decay-scale .05 + "*Decay all \"big\" scores with this factor." + :group 'gnus-score-decay + :type 'number) + +(defcustom gnus-home-score-file nil + "Variable to control where interactive score entries are to go. +It can be: + + * A string + This file file will be used as the home score file. + + * A function + The result of this function will be used as the home score file. + The function will be passed the name of the group as its + parameter. + + * A list + The elements in this list can be: + + * `(regexp file-name ...)' + If the `regexp' matches the group name, the first `file-name' will + will be used as the home score file. (Multiple filenames are + allowed so that one may use gnus-score-file-single-match-alist to + set this variable.) + + * A function. + If the function returns non-nil, the result will be used + as the home score file. The function will be passed the + name of the group as its parameter. + + * A string. Use the string as the home score file. + + The list will be traversed from the beginning towards the end looking + for matches." + :group 'gnus-score-files + :type '(choice string + (repeat (choice string + (cons regexp (repeat file)) + function)) + function)) + +(defcustom gnus-home-adapt-file nil + "Variable to control where new adaptive score entries are to go. +This variable allows the same syntax as `gnus-home-score-file'." + :group 'gnus-score-adapt + :group 'gnus-score-files + :type '(choice string + (repeat (choice string + (cons regexp (repeat file)) + function)) + function)) + +(defcustom gnus-default-adaptive-score-alist + '((gnus-kill-file-mark) + (gnus-unread-mark) + (gnus-read-mark (from 3) (subject 30)) + (gnus-catchup-mark (subject -10)) + (gnus-killed-mark (from -1) (subject -20)) + (gnus-del-mark (from -2) (subject -15))) +"Alist of marks and scores." +:group 'gnus-score-adapt +:type '(repeat (cons (symbol :tag "Mark") + (repeat (list (choice :tag "Header" + (const from) + (const subject) + (symbol :tag "other")) + (integer :tag "Score")))))) + +(defcustom gnus-ignored-adaptive-words nil + "List of words to be ignored when doing adaptive word scoring." + :group 'gnus-score-adapt + :type '(repeat string)) + +(defcustom gnus-default-ignored-adaptive-words + '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you" + "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can" + "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one" + "so" "we" "they" "what" "would" "any" "which" "about" "get" "your" + "use" "some" "me" "then" "name" "like" "out" "when" "up" "time" + "other" "more" "only" "just" "end" "also" "know" "how" "new" "should" + "been" "than" "them" "he" "who" "make" "may" "people" "these" "now" + "their" "here" "into" "first" "could" "way" "had" "see" "work" "well" + "were" "two" "very" "where" "while" "us" "because" "good" "same" + "even" "much" "most" "many" "such" "long" "his" "over" "last" "since" + "right" "before" "our" "without" "too" "those" "why" "must" "part" + "being" "current" "back" "still" "go" "point" "value" "each" "did" + "both" "true" "off" "say" "another" "state" "might" "under" "start" + "try" "re") + "Default list of words to be ignored when doing adaptive word scoring." + :group 'gnus-score-adapt + :type '(repeat string)) + +(defcustom gnus-default-adaptive-word-score-alist + `((,gnus-read-mark . 30) + (,gnus-catchup-mark . -10) + (,gnus-killed-mark . -20) + (,gnus-del-mark . -15)) +"Alist of marks and scores." +:group 'gnus-score-adapt +:type '(repeat (cons (character :tag "Mark") + (integer :tag "Score")))) + +(defcustom gnus-score-mimic-keymap nil + "*Have the score entry functions pretend that they are a keymap." + :group 'gnus-score-default + :type 'boolean) + +(defcustom gnus-score-exact-adapt-limit 10 + "*Number that says how long a match has to be before using substring matching. +When doing adaptive scoring, one normally uses fuzzy or substring +matching. However, if the header one matches is short, the possibility +for false positives is great, so if the length of the match is less +than this variable, exact matching will be used. + +If this variable is nil, exact matching will always be used." + :group 'gnus-score-adapt + :type '(choice (const nil) integer)) + +(defcustom gnus-score-uncacheable-files "ADAPT$" + "All score files that match this regexp will not be cached." + :group 'gnus-score-adapt + :group 'gnus-score-files + :type 'regexp) + +(defcustom gnus-score-default-header nil + "Default header when entering new scores. + +Should be one of the following symbols. + + a: from + s: subject + b: body + h: head + i: message-id + t: references + x: xref + l: lines + d: date + f: followup + +If nil, the user will be asked for a header." + :group 'gnus-score-default + :type '(choice (const :tag "from" a) + (const :tag "subject" s) + (const :tag "body" b) + (const :tag "head" h) + (const :tag "message-id" i) + (const :tag "references" t) + (const :tag "xref" x) + (const :tag "lines" l) + (const :tag "date" d) + (const :tag "followup" f) + (const :tag "ask" nil))) + +(defcustom gnus-score-default-type nil + "Default match type when entering new scores. + +Should be one of the following symbols. + + s: substring + e: exact string + f: fuzzy string + r: regexp string + b: before date + a: at date + n: this date + <: less than number + >: greater than number + =: equal to number + +If nil, the user will be asked for a match type." + :group 'gnus-score-default + :type '(choice (const :tag "substring" s) + (const :tag "exact string" e) + (const :tag "fuzzy string" f) + (const :tag "regexp string" r) + (const :tag "before date" b) + (const :tag "at date" a) + (const :tag "this date" n) + (const :tag "less than number" <) + (const :tag "greater than number" >) + (const :tag "equal than number" =) + (const :tag "ask" nil))) + +(defcustom gnus-score-default-fold nil + "Use case folding for new score file entries iff not nil." + :group 'gnus-score-default + :type 'boolean) + +(defcustom gnus-score-default-duration nil + "Default duration of effect when entering new scores. + +Should be one of the following symbols. + + t: temporary + p: permanent + i: immediate + +If nil, the user will be asked for a duration." + :group 'gnus-score-default + :type '(choice (const :tag "temporary" t) + (const :tag "permanent" p) + (const :tag "immediate" i) + (const :tag "ask" nil))) + +(defcustom gnus-score-after-write-file-function nil + "Function called with the name of the score file just written to disk." + :group 'gnus-score-files + :type 'function) + + + +;; Internal variables. + +(defvar gnus-adaptive-word-syntax-table + (let ((table (copy-syntax-table (standard-syntax-table))) + (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))) + (while numbers + (modify-syntax-entry (pop numbers) " " table)) + (modify-syntax-entry ?' "w" table) + table) + "Syntax table used when doing adaptive word scoring.") + +(defvar gnus-scores-exclude-files nil) +(defvar gnus-internal-global-score-files nil) +(defvar gnus-score-file-list nil) + +(defvar gnus-short-name-score-file-cache nil) + +(defvar gnus-score-help-winconf nil) +(defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist) +(defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist) +(defvar gnus-score-trace nil) +(defvar gnus-score-edit-buffer nil) + +(defvar gnus-score-alist nil + "Alist containing score information. +The keys can be symbols or strings. The following symbols are defined. + +touched: If this alist has been modified. +mark: Automatically mark articles below this. +expunge: Automatically expunge articles below this. +files: List of other score files to load when loading this one. +eval: Sexp to be evaluated when the score file is loaded. + +String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...) +where HEADER is the header being scored, MATCH is the string we are +looking for, TYPE is a flag indicating whether it should use regexp or +substring matching, SCORE is the score to add and DATE is the date +of the last successful match.") + +(defvar gnus-score-cache nil) +(defvar gnus-scores-articles nil) +(defvar gnus-score-index nil) + + +(defconst gnus-header-index + ;; Name to index alist. + '(("number" 0 gnus-score-integer) + ("subject" 1 gnus-score-string) + ("from" 2 gnus-score-string) + ("date" 3 gnus-score-date) + ("message-id" 4 gnus-score-string) + ("references" 5 gnus-score-string) + ("chars" 6 gnus-score-integer) + ("lines" 7 gnus-score-integer) + ("xref" 8 gnus-score-string) + ("head" -1 gnus-score-body) + ("body" -1 gnus-score-body) + ("all" -1 gnus-score-body) + ("followup" 2 gnus-score-followup) + ("thread" 5 gnus-score-thread))) + +;;; Summary mode score maps. + +(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) + "s" gnus-summary-set-score + "a" gnus-summary-score-entry + "S" gnus-summary-current-score + "c" gnus-score-change-score-file + "C" gnus-score-customize + "m" gnus-score-set-mark-below + "x" gnus-score-set-expunge-below + "R" gnus-summary-rescore + "e" gnus-score-edit-current-scores + "f" gnus-score-edit-file + "F" gnus-score-flush-cache + "t" gnus-score-find-trace + "w" gnus-score-find-favourite-words) + +;; Summary score file commands + +;; Much modification of the kill (ahem, score) code and lots of the +;; functions are written by Per Abrahamsen . + +(defun gnus-summary-lower-score (&optional score symp) + "Make a score entry based on the current article. +The user will be prompted for header to score on, match type, +permanence, and the string to be used. The numerical prefix will be +used as score." + (interactive (gnus-interactive "P\ny")) + (gnus-summary-increase-score (- (gnus-score-default score)) symp)) + +(defun gnus-score-kill-help-buffer () + (when (get-buffer "*Score Help*") + (kill-buffer "*Score Help*") + (when gnus-score-help-winconf + (set-window-configuration gnus-score-help-winconf)))) + +(defun gnus-summary-increase-score (&optional score symp) + "Make a score entry based on the current article. +The user will be prompted for header to score on, match type, +permanence, and the string to be used. The numerical prefix will be +used as score." + (interactive (gnus-interactive "P\ny")) + (gnus-set-global-variables) + (let* ((nscore (gnus-score-default score)) + (prefix (if (< nscore 0) ?L ?I)) + (increase (> nscore 0)) + (char-to-header + '((?a "from" nil nil string) + (?s "subject" nil nil string) + (?b "body" "" nil body-string) + (?h "head" "" nil body-string) + (?i "message-id" nil t string) + (?t "references" "message-id" nil string) + (?x "xref" nil nil string) + (?l "lines" nil nil number) + (?d "date" nil nil date) + (?f "followup" nil nil string) + (?T "thread" nil nil string))) + (char-to-type + '((?s s "substring" string) + (?e e "exact string" string) + (?f f "fuzzy string" string) + (?r r "regexp string" string) + (?z s "substring" body-string) + (?p r "regexp string" body-string) + (?b before "before date" date) + (?a at "at date" date) + (?n now "this date" date) + (?< < "less than number" number) + (?> > "greater than number" number) + (?= = "equal to number" number))) + (current-score-file gnus-current-score-file) + (char-to-perm + (list (list ?t (current-time-string) "temporary") + '(?p perm "permanent") '(?i now "immediate"))) + (mimic gnus-score-mimic-keymap) + (hchar (and gnus-score-default-header + (aref (symbol-name gnus-score-default-header) 0))) + (tchar (and gnus-score-default-type + (aref (symbol-name gnus-score-default-type) 0))) + (pchar (and gnus-score-default-duration + (aref (symbol-name gnus-score-default-duration) 0))) + entry temporary type match) + + (unwind-protect + (progn + + ;; First we read the header to score. + (while (not hchar) + (if mimic + (progn + (sit-for 1) + (message "%c-" prefix)) + (message "%s header (%s?): " (if increase "Increase" "Lower") + (mapconcat (lambda (s) (char-to-string (car s))) + char-to-header ""))) + (setq hchar (read-char)) + (when (or (= hchar ??) (= hchar ?\C-h)) + (setq hchar nil) + (gnus-score-insert-help "Match on header" char-to-header 1))) + + (gnus-score-kill-help-buffer) + (unless (setq entry (assq (downcase hchar) char-to-header)) + (if mimic (error "%c %c" prefix hchar) + (error "Illegal header type"))) + + (when (/= (downcase hchar) hchar) + ;; This was a majuscule, so we end reading and set the defaults. + (if mimic (message "%c %c" prefix hchar) (message "")) + (setq tchar (or tchar ?s) + pchar (or pchar ?t))) + + (let ((legal-types + (delq nil + (mapcar (lambda (s) + (if (eq (nth 4 entry) + (nth 3 s)) + s nil)) + char-to-type)))) + ;; We continue reading - the type. + (while (not tchar) + (if mimic + (progn + (sit-for 1) (message "%c %c-" prefix hchar)) + (message "%s header '%s' with match type (%s?): " + (if increase "Increase" "Lower") + (nth 1 entry) + (mapconcat (lambda (s) (char-to-string (car s))) + legal-types ""))) + (setq tchar (read-char)) + (when (or (= tchar ??) (= tchar ?\C-h)) + (setq tchar nil) + (gnus-score-insert-help "Match type" legal-types 2))) + + (gnus-score-kill-help-buffer) + (unless (setq type (nth 1 (assq (downcase tchar) legal-types))) + (if mimic (error "%c %c" prefix hchar) + (error "Illegal match type")))) + + (when (/= (downcase tchar) tchar) + ;; It was a majuscule, so we end reading and use the default. + (if mimic (message "%c %c %c" prefix hchar tchar) + (message "")) + (setq pchar (or pchar ?p))) + + ;; We continue reading. + (while (not pchar) + (if mimic + (progn + (sit-for 1) (message "%c %c %c-" prefix hchar tchar)) + (message "%s permanence (%s?): " (if increase "Increase" "Lower") + (mapconcat (lambda (s) (char-to-string (car s))) + char-to-perm ""))) + (setq pchar (read-char)) + (when (or (= pchar ??) (= pchar ?\C-h)) + (setq pchar nil) + (gnus-score-insert-help "Match permanence" char-to-perm 2))) + + (gnus-score-kill-help-buffer) + (if mimic (message "%c %c %c" prefix hchar tchar pchar) + (message "")) + (unless (setq temporary (cadr (assq pchar char-to-perm))) + ;; Deal with der(r)ided superannuated paradigms. + (when (and (eq (1+ prefix) 77) + (eq (+ hchar 12) 109) + (eq tchar 114) + (eq (- pchar 4) 111)) + (error "You rang?")) + (if mimic + (error "%c %c %c %c" prefix hchar tchar pchar) + (error "Illegal match duration")))) + ;; Always kill the score help buffer. + (gnus-score-kill-help-buffer)) + + ;; We have all the data, so we enter this score. + (setq match (if (string= (nth 2 entry) "") "" + (gnus-summary-header (or (nth 2 entry) (nth 1 entry))))) + + ;; Modify the match, perhaps. + (cond + ((equal (nth 1 entry) "xref") + (when (string-match "^Xref: *" match) + (setq match (substring match (match-end 0)))) + (when (string-match "^[^:]* +" match) + (setq match (substring match (match-end 0)))))) + + (when (memq type '(r R regexp Regexp)) + (setq match (regexp-quote match))) + + ;; Change score file to the "all.SCORE" file. + (when (eq symp 'a) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file + (gnus-score-file-name "all")))) + + (gnus-summary-score-entry + (nth 1 entry) ; Header + match ; Match + type ; Type + (if (eq score 's) nil score) ; Score + (if (eq temporary 'perm) ; Temp + nil + temporary) + (not (nth 3 entry))) ; Prompt + + (when (eq symp 'a) + ;; We change the score file back to the previous one. + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file current-score-file))))) + +(defun gnus-score-insert-help (string alist idx) + (setq gnus-score-help-winconf (current-window-configuration)) + (save-excursion + (set-buffer (get-buffer-create "*Score Help*")) + (buffer-disable-undo (current-buffer)) + (delete-windows-on (current-buffer)) + (erase-buffer) + (insert string ":\n\n") + (let ((max -1) + (list alist) + (i 0) + n width pad format) + ;; find the longest string to display + (while list + (setq n (length (nth idx (car list)))) + (unless (> max n) + (setq max n)) + (setq list (cdr list))) + (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end + (setq n (/ (1- (window-width)) max)) ; items per line + (setq width (/ (1- (window-width)) n)) ; width of each item + ;; insert `n' items, each in a field of width `width' + (while alist + (if (< i n) + () + (setq i 0) + (delete-char -1) ; the `\n' takes a char + (insert "\n")) + (setq pad (- width 3)) + (setq format (concat "%c: %-" (int-to-string pad) "s")) + (insert (format format (caar alist) (nth idx (car alist)))) + (setq alist (cdr alist)) + (setq i (1+ i)))) + ;; display ourselves in a small window at the bottom + (gnus-appt-select-lowest-window) + (split-window) + (pop-to-buffer "*Score Help*") + (let ((window-min-height 1)) + (shrink-window-if-larger-than-buffer)) + (select-window (get-buffer-window gnus-summary-buffer)))) + +(defun gnus-summary-header (header &optional no-err) + ;; Return HEADER for current articles, or error. + (let ((article (gnus-summary-article-number)) + headers) + (if article + (if (and (setq headers (gnus-summary-article-header article)) + (vectorp headers)) + (aref headers (nth 1 (assoc header gnus-header-index))) + (if no-err + nil + (error "Pseudo-articles can't be scored"))) + (if no-err + (error "No article on current line") + nil)))) + +(defun gnus-newsgroup-score-alist () + (or + (let ((param-file (gnus-group-find-parameter + gnus-newsgroup-name 'score-file))) + (when param-file + (gnus-score-load param-file))) + (gnus-score-load + (gnus-score-file-name gnus-newsgroup-name))) + gnus-score-alist) + +(defsubst gnus-score-get (symbol &optional alist) + ;; Get SYMBOL's definition in ALIST. + (cdr (assoc symbol + (or alist + gnus-score-alist + (gnus-newsgroup-score-alist))))) + +(defun gnus-summary-score-entry (header match type score date + &optional prompt silent) + "Enter score file entry. +HEADER is the header being scored. +MATCH is the string we are looking for. +TYPE is the match type: substring, regexp, exact, fuzzy. +SCORE is the score to add. +DATE is the expire date, or nil for no expire, or 'now for immediate expire. +If optional argument `PROMPT' is non-nil, allow user to edit match. +If optional argument `SILENT' is nil, show effect of score entry." + (interactive + (list (completing-read "Header: " + gnus-header-index + (lambda (x) (fboundp (nth 2 x))) + t) + (read-string "Match: ") + (if (y-or-n-p "Use regexp match? ") 'r 's) + (and current-prefix-arg + (prefix-numeric-value current-prefix-arg)) + (cond ((not (y-or-n-p "Add to score file? ")) + 'now) + ((y-or-n-p "Expire kill? ") + (current-time-string)) + (t nil)))) + ;; Regexp is the default type. + (when (eq type t) + (setq type 'r)) + ;; Simplify matches... + (cond ((or (eq type 'r) (eq type 's) (eq type nil)) + (setq match (if match (gnus-simplify-subject-re match) ""))) + ((eq type 'f) + (setq match (gnus-simplify-subject-fuzzy match)))) + (let ((score (gnus-score-default score)) + (header (format "%s" (downcase header))) + new) + (when prompt + (setq match (read-string + (format "Match %s on %s, %s: " + (cond ((eq date 'now) + "now") + ((stringp date) + "temp") + (t "permanent")) + header + (if (< score 0) "lower" "raise")) + (if (numberp match) + (int-to-string match) + match)))) + + ;; Get rid of string props. + (setq match (format "%s" match)) + + ;; If this is an integer comparison, we transform from string to int. + (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) + (setq match (string-to-int match))) + + (unless (eq date 'now) + ;; Add the score entry to the score file. + (when (= score gnus-score-interactive-default-score) + (setq score nil)) + (let ((old (gnus-score-get header)) + elem) + (setq new + (cond + (type + (list match score + (and date (if (numberp date) date + (gnus-day-number date))) + type)) + (date (list match score (gnus-day-number date))) + (score (list match score)) + (t (list match)))) + ;; We see whether we can collapse some score entries. + ;; This isn't quite correct, because there may be more elements + ;; later on with the same key that have matching elems... Hm. + (if (and old + (setq elem (assoc match old)) + (eq (nth 3 elem) (nth 3 new)) + (or (and (numberp (nth 2 elem)) (numberp (nth 2 new))) + (and (not (nth 2 elem)) (not (nth 2 new))))) + ;; Yup, we just add this new score to the old elem. + (setcar (cdr elem) (+ (or (nth 1 elem) + gnus-score-interactive-default-score) + (or (nth 1 new) + gnus-score-interactive-default-score))) + ;; Nope, we have to add a new elem. + (gnus-score-set header (if old (cons new old) (list new)))) + (gnus-score-set 'touched '(t)))) + + ;; Score the current buffer. + (unless silent + (if (and (>= (nth 1 (assoc header gnus-header-index)) 0) + (eq (nth 2 (assoc header gnus-header-index)) + 'gnus-score-string)) + (gnus-summary-score-effect header match type score) + (gnus-summary-rescore))) + + ;; Return the new scoring rule. + new)) + +(defun gnus-summary-score-effect (header match type score) + "Simulate the effect of a score file entry. +HEADER is the header being scored. +MATCH is the string we are looking for. +TYPE is the score type. +SCORE is the score to add." + (interactive (list (completing-read "Header: " + gnus-header-index + (lambda (x) (fboundp (nth 2 x))) + t) + (read-string "Match: ") + (y-or-n-p "Use regexp match? ") + (prefix-numeric-value current-prefix-arg))) + (save-excursion + (unless (and (stringp match) (> (length match) 0)) + (error "No match")) + (goto-char (point-min)) + (let ((regexp (cond ((eq type 'f) + (gnus-simplify-subject-fuzzy match)) + ((eq type 'r) + match) + ((eq type 'e) + (concat "\\`" (regexp-quote match) "\\'")) + (t + (regexp-quote match))))) + (while (not (eobp)) + (let ((content (gnus-summary-header header 'noerr)) + (case-fold-search t)) + (and content + (when (if (eq type 'f) + (string-equal (gnus-simplify-subject-fuzzy content) + regexp) + (string-match regexp content)) + (gnus-summary-raise-score score)))) + (beginning-of-line 2)))) + (gnus-set-mode-line 'summary)) + +(defun gnus-summary-score-crossposting (score date) + ;; Enter score file entry for current crossposting. + ;; SCORE is the score to add. + ;; DATE is the expire date. + (let ((xref (gnus-summary-header "xref")) + (start 0) + group) + (unless xref + (error "This article is not crossposted")) + (while (string-match " \\([^ \t]+\\):" xref start) + (setq start (match-end 0)) + (when (not (string= + (setq group + (substring xref (match-beginning 1) (match-end 1))) + gnus-newsgroup-name)) + (gnus-summary-score-entry + "xref" (concat " " group ":") nil score date t))))) + + +;;; +;;; Gnus Score Files +;;; + +;; All score code written by Per Abrahamsen . + +;; Added by Per Abrahamsen . +(defun gnus-score-set-mark-below (score) + "Automatically mark articles with score below SCORE as read." + (interactive + (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) + (string-to-int (read-string "Mark below: "))))) + (setq score (or score gnus-summary-default-score 0)) + (gnus-score-set 'mark (list score)) + (gnus-score-set 'touched '(t)) + (setq gnus-summary-mark-below score) + (gnus-score-update-lines)) + +(defun gnus-score-update-lines () + "Update all lines in the summary buffer." + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (gnus-summary-update-line) + (forward-line 1)))) + +(defun gnus-score-update-all-lines () + "Update all lines in the summary buffer, even the hidden ones." + (save-excursion + (goto-char (point-min)) + (let (hidden) + (while (not (eobp)) + (when (gnus-summary-show-thread) + (push (point) hidden)) + (gnus-summary-update-line) + (forward-line 1)) + ;; Re-hide the hidden threads. + (while hidden + (goto-char (pop hidden)) + (gnus-summary-hide-thread))))) + +(defun gnus-score-set-expunge-below (score) + "Automatically expunge articles with score below SCORE." + (interactive + (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) + (string-to-int (read-string "Set expunge below: "))))) + (setq score (or score gnus-summary-default-score 0)) + (gnus-score-set 'expunge (list score)) + (gnus-score-set 'touched '(t))) + +(defun gnus-score-followup-article (&optional score) + "Add SCORE to all followups to the article in the current buffer." + (interactive "P") + (setq score (gnus-score-default score)) + (when (gnus-buffer-live-p gnus-summary-buffer) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (let ((id (mail-fetch-field "message-id"))) + (when id + (set-buffer gnus-summary-buffer) + (gnus-summary-score-entry + "references" (concat id "[ \t]*$") 'r + score (current-time-string) nil t))))))) + +(defun gnus-score-followup-thread (&optional score) + "Add SCORE to all later articles in the thread the current buffer is part of." + (interactive "P") + (setq score (gnus-score-default score)) + (when (gnus-buffer-live-p gnus-summary-buffer) + (save-excursion + (save-restriction + (goto-char (point-min)) + (let ((id (mail-fetch-field "message-id"))) + (when id + (set-buffer gnus-summary-buffer) + (gnus-summary-score-entry + "references" id 's + score (current-time-string)))))))) + +(defun gnus-score-set (symbol value &optional alist) + ;; Set SYMBOL to VALUE in ALIST. + (let* ((alist + (or alist + gnus-score-alist + (gnus-newsgroup-score-alist))) + (entry (assoc symbol alist))) + (cond ((gnus-score-get 'read-only alist) + ;; This is a read-only score file, so we do nothing. + ) + (entry + (setcdr entry value)) + ((null alist) + (error "Empty alist")) + (t + (setcdr alist + (cons (cons symbol value) (cdr alist))))))) + +(defun gnus-summary-raise-score (n) + "Raise the score of the current article by N." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-set-score (+ (gnus-summary-article-score) + (or n gnus-score-interactive-default-score )))) + +(defun gnus-summary-set-score (n) + "Set the score of the current article to N." + (interactive "p") + (gnus-set-global-variables) + (save-excursion + (gnus-summary-show-thread) + (let ((buffer-read-only nil)) + ;; Set score. + (gnus-summary-update-mark + (if (= n (or gnus-summary-default-score 0)) ? + (if (< n (or gnus-summary-default-score 0)) + gnus-score-below-mark gnus-score-over-mark)) + 'score)) + (let* ((article (gnus-summary-article-number)) + (score (assq article gnus-newsgroup-scored))) + (if score (setcdr score n) + (push (cons article n) gnus-newsgroup-scored))) + (gnus-summary-update-line))) + +(defun gnus-summary-current-score () + "Return the score of the current article." + (interactive) + (gnus-set-global-variables) + (gnus-message 1 "%s" (gnus-summary-article-score))) + +(defun gnus-score-change-score-file (file) + "Change current score alist." + (interactive + (list (read-file-name "Change to score file: " gnus-kill-files-directory))) + (gnus-score-load-file file) + (gnus-set-mode-line 'summary)) + +(defvar gnus-score-edit-exit-function) +(defun gnus-score-edit-current-scores (file) + "Edit the current score alist." + (interactive (list gnus-current-score-file)) + (gnus-set-global-variables) + (let ((winconf (current-window-configuration))) + (when (buffer-name gnus-summary-buffer) + (gnus-score-save)) + (gnus-make-directory (file-name-directory file)) + (setq gnus-score-edit-buffer (find-file-noselect file)) + (gnus-configure-windows 'edit-score) + (select-window (get-buffer-window gnus-score-edit-buffer)) + (gnus-score-mode) + (setq gnus-score-edit-exit-function 'gnus-score-edit-done) + (make-local-variable 'gnus-prev-winconf) + (setq gnus-prev-winconf winconf)) + (gnus-message + 4 (substitute-command-keys + "\\\\[gnus-score-edit-exit] to save edits"))) + +(defun gnus-score-edit-file (file) + "Edit a score file." + (interactive + (list (read-file-name "Edit score file: " gnus-kill-files-directory))) + (gnus-make-directory (file-name-directory file)) + (when (buffer-name gnus-summary-buffer) + (gnus-score-save)) + (let ((winconf (current-window-configuration))) + (setq gnus-score-edit-buffer (find-file-noselect file)) + (gnus-configure-windows 'edit-score) + (gnus-score-mode) + (setq gnus-score-edit-exit-function 'gnus-score-edit-done) + (make-local-variable 'gnus-prev-winconf) + (setq gnus-prev-winconf winconf)) + (gnus-message + 4 (substitute-command-keys + "\\\\[gnus-score-edit-exit] to save edits"))) + +(defun gnus-score-load-file (file) + ;; Load score file FILE. Returns a list a retrieved score-alists. + (let* ((file (expand-file-name + (or (and (string-match + (concat "^" (expand-file-name + gnus-kill-files-directory)) + (expand-file-name file)) + file) + (concat (file-name-as-directory gnus-kill-files-directory) + file)))) + (cached (assoc file gnus-score-cache)) + (global (member file gnus-internal-global-score-files)) + lists alist) + (if cached + ;; The score file was already loaded. + (setq alist (cdr cached)) + ;; We load the score file. + (setq gnus-score-alist nil) + (setq alist (gnus-score-load-score-alist file)) + ;; We add '(touched) to the alist to signify that it hasn't been + ;; touched (yet). + (unless (assq 'touched alist) + (push (list 'touched nil) alist)) + ;; If it is a global score file, we make it read-only. + (and global + (not (assq 'read-only alist)) + (push (list 'read-only t) alist)) + (push (cons file alist) gnus-score-cache)) + (let ((a alist) + found) + (while a + ;; Downcase all header names. + (when (stringp (caar a)) + (setcar (car a) (downcase (caar a))) + (setq found t)) + (pop a)) + ;; If there are actual scores in the alist, we add it to the + ;; return value of this function. + (when found + (setq lists (list alist)))) + ;; Treat the other possible atoms in the score alist. + (let ((mark (car (gnus-score-get 'mark alist))) + (expunge (car (gnus-score-get 'expunge alist))) + (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist))) + (files (gnus-score-get 'files alist)) + (exclude-files (gnus-score-get 'exclude-files alist)) + (orphan (car (gnus-score-get 'orphan alist))) + (adapt (gnus-score-get 'adapt alist)) + (thread-mark-and-expunge + (car (gnus-score-get 'thread-mark-and-expunge alist))) + (adapt-file (car (gnus-score-get 'adapt-file alist))) + (local (gnus-score-get 'local alist)) + (decay (car (gnus-score-get 'decay alist))) + (eval (car (gnus-score-get 'eval alist)))) + ;; Perform possible decays. + (when (and gnus-decay-scores + (or (not decay) + (gnus-decay-scores alist decay))) + (gnus-score-set 'touched '(t) alist) + (gnus-score-set 'decay (list (gnus-time-to-day (current-time))))) + ;; We do not respect eval and files atoms from global score + ;; files. + (when (and files (not global)) + (setq lists (apply 'append lists + (mapcar (lambda (file) + (gnus-score-load-file file)) + (if adapt-file (cons adapt-file files) + files))))) + (when (and eval (not global)) + (eval eval)) + ;; We then expand any exclude-file directives. + (setq gnus-scores-exclude-files + (nconc + (mapcar + (lambda (sfile) + (expand-file-name sfile (file-name-directory file))) + exclude-files) + gnus-scores-exclude-files)) + (unless local + (save-excursion + (set-buffer gnus-summary-buffer) + (while local + (and (consp (car local)) + (symbolp (caar local)) + (progn + (make-local-variable (caar local)) + (set (caar local) (nth 1 (car local))))) + (setq local (cdr local))))) + (when orphan + (setq gnus-orphan-score orphan)) + (setq gnus-adaptive-score-alist + (cond ((equal adapt '(t)) + (setq gnus-newsgroup-adaptive t) + gnus-default-adaptive-score-alist) + ((equal adapt '(ignore)) + (setq gnus-newsgroup-adaptive nil)) + ((consp adapt) + (setq gnus-newsgroup-adaptive t) + adapt) + (t + ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) + gnus-default-adaptive-score-alist))) + (setq gnus-thread-expunge-below + (or thread-mark-and-expunge gnus-thread-expunge-below)) + (setq gnus-summary-mark-below + (or mark mark-and-expunge gnus-summary-mark-below)) + (setq gnus-summary-expunge-below + (or expunge mark-and-expunge gnus-summary-expunge-below)) + (setq gnus-newsgroup-adaptive-score-file + (or adapt-file gnus-newsgroup-adaptive-score-file))) + (setq gnus-current-score-file file) + (setq gnus-score-alist alist) + lists)) + +(defun gnus-score-load (file) + ;; Load score FILE. + (let ((cache (assoc file gnus-score-cache))) + (if cache + (setq gnus-score-alist (cdr cache)) + (setq gnus-score-alist nil) + (gnus-score-load-score-alist file) + (unless gnus-score-alist + (setq gnus-score-alist (copy-alist '((touched nil))))) + (push (cons file gnus-score-alist) gnus-score-cache)))) + +(defun gnus-score-remove-from-cache (file) + (setq gnus-score-cache + (delq (assoc file gnus-score-cache) gnus-score-cache))) + +(defun gnus-score-load-score-alist (file) + "Read score FILE." + (let (alist) + (if (not (file-readable-p file)) + ;; Couldn't read file. + (setq gnus-score-alist nil) + ;; Read file. + (save-excursion + (gnus-set-work-buffer) + (insert-file-contents file) + (goto-char (point-min)) + ;; Only do the loading if the score file isn't empty. + (when (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t)) + (setq alist + (condition-case () + (read (current-buffer)) + (error + (gnus-error 3.2 "Problem with score file %s" file)))))) + (if (eq (car alist) 'setq) + ;; This is an old-style score file. + (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) + (setq gnus-score-alist alist)) + ;; Check the syntax of the score file. + (setq gnus-score-alist + (gnus-score-check-syntax gnus-score-alist file))))) + +(defun gnus-score-check-syntax (alist file) + "Check the syntax of the score ALIST." + (cond + ((null alist) + nil) + ((not (consp alist)) + (gnus-message 1 "Score file is not a list: %s" file) + (ding) + nil) + (t + (let ((a alist) + sr err s type) + (while (and a (not err)) + (setq + err + (cond + ((not (listp (car a))) + (format "Illegal score element %s in %s" (car a) file)) + ((stringp (caar a)) + (cond + ((not (listp (setq sr (cdar a)))) + (format "Illegal header match %s in %s" (nth 1 (car a)) file)) + (t + (setq type (caar a)) + (while (and sr (not err)) + (setq s (pop sr)) + (setq + err + (cond + ((if (member (downcase type) '("lines" "chars")) + (not (numberp (car s))) + (not (stringp (car s)))) + (format "Illegal match %s in %s" (car s) file)) + ((and (cadr s) (not (integerp (cadr s)))) + (format "Non-integer score %s in %s" (cadr s) file)) + ((and (caddr s) (not (integerp (caddr s)))) + (format "Non-integer date %s in %s" (caddr s) file)) + ((and (cadddr s) (not (symbolp (cadddr s)))) + (format "Non-symbol match type %s in %s" (cadddr s) file))))) + err))))) + (setq a (cdr a))) + (if err + (progn + (ding) + (gnus-message 3 err) + (sit-for 2) + nil) + alist))))) + +(defun gnus-score-transform-old-to-new (alist) + (let* ((alist (nth 2 alist)) + out entry) + (when (eq (car alist) 'quote) + (setq alist (nth 1 alist))) + (while alist + (setq entry (car alist)) + (if (stringp (car entry)) + (let ((scor (cdr entry))) + (push entry out) + (while scor + (setcar scor + (list (caar scor) (nth 2 (car scor)) + (and (nth 3 (car scor)) + (gnus-day-number (nth 3 (car scor)))) + (if (nth 1 (car scor)) 'r 's))) + (setq scor (cdr scor)))) + (push (if (not (listp (cdr entry))) + (list (car entry) (cdr entry)) + entry) + out)) + (setq alist (cdr alist))) + (cons (list 'touched t) (nreverse out)))) + +(defun gnus-score-save () + ;; Save all score information. + (let ((cache gnus-score-cache) + entry score file) + (save-excursion + (setq gnus-score-alist nil) + (nnheader-set-temp-buffer " *Gnus Scores*") + (while cache + (current-buffer) + (setq entry (pop cache) + file (car entry) + score (cdr entry)) + (if (or (not (equal (gnus-score-get 'touched score) '(t))) + (gnus-score-get 'read-only score) + (and (file-exists-p file) + (not (file-writable-p file)))) + () + (setq score (setcdr entry (delq (assq 'touched score) score))) + (erase-buffer) + (let (emacs-lisp-mode-hook) + (if (string-match + (concat (regexp-quote gnus-adaptive-file-suffix) "$") + file) + ;; This is an adaptive score file, so we do not run + ;; it through `pp'. These files can get huge, and + ;; are not meant to be edited by human hands. + (gnus-prin1 score) + ;; This is a normal score file, so we print it very + ;; prettily. + (pp score (current-buffer)))) + (gnus-make-directory (file-name-directory file)) + ;; If the score file is empty, we delete it. + (if (zerop (buffer-size)) + (delete-file file) + ;; There are scores, so we write the file. + (when (file-writable-p file) + (gnus-write-buffer file) + (when gnus-score-after-write-file-function + (funcall gnus-score-after-write-file-function file))))) + (and gnus-score-uncacheable-files + (string-match gnus-score-uncacheable-files file) + (gnus-score-remove-from-cache file))) + (kill-buffer (current-buffer))))) + +(defun gnus-score-load-files (score-files) + "Load all score files in SCORE-FILES." + ;; Load the score files. + (let (scores) + (while score-files + (if (stringp (car score-files)) + ;; It is a string, which means that it's a score file name, + ;; so we load the score file and add the score alist to + ;; the list of alists. + (setq scores (nconc (gnus-score-load-file (car score-files)) scores)) + ;; It is an alist, so we just add it to the list directly. + (setq scores (nconc (car score-files) scores))) + (setq score-files (cdr score-files))) + ;; Prune the score files that are to be excluded, if any. + (when gnus-scores-exclude-files + (let ((s scores) + c) + (while s + (and (setq c (rassq (car s) gnus-score-cache)) + (member (car c) gnus-scores-exclude-files) + (setq scores (delq (car s) scores))) + (setq s (cdr s))))) + scores)) + +(defun gnus-score-headers (score-files &optional trace) + ;; Score `gnus-newsgroup-headers'. + (let (scores news) + ;; PLM: probably this is not the best place to clear orphan-score + (setq gnus-orphan-score nil + gnus-scores-articles nil + gnus-scores-exclude-files nil + scores (gnus-score-load-files score-files)) + (setq news scores) + ;; Do the scoring. + (while news + (setq scores news + news nil) + (when (and gnus-summary-default-score + scores) + (let* ((entries gnus-header-index) + (now (gnus-day-number (current-time-string))) + (expire (and gnus-score-expiry-days + (- now gnus-score-expiry-days))) + (headers gnus-newsgroup-headers) + (current-score-file gnus-current-score-file) + entry header new) + (gnus-message 5 "Scoring...") + ;; Create articles, an alist of the form `(HEADER . SCORE)'. + (while (setq header (pop headers)) + ;; WARNING: The assq makes the function O(N*S) while it could + ;; be written as O(N+S), where N is (length gnus-newsgroup-headers) + ;; and S is (length gnus-newsgroup-scored). + (unless (assq (mail-header-number header) gnus-newsgroup-scored) + (setq gnus-scores-articles ;Total of 2 * N cons-cells used. + (cons (cons header (or gnus-summary-default-score 0)) + gnus-scores-articles)))) + + (save-excursion + (set-buffer (get-buffer-create "*Headers*")) + (buffer-disable-undo (current-buffer)) + (when (gnus-buffer-live-p gnus-summary-buffer) + (message-clone-locals gnus-summary-buffer)) + + ;; Set the global variant of this variable. + (setq gnus-current-score-file current-score-file) + ;; score orphans + (when gnus-orphan-score + (setq gnus-score-index + (nth 1 (assoc "references" gnus-header-index))) + (gnus-score-orphans gnus-orphan-score)) + ;; Run each header through the score process. + (while entries + (setq entry (pop entries) + header (nth 0 entry) + gnus-score-index (nth 1 (assoc header gnus-header-index))) + (when (< 0 (apply 'max (mapcar + (lambda (score) + (length (gnus-score-get header score))) + scores))) + ;; Call the scoring function for this type of "header". + (when (setq new (funcall (nth 2 entry) scores header + now expire trace)) + (push new news)))) + ;; Remove the buffer. + (kill-buffer (current-buffer))) + + ;; Add articles to `gnus-newsgroup-scored'. + (while gnus-scores-articles + (when (or (/= gnus-summary-default-score + (cdar gnus-scores-articles)) + gnus-save-score) + (push (cons (mail-header-number (caar gnus-scores-articles)) + (cdar gnus-scores-articles)) + gnus-newsgroup-scored)) + (setq gnus-scores-articles (cdr gnus-scores-articles))) + + (let (score) + (while (setq score (pop scores)) + (while score + (when (listp (caar score)) + (gnus-score-advanced (car score) trace)) + (pop score)))) + + (gnus-message 5 "Scoring...done")))))) + + +(defun gnus-get-new-thread-ids (articles) + (let ((index (nth 1 (assoc "message-id" gnus-header-index))) + (refind gnus-score-index) + id-list art this tref) + (while articles + (setq art (car articles) + this (aref (car art) index) + tref (aref (car art) refind) + articles (cdr articles)) + (when (string-equal tref "") ;no references line + (push this id-list))) + id-list)) + +;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). +(defun gnus-score-orphans (score) + (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles)) + alike articles art arts this last this-id) + + (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + articles gnus-scores-articles) + + ;;more or less the same as in gnus-score-string + (erase-buffer) + (while articles + (setq art (car articles) + this (aref (car art) gnus-score-index) + articles (cdr articles)) + ;;completely skip if this is empty (not a child, so not an orphan) + (when (not (string= this "")) + (if (equal last this) + ;; O(N*H) cons-cells used here, where H is the number of + ;; headers. + (push art alike) + (when last + ;; Insert the line, with a text property on the + ;; terminating newline referring to the articles with + ;; this line. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + (setq alike (list art) + last this)))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + + ;; PLM: now delete those lines that contain an entry from new-thread-ids + (while new-thread-ids + (setq this-id (car new-thread-ids) + new-thread-ids (cdr new-thread-ids)) + (goto-char (point-min)) + (while (search-forward this-id nil t) + ;; found a match. remove this line + (beginning-of-line) + (kill-line 1))) + + ;; now for each line: update its articles with score by moving to + ;; every end-of-line in the buffer and read the articles property + (goto-char (point-min)) + (while (eq 0 (progn + (end-of-line) + (setq arts (get-text-property (point) 'articles)) + (while arts + (setq art (car arts) + arts (cdr arts)) + (setcdr art (+ score (cdr art)))) + (forward-line)))))) + + +(defun gnus-score-integer (scores header now expire &optional trace) + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + entries alist) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) '>)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (match-func (if (or (eq type '>) (eq type '<) (eq type '<=) + (eq type '>=) (eq type '=)) + type + (error "Illegal match type: %s" type))) + (articles gnus-scores-articles)) + ;; Instead of doing all the clever stuff that + ;; `gnus-score-string' does to minimize searches and stuff, + ;; I will assume that people generally will put so few + ;; matches on numbers that any cleverness will take more + ;; time than one would gain. + (while articles + (when (funcall match-func + (or (aref (caar articles) gnus-score-index) 0) + match) + (when trace + (push (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace)) + (setq found t) + (setcdr (car articles) (+ score (cdar articles)))) + (setq articles (cdr articles))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + ((and found gnus-update-score-entry-dates) ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((and expire (< date expire)) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest))))) + nil) + +(defun gnus-score-date (scores header now expire &optional trace) + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + entries alist match match-func article) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (type (or (nth 3 kill) 'before)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (articles gnus-scores-articles) + l) + (cond + ((eq type 'after) + (setq match-func 'string< + match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type 'before) + (setq match-func 'gnus-string> + match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type 'at) + (setq match-func 'string= + match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type 'regexp) + (setq match-func 'string-match + match (nth 0 kill))) + (t (error "Illegal match type: %s" type))) + ;; Instead of doing all the clever stuff that + ;; `gnus-score-string' does to minimize searches and stuff, + ;; I will assume that people generally will put so few + ;; matches on numbers that any cleverness will take more + ;; time than one would gain. + (while (setq article (pop articles)) + (when (and + (setq l (aref (car article) gnus-score-index)) + (funcall match-func match (gnus-date-iso8601 l))) + (when trace + (push (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace)) + (setq found t) + (setcdr article (+ score (cdr article))))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + ((and found gnus-update-score-entry-dates) ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((and expire (< date expire)) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest))))) + nil) + +(defun gnus-score-body (scores header now expire &optional trace) + (save-excursion + (setq gnus-scores-articles + (sort gnus-scores-articles + (lambda (a1 a2) + (< (mail-header-number (car a1)) + (mail-header-number (car a2)))))) + (set-buffer nntp-server-buffer) + (save-restriction + (let* ((buffer-read-only nil) + (articles gnus-scores-articles) + (all-scores scores) + (request-func (cond ((string= "head" header) + 'gnus-request-head) + ((string= "body" header) + 'gnus-request-body) + (t 'gnus-request-article))) + entries alist ofunc article last) + (when articles + (setq last (mail-header-number (caar (last articles)))) + ;; Not all backends support partial fetching. In that case, + ;; we just fetch the entire article. + (unless (gnus-check-backend-function + (and (string-match "^gnus-" (symbol-name request-func)) + (intern (substring (symbol-name request-func) + (match-end 0)))) + gnus-newsgroup-name) + (setq ofunc request-func) + (setq request-func 'gnus-request-article)) + (while articles + (setq article (mail-header-number (caar articles))) + (gnus-message 7 "Scoring on article %s of %s..." article last) + (when (funcall request-func article gnus-newsgroup-name) + (widen) + (goto-char (point-min)) + ;; If just parts of the article is to be searched, but the + ;; backend didn't support partial fetching, we just narrow + ;; to the relevant parts. + (when ofunc + (if (eq ofunc 'gnus-request-head) + (narrow-to-region + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) + (setq scores all-scores) + ;; Find matches. + (while scores + (setq alist (pop scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) + gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (case-fold-search + (not (or (eq type 'R) (eq type 'S) + (eq type 'Regexp) (eq type 'String)))) + (search-func + (cond ((or (eq type 'r) (eq type 'R) + (eq type 'regexp) (eq type 'Regexp)) + 're-search-forward) + ((or (eq type 's) (eq type 'S) + (eq type 'string) (eq type 'String)) + 'search-forward) + (t + (error "Illegal match type: %s" type))))) + (goto-char (point-min)) + (when (funcall search-func match nil t) + ;; Found a match, update scores. + (setcdr (car articles) (+ score (cdar articles))) + (setq found t) + (when trace + (push + (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace))) + ;; Update expire date + (unless trace + (cond + ((null date)) ;Permanent entry. + ((and found gnus-update-score-entry-dates) + ;; Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((and expire (< date expire)) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries)))) + (setq entries rest))))) + (setq articles (cdr articles))))))) + nil) + +(defun gnus-score-thread (scores header now expire &optional trace) + (gnus-score-followup scores header now expire trace t)) + +(defun gnus-score-followup (scores header now expire &optional trace thread) + ;; Insert the unique article headers in the buffer. + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + (current-score-file gnus-current-score-file) + (all-scores scores) + ;; gnus-score-index is used as a free variable. + alike last this art entries alist articles + new news) + + ;; Change score file to the adaptive score file. All entries that + ;; this function makes will be put into this file. + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file + (or gnus-newsgroup-adaptive-score-file + (gnus-score-file-name + gnus-newsgroup-name gnus-adaptive-file-suffix)))) + + (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + articles gnus-scores-articles) + + (erase-buffer) + (while articles + (setq art (car articles) + this (aref (car art) gnus-score-index) + articles (cdr articles)) + (if (equal last this) + (push art alike) + (when last + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + (setq alike (list art) + last this))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + + ;; Find matches. + (while scores + (setq alist (car scores) + scores (cdr scores) + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((rest (cdr entries)) + (kill (car rest)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (mt (aref (symbol-name type) 0)) + (case-fold-search + (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F)))) + (dmt (downcase mt)) + (search-func + (cond ((= dmt ?r) 're-search-forward) + ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) + (t (error "Illegal match type: %s" type)))) + arts art) + (goto-char (point-min)) + (if (= dmt ?e) + (while (funcall search-func match nil t) + (and (= (progn (beginning-of-line) (point)) + (match-beginning 0)) + (= (progn (end-of-line) (point)) + (match-end 0)) + (progn + (setq found (setq arts (get-text-property + (point) 'articles))) + ;; Found a match, update scores. + (while arts + (setq art (car arts) + arts (cdr arts)) + (gnus-score-add-followups + (car art) score all-scores thread)))) + (end-of-line)) + (while (funcall search-func match nil t) + (end-of-line) + (setq found (setq arts (get-text-property (point) 'articles))) + ;; Found a match, update scores. + (while (setq art (pop arts)) + (when (setq new (gnus-score-add-followups + (car art) score all-scores thread)) + (push new news))))) + ;; Update expire date + (cond ((null date)) ;Permanent entry. + ((and found gnus-update-score-entry-dates) ;Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((and expire (< date expire)) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries))) + (setq entries rest)))) + ;; We change the score file back to the previous one. + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file current-score-file)) + (list (cons "references" news)))) + +(defun gnus-score-add-followups (header score scores &optional thread) + "Add a score entry to the adapt file." + (save-excursion + (set-buffer gnus-summary-buffer) + (let* ((id (mail-header-id header)) + (scores (car scores)) + entry dont) + ;; Don't enter a score if there already is one. + (while (setq entry (pop scores)) + (and (equal "references" (car entry)) + (or (null (nth 3 (cadr entry))) + (eq 's (nth 3 (cadr entry)))) + (assoc id entry) + (setq dont t))) + (unless dont + (gnus-summary-score-entry + (if thread "thread" "references") + id 's score (current-time-string) nil t))))) + +(defun gnus-score-string (score-list header now expire &optional trace) + ;; Score ARTICLES according to HEADER in SCORE-LIST. + ;; Update matching entries to NOW and remove unmatched entries older + ;; than EXPIRE. + + ;; Insert the unique article headers in the buffer. + (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) + ;; gnus-score-index is used as a free variable. + alike last this art entries alist articles + fuzzies arts words kill) + + ;; Sorting the articles costs os O(N*log N) but will allow us to + ;; only match with each unique header. Thus the actual matching + ;; will be O(M*U) where M is the number of strings to match with, + ;; and U is the number of unique headers. It is assumed (but + ;; untested) this will be a net win because of the large constant + ;; factor involved with string matching. + (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<) + articles gnus-scores-articles) + + (erase-buffer) + (while (setq art (pop articles)) + (setq this (aref (car art) gnus-score-index)) + (if (equal last this) + ;; O(N*H) cons-cells used here, where H is the number of + ;; headers. + (push art alike) + (when last + ;; Insert the line, with a text property on the + ;; terminating newline referring to the articles with + ;; this line. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + (setq alike (list art) + last this))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + + ;; Go through all the score alists and pick out the entries + ;; for this header. + (while score-list + (setq alist (pop score-list) + ;; There's only one instance of this header for + ;; each score alist. + entries (assoc header alist)) + (while (cdr entries) ;First entry is the header index. + (let* ((kill (cadr entries)) + (match (nth 0 kill)) + (type (or (nth 3 kill) 's)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (found nil) + (mt (aref (symbol-name type) 0)) + (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) + (dmt (downcase mt)) + (search-func + (cond ((= dmt ?r) 're-search-forward) + ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) + ((= dmt ?w) nil) + (t (error "Illegal match type: %s" type))))) + (cond + ;; Fuzzy matches. We save these for later. + ((= dmt ?f) + (push (cons entries alist) fuzzies)) + ;; Word matches. Save these for even later. + ((= dmt ?w) + (push (cons entries alist) words)) + ;; Exact matches. + ((= dmt ?e) + ;; Do exact matching. + (goto-char (point-min)) + (while (and (not (eobp)) + (funcall search-func match nil t)) + ;; Is it really exact? + (and (eolp) + (= (gnus-point-at-bol) (match-beginning 0)) + ;; Yup. + (progn + (setq found (setq arts (get-text-property + (point) 'articles))) + ;; Found a match, update scores. + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push + (cons + (car-safe (rassq alist gnus-score-cache)) + kill) + gnus-score-trace)) + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))))))) + (forward-line 1))) + ;; Regexp and substring matching. + (t + (goto-char (point-min)) + (when (string= match "") + (setq match "\n")) + (while (and (not (eobp)) + (funcall search-func match nil t)) + (goto-char (match-beginning 0)) + (end-of-line) + (setq found (setq arts (get-text-property (point) 'articles))) + ;; Found a match, update scores. + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace)) + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))))) + (forward-line 1)))) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) + (cond + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))))) + + ;; Find fuzzy matches. + (when fuzzies + ;; Simplify the entire buffer for easy matching. + (gnus-simplify-buffer-fuzzy) + (while (setq kill (cadaar fuzzies)) + (let* ((match (nth 0 kill)) + (type (nth 3 kill)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (mt (aref (symbol-name type) 0)) + (case-fold-search (not (= mt ?F))) + found) + (goto-char (point-min)) + (while (and (not (eobp)) + (search-forward match nil t)) + (when (and (= (gnus-point-at-bol) (match-beginning 0)) + (eolp)) + (setq found (setq arts (get-text-property (point) 'articles))) + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push (cons + (car-safe (rassq (cdar fuzzies) gnus-score-cache)) + kill) + gnus-score-trace)) + ;; Found a match, update scores. + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art)))))) + (forward-line 1)) + ;; Update expiry date + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcdr (caar fuzzies) (cddaar fuzzies)))) + (setq fuzzies (cdr fuzzies))))) + + (when words + ;; Enter all words into the hashtb. + (let ((hashtb (gnus-make-hashtable + (* 10 (count-lines (point-min) (point-max)))))) + (gnus-enter-score-words-into-hashtb hashtb) + (while (setq kill (cadaar words)) + (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + found) + (when (setq arts (intern-soft (nth 0 kill) hashtb)) + (setq arts (symbol-value arts)) + (setq found t) + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push (cons + (car-safe (rassq (cdar words) gnus-score-cache)) + kill) + gnus-score-trace)) + ;; Found a match, update scores. + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art)))))) + ;; Update expiry date + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar words)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar words)) + (setcdr (caar words) (cddaar words)))) + (setq words (cdr words)))))) + nil)) + +(defun gnus-enter-score-words-into-hashtb (hashtb) + ;; Find all the words in the buffer and enter them into + ;; the hashtable. + (let ((syntab (syntax-table)) + word val) + (goto-char (point-min)) + (unwind-protect + (progn + (set-syntax-table gnus-adaptive-word-syntax-table) + (while (re-search-forward "\\b\\w+\\b" nil t) + (setq val + (gnus-gethash + (setq word (downcase (buffer-substring + (match-beginning 0) (match-end 0)))) + hashtb)) + (gnus-sethash + word + (append (get-text-property (gnus-point-at-eol) 'articles) val) + hashtb))) + (set-syntax-table syntab)) + ;; Make all the ignorable words ignored. + (let ((ignored (append gnus-ignored-adaptive-words + gnus-default-ignored-adaptive-words))) + (while ignored + (gnus-sethash (pop ignored) nil hashtb))))) + +(defun gnus-score-string< (a1 a2) + ;; Compare headers in articles A2 and A2. + ;; The header index used is the free variable `gnus-score-index'. + (string-lessp (aref (car a1) gnus-score-index) + (aref (car a2) gnus-score-index))) + +(defun gnus-current-score-file-nondirectory (&optional score-file) + (let ((score-file (or score-file gnus-current-score-file))) + (if score-file + (gnus-short-group-name (file-name-nondirectory score-file)) + "none"))) + +(defun gnus-score-adaptive () + "Create adaptive score rules for this newsgroup." + (when gnus-newsgroup-adaptive + ;; We change the score file to the adaptive score file. + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file + (or gnus-newsgroup-adaptive-score-file + (gnus-score-file-name + gnus-newsgroup-name gnus-adaptive-file-suffix)))) + ;; Perform ordinary line scoring. + (when (or (not (listp gnus-newsgroup-adaptive)) + (memq 'line gnus-newsgroup-adaptive)) + (save-excursion + (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) + (alist malist) + (date (current-time-string)) + (data gnus-newsgroup-data) + elem headers match) + ;; First we transform the adaptive rule alist into something + ;; that's faster to process. + (while malist + (setq elem (car malist)) + (when (symbolp (car elem)) + (setcar elem (symbol-value (car elem)))) + (setq elem (cdr elem)) + (while elem + (setcdr (car elem) + (cons (if (eq (caar elem) 'followup) + "references" + (symbol-name (caar elem))) + (cdar elem))) + (setcar (car elem) + `(lambda (h) + (,(intern + (concat "mail-header-" + (if (eq (caar elem) 'followup) + "message-id" + (downcase (symbol-name (caar elem)))))) + h))) + (setq elem (cdr elem))) + (setq malist (cdr malist))) + ;; Then we score away. + (while data + (setq elem (cdr (assq (gnus-data-mark (car data)) alist))) + (if (or (not elem) + (gnus-data-pseudo-p (car data))) + () + (when (setq headers (gnus-data-header (car data))) + (while elem + (setq match (funcall (caar elem) headers)) + (gnus-summary-score-entry + (nth 1 (car elem)) match + (cond + ((numberp match) + '=) + ((equal (nth 1 (car elem)) "date") + 'a) + (t + ;; Whether we use substring or exact matches is + ;; controlled here. + (if (or (not gnus-score-exact-adapt-limit) + (< (length match) gnus-score-exact-adapt-limit)) + 'e + (if (equal (nth 1 (car elem)) "subject") + 'f 's)))) + (nth 2 (car elem)) date nil t) + (setq elem (cdr elem))))) + (setq data (cdr data)))))) + + ;; Perform adaptive word scoring. + (when (and (listp gnus-newsgroup-adaptive) + (memq 'word gnus-newsgroup-adaptive)) + (nnheader-temp-write nil + (let* ((hashtb (gnus-make-hashtable 1000)) + (date (gnus-day-number (current-time-string))) + (data gnus-newsgroup-data) + (syntab (syntax-table)) + word d score val) + (unwind-protect + (progn + (set-syntax-table gnus-adaptive-word-syntax-table) + ;; Go through all articles. + (while (setq d (pop data)) + (when (and + (not (gnus-data-pseudo-p d)) + (setq score + (cdr (assq + (gnus-data-mark d) + gnus-adaptive-word-score-alist)))) + ;; This article has a mark that should lead to + ;; adaptive word rules, so we insert the subject + ;; and find all words in that string. + (insert (mail-header-subject (gnus-data-header d))) + (downcase-region (point-min) (point-max)) + (goto-char (point-min)) + (while (re-search-forward "\\b\\w+\\b" nil t) + ;; Put the word and score into the hashtb. + (setq val (gnus-gethash (setq word (match-string 0)) + hashtb)) + (gnus-sethash word (+ (or val 0) score) hashtb)) + (erase-buffer)))) + (set-syntax-table syntab)) + ;; Make all the ignorable words ignored. + (let ((ignored (append gnus-ignored-adaptive-words + gnus-default-ignored-adaptive-words))) + (while ignored + (gnus-sethash (pop ignored) nil hashtb))) + ;; Now we have all the words and scores, so we + ;; add these rules to the ADAPT file. + (set-buffer gnus-summary-buffer) + (mapatoms + (lambda (word) + (when (symbol-value word) + (gnus-summary-score-entry + "subject" (symbol-name word) 'w (symbol-value word) + date nil t))) + hashtb)))))) + +(defun gnus-score-edit-done () + (let ((bufnam (buffer-file-name (current-buffer))) + (winconf gnus-prev-winconf)) + (when winconf + (set-window-configuration winconf)) + (gnus-score-remove-from-cache bufnam) + (gnus-score-load-file bufnam))) + +(defun gnus-score-find-trace () + "Find all score rules that applies to the current article." + (interactive) + (let ((old-scored gnus-newsgroup-scored)) + (let ((gnus-newsgroup-headers + (list (gnus-summary-article-header))) + (gnus-newsgroup-scored nil) + trace) + (save-excursion + (nnheader-set-temp-buffer "*Score Trace*")) + (setq gnus-score-trace nil) + (gnus-possibly-score-headers 'trace) + (if (not (setq trace gnus-score-trace)) + (gnus-error + 1 "No score rules apply to the current article (default score %d)." + gnus-summary-default-score) + (set-buffer "*Score Trace*") + (gnus-add-current-to-buffer-list) + (while trace + (insert (format "%S -> %s\n" (cdar trace) + (if (caar trace) + (file-name-nondirectory (caar trace)) + "(non-file rule)"))) + (setq trace (cdr trace))) + (goto-char (point-min)) + (gnus-configure-windows 'score-trace))) + (set-buffer gnus-summary-buffer) + (setq gnus-newsgroup-scored old-scored))) + +(defun gnus-score-find-favourite-words () + "List words used in scoring." + (interactive) + (let ((alists (gnus-score-load-files (gnus-all-score-files))) + alist rule rules kill) + ;; Go through all the score alists for this group + ;; and find all `w' rules. + (while (setq alist (pop alists)) + (while (setq rule (pop alist)) + (when (and (stringp (car rule)) + (equal "subject" (downcase (pop rule)))) + (while (setq kill (pop rule)) + (when (memq (nth 3 kill) '(w W word Word)) + (push (cons (or (nth 1 kill) + gnus-score-interactive-default-score) + (car kill)) + rules)))))) + (setq rules (sort rules (lambda (r1 r2) + (string-lessp (cdr r1) (cdr r2))))) + ;; Add up words that have appeared several times. + (let ((r rules)) + (while (cdr r) + (if (equal (cdar r) (cdadr r)) + (progn + (setcar (car r) (+ (caar r) (caadr r))) + (setcdr r (cddr r))) + (pop r)))) + ;; Insert the words. + (nnheader-set-temp-buffer "*Score Words*") + (if (not (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2)))))) + (gnus-error 3 "No word score rules") + (while rules + (insert (format "%-5d: %s\n" (caar rules) (cdar rules))) + (pop rules)) + (gnus-add-current-to-buffer-list) + (goto-char (point-min)) + (gnus-configure-windows 'score-words)))) + +(defun gnus-summary-rescore () + "Redo the entire scoring process in the current summary." + (interactive) + (gnus-score-save) + (setq gnus-score-cache nil) + (setq gnus-newsgroup-scored nil) + (gnus-possibly-score-headers) + (gnus-score-update-all-lines)) + +(defun gnus-score-flush-cache () + "Flush the cache of score files." + (interactive) + (gnus-score-save) + (setq gnus-score-cache nil + gnus-score-alist nil + gnus-short-name-score-file-cache nil) + (gnus-message 6 "The score cache is now flushed")) + +(gnus-add-shutdown 'gnus-score-close 'gnus) + +(defvar gnus-score-file-alist-cache nil) + +(defun gnus-score-close () + "Clear all internal score variables." + (setq gnus-score-cache nil + gnus-internal-global-score-files nil + gnus-score-file-list nil + gnus-score-file-alist-cache nil)) + +;; Summary score marking commands. + +(defun gnus-summary-raise-same-subject-and-select (score) + "Raise articles which has the same subject with SCORE and select the next." + (interactive "p") + (let ((subject (gnus-summary-article-subject))) + (gnus-summary-raise-score score) + (while (gnus-summary-find-subject subject) + (gnus-summary-raise-score score)) + (gnus-summary-next-article t))) + +(defun gnus-summary-raise-same-subject (score) + "Raise articles which has the same subject with SCORE." + (interactive "p") + (let ((subject (gnus-summary-article-subject))) + (gnus-summary-raise-score score) + (while (gnus-summary-find-subject subject) + (gnus-summary-raise-score score)) + (gnus-summary-next-subject 1 t))) + +(defun gnus-score-default (level) + (if level (prefix-numeric-value level) + gnus-score-interactive-default-score)) + +(defun gnus-summary-raise-thread (&optional score) + "Raise the score of the articles in the current thread with SCORE." + (interactive "P") + (setq score (gnus-score-default score)) + (let (e) + (save-excursion + (let ((articles (gnus-summary-articles-in-thread))) + (while articles + (gnus-summary-goto-subject (car articles)) + (gnus-summary-raise-score score) + (setq articles (cdr articles)))) + (setq e (point))) + (let ((gnus-summary-check-current t)) + (unless (zerop (gnus-summary-next-subject 1 t)) + (goto-char e)))) + (gnus-summary-recenter) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary)) + +(defun gnus-summary-lower-same-subject-and-select (score) + "Raise articles which has the same subject with SCORE and select the next." + (interactive "p") + (gnus-summary-raise-same-subject-and-select (- score))) + +(defun gnus-summary-lower-same-subject (score) + "Raise articles which has the same subject with SCORE." + (interactive "p") + (gnus-summary-raise-same-subject (- score))) + +(defun gnus-summary-lower-thread (&optional score) + "Lower score of articles in the current thread with SCORE." + (interactive "P") + (gnus-summary-raise-thread (- (1- (gnus-score-default score))))) + +;;; Finding score files. + +(defun gnus-score-score-files (group) + "Return a list of all possible score files." + ;; Search and set any global score files. + (when gnus-global-score-files + (unless gnus-internal-global-score-files + (gnus-score-search-global-directories gnus-global-score-files))) + ;; Fix the kill-file dir variable. + (setq gnus-kill-files-directory + (file-name-as-directory gnus-kill-files-directory)) + ;; If we can't read it, there are no score files. + (if (not (file-exists-p (expand-file-name gnus-kill-files-directory))) + (setq gnus-score-file-list nil) + (if (not (gnus-use-long-file-name 'not-score)) + ;; We do not use long file names, so we have to do some + ;; directory traversing. + (setq gnus-score-file-list + (cons nil + (or gnus-short-name-score-file-cache + (prog2 + (gnus-message 6 "Finding all score files...") + (setq gnus-short-name-score-file-cache + (gnus-score-score-files-1 + gnus-kill-files-directory)) + (gnus-message 6 "Finding all score files...done"))))) + ;; We want long file names. + (when (or (not gnus-score-file-list) + (not (car gnus-score-file-list)) + (gnus-file-newer-than gnus-kill-files-directory + (car gnus-score-file-list))) + (setq gnus-score-file-list + (cons (nth 5 (file-attributes gnus-kill-files-directory)) + (nreverse + (directory-files + gnus-kill-files-directory t + (gnus-score-file-regexp))))))) + (cdr gnus-score-file-list))) + +(defun gnus-score-score-files-1 (dir) + "Return all possible score files under DIR." + (let ((files (list (expand-file-name dir))) + (regexp (gnus-score-file-regexp)) + (case-fold-search nil) + seen out file) + (while (setq file (pop files)) + (cond + ;; Ignore "." and "..". + ((member (file-name-nondirectory file) '("." "..")) + nil) + ;; Add subtrees of directory to also be searched. + ((and (file-directory-p file) + (not (member (file-truename file) seen))) + (push (file-truename file) seen) + (setq files (nconc (directory-files file t nil t) files))) + ;; Add files to the list of score files. + ((string-match regexp file) + (push file out)))) + (or out + ;; Return a dummy value. + (list "~/News/this.file.does.not.exist.SCORE")))) + +(defun gnus-score-file-regexp () + "Return a regexp that match all score files." + (concat "\\(" (regexp-quote gnus-score-file-suffix ) + "\\|" (regexp-quote gnus-adaptive-file-suffix) "\\)\\'")) + +(defun gnus-score-find-bnews (group) + "Return a list of score files for GROUP. +The score files are those files in the ~/News/ directory which matches +GROUP using BNews sys file syntax." + (let* ((sfiles (append (gnus-score-score-files group) + gnus-internal-global-score-files)) + (kill-dir (file-name-as-directory + (expand-file-name gnus-kill-files-directory))) + (klen (length kill-dir)) + (score-regexp (gnus-score-file-regexp)) + (trans (cdr (assq ?: nnheader-file-name-translation-alist))) + ofiles not-match regexp) + (save-excursion + (set-buffer (get-buffer-create "*gnus score files*")) + (buffer-disable-undo (current-buffer)) + ;; Go through all score file names and create regexp with them + ;; as the source. + (while sfiles + (erase-buffer) + (insert (car sfiles)) + (goto-char (point-min)) + ;; First remove the suffix itself. + (when (re-search-forward (concat "." score-regexp) nil t) + (replace-match "" t t) + (goto-char (point-min)) + (if (looking-at (regexp-quote kill-dir)) + ;; If the file name was just "SCORE", `klen' is one character + ;; too much. + (delete-char (min (1- (point-max)) klen)) + (goto-char (point-max)) + (search-backward "/") + (delete-region (1+ (point)) (point-min))) + ;; If short file names were used, we have to translate slashes. + (goto-char (point-min)) + (let ((regexp (concat + "[/:" (if trans (char-to-string trans) "") "]"))) + (while (re-search-forward regexp nil t) + (replace-match "." t t))) + ;; Kludge to get rid of "nntp+" problems. + (goto-char (point-min)) + (when (looking-at "nn[a-z]+\\+") + (search-forward "+") + (forward-char -1) + (insert "\\") + (forward-char 1)) + ;; Kludge to deal with "++". + (while (search-forward "+" nil t) + (replace-match "\\+" t t)) + ;; Translate "all" to ".*". + (goto-char (point-min)) + (while (search-forward "all" nil t) + (replace-match ".*" t t)) + (goto-char (point-min)) + ;; Deal with "not."s. + (if (looking-at "not.") + (progn + (setq not-match t) + (setq regexp (concat "^" (buffer-substring 5 (point-max)) "$"))) + (setq regexp (concat "^" (buffer-substring 1 (point-max)) "$")) + (setq not-match nil)) + ;; Finally - if this resulting regexp matches the group name, + ;; we add this score file to the list of score files + ;; applicable to this group. + (when (or (and not-match + (not (string-match regexp group))) + (and (not not-match) + (string-match regexp group))) + (push (car sfiles) ofiles))) + (setq sfiles (cdr sfiles))) + (kill-buffer (current-buffer)) + ;; Slight kludge here - the last score file returned should be + ;; the local score file, whether it exists or not. This is so + ;; that any score commands the user enters will go to the right + ;; file, and not end up in some global score file. + (let ((localscore (gnus-score-file-name group))) + (setq ofiles (cons localscore (delete localscore ofiles)))) + (gnus-sort-score-files (nreverse ofiles))))) + +(defun gnus-score-find-single (group) + "Return list containing the score file for GROUP." + (list (or gnus-newsgroup-adaptive-score-file + (gnus-score-file-name group gnus-adaptive-file-suffix)) + (gnus-score-file-name group))) + +(defun gnus-score-find-hierarchical (group) + "Return list of score files for GROUP. +This includes the score file for the group and all its parents." + (let* ((prefix (gnus-group-real-prefix group)) + (all (list nil)) + (group (gnus-group-real-name group)) + (start 0)) + (while (string-match "\\." group (1+ start)) + (setq start (match-beginning 0)) + (push (substring group 0 start) all)) + (push group all) + (setq all + (nconc + (mapcar (lambda (group) + (gnus-score-file-name group gnus-adaptive-file-suffix)) + (setq all (nreverse all))) + (mapcar 'gnus-score-file-name all))) + (if (equal prefix "") + all + (mapcar + (lambda (file) + (nnheader-translate-file-chars + (concat (file-name-directory file) prefix + (file-name-nondirectory file)))) + all)))) + +(defun gnus-score-file-rank (file) + "Return a number that says how specific score FILE is. +Destroys the current buffer." + (if (member file gnus-internal-global-score-files) + 0 + (when (string-match + (concat "^" (regexp-quote + (expand-file-name + (file-name-as-directory gnus-kill-files-directory)))) + file) + (setq file (substring file (match-end 0)))) + (insert file) + (goto-char (point-min)) + (let ((beg (point)) + elems) + (while (re-search-forward "[./]" nil t) + (push (buffer-substring beg (1- (point))) + elems)) + (erase-buffer) + (setq elems (delete "all" elems)) + (length elems)))) + +(defun gnus-sort-score-files (files) + "Sort FILES so that the most general files come first." + (nnheader-temp-write nil + (let ((alist + (mapcar + (lambda (file) + (cons (inline (gnus-score-file-rank file)) file)) + files))) + (mapcar + (lambda (f) (cdr f)) + (sort alist 'car-less-than-car))))) + +(defun gnus-score-find-alist (group) + "Return list of score files for GROUP. +The list is determined from the variable gnus-score-file-alist." + (let ((alist gnus-score-file-multiple-match-alist) + score-files) + ;; if this group has been seen before, return the cached entry + (if (setq score-files (assoc group gnus-score-file-alist-cache)) + (cdr score-files) ;ensures caching groups with no matches + ;; handle the multiple match alist + (while alist + (when (string-match (caar alist) group) + (setq score-files + (nconc score-files (copy-sequence (cdar alist))))) + (setq alist (cdr alist))) + (setq alist gnus-score-file-single-match-alist) + ;; handle the single match alist + (while alist + (when (string-match (caar alist) group) + ;; progn used just in case ("regexp") has no files + ;; and score-files is still nil. -sj + ;; this can be construed as a "stop searching here" feature :> + ;; and used to simplify regexps in the single-alist + (setq score-files + (nconc score-files (copy-sequence (cdar alist)))) + (setq alist nil)) + (setq alist (cdr alist))) + ;; cache the score files + (push (cons group score-files) gnus-score-file-alist-cache) + score-files))) + +(defun gnus-all-score-files (&optional group) + "Return a list of all score files for the current group." + (let ((funcs gnus-score-find-score-files-function) + (group (or group gnus-newsgroup-name)) + score-files) + ;; Make sure funcs is a list. + (and funcs + (not (listp funcs)) + (setq funcs (list funcs))) + ;; Get the initial score files for this group. + (when funcs + (setq score-files (nreverse (gnus-score-find-alist group)))) + ;; Add any home adapt files. + (let ((home (gnus-home-score-file group t))) + (when home + (push home score-files) + (setq gnus-newsgroup-adaptive-score-file home))) + ;; Check whether there is a `adapt-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'adapt-file))) + (when param-file + (push param-file score-files) + (setq gnus-newsgroup-adaptive-score-file param-file))) + ;; Go through all the functions for finding score files (or actual + ;; scores) and add them to a list. + (while funcs + (when (gnus-functionp (car funcs)) + (setq score-files + (nconc score-files (nreverse (funcall (car funcs) group))))) + (setq funcs (cdr funcs))) + ;; Add any home score files. + (let ((home (gnus-home-score-file group))) + (when home + (push home score-files))) + ;; Check whether there is a `score-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'score-file))) + (when param-file + (push param-file score-files))) + ;; Expand all files names. + (let ((files score-files)) + (while files + (when (stringp (car files)) + (setcar files (expand-file-name + (car files) gnus-kill-files-directory))) + (pop files))) + (setq score-files (nreverse score-files)) + ;; Remove any duplicate score files. + (while (and score-files + (member (car score-files) (cdr score-files))) + (pop score-files)) + (let ((files score-files)) + (while (cdr files) + (if (member (cadr files) (cddr files)) + (setcdr files (cddr files)) + (pop files)))) + ;; Do the scoring if there are any score files for this group. + score-files)) + +(defun gnus-possibly-score-headers (&optional trace) + "Do scoring if scoring is required." + (let ((score-files (gnus-all-score-files))) + (when score-files + (gnus-score-headers score-files trace)))) + +(defun gnus-score-file-name (newsgroup &optional suffix) + "Return the name of a score file for NEWSGROUP." + (let ((suffix (or suffix gnus-score-file-suffix))) + (nnheader-translate-file-chars + (cond + ((or (null newsgroup) + (string-equal newsgroup "")) + ;; The global score file is placed at top of the directory. + (expand-file-name + suffix gnus-kill-files-directory)) + ((gnus-use-long-file-name 'not-score) + ;; Append ".SCORE" to newsgroup name. + (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup) + "." suffix) + gnus-kill-files-directory)) + (t + ;; Place "SCORE" under the hierarchical directory. + (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) + "/" suffix) + gnus-kill-files-directory)))))) + +(defun gnus-score-search-global-directories (files) + "Scan all global score directories for score files." + ;; Set the variable `gnus-internal-global-score-files' to all + ;; available global score files. + (interactive (list gnus-global-score-files)) + (let (out) + (while files + (if (string-match "/$" (car files)) + (setq out (nconc (directory-files + (car files) t + (concat (gnus-score-file-regexp) "$")))) + (push (car files) out)) + (setq files (cdr files))) + (setq gnus-internal-global-score-files out))) + +(defun gnus-score-default-fold-toggle () + "Toggle folding for new score file entries." + (interactive) + (setq gnus-score-default-fold (not gnus-score-default-fold)) + (if gnus-score-default-fold + (gnus-message 1 "New score file entries will be case insensitive.") + (gnus-message 1 "New score file entries will be case sensitive."))) + +;;; Home score file. + +(defun gnus-home-score-file (group &optional adapt) + "Return the home score file for GROUP. +If ADAPT, return the home adaptive file instead." + (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file)) + elem found) + ;; Make sure we have a list. + (unless (listp list) + (setq list (list list))) + ;; Go through the list and look for matches. + (while (and (not found) + (setq elem (pop list))) + (setq found + (cond + ;; Simple string. + ((stringp elem) + elem) + ;; Function. + ((gnus-functionp elem) + (funcall elem group)) + ;; Regexp-file cons + ((consp elem) + (when (string-match (car elem) group) + (cadr elem)))))) + (when found + (nnheader-concat gnus-kill-files-directory found)))) + +(defun gnus-hierarchial-home-score-file (group) + "Return the score file of the top-level hierarchy of GROUP." + (if (string-match "^[^.]+\\." group) + (concat (match-string 0 group) gnus-score-file-suffix) + ;; Group name without any dots. + (concat group (if (gnus-use-long-file-name 'not-score) "." "/") + gnus-score-file-suffix))) + +(defun gnus-hierarchial-home-adapt-file (group) + "Return the adapt file of the top-level hierarchy of GROUP." + (if (string-match "^[^.]+\\." group) + (concat (match-string 0 group) gnus-adaptive-file-suffix) + ;; Group name without any dots. + (concat group (if (gnus-use-long-file-name 'not-score) "." "/") + gnus-adaptive-file-suffix))) + +;;; +;;; Score decays +;;; + +(defun gnus-decay-score (score) + "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'." + (floor + (- score + (* (if (< score 0) -1 1) + (min (abs score) + (max gnus-score-decay-constant + (* (abs score) + gnus-score-decay-scale))))))) + +(defun gnus-decay-scores (alist day) + "Decay non-permanent scores in ALIST." + (let ((times (- (gnus-time-to-day (current-time)) day)) + kill entry updated score n) + (unless (zerop times) ;Done decays today already? + (while (setq entry (pop alist)) + (when (stringp (car entry)) + (setq entry (cdr entry)) + (while (setq kill (pop entry)) + (when (nth 2 kill) + (setq updated t) + (setq score (or (nth 1 kill) + gnus-score-interactive-default-score) + n times) + (while (natnump (decf n)) + (setq score (funcall gnus-decay-score-function score))) + (setcdr kill (cons score + (cdr (cdr kill))))))))) + ;; Return whether this score file needs to be saved. By Je-haysuss! + updated)) + +(defun gnus-score-regexp-bad-p (regexp) + "Test whether REGEXP is safe for Gnus scoring. +A regexp is unsafe if it matches newline or a buffer boundary. + +If the regexp is good, return nil. If the regexp is bad, return a +cons cell (SYM . STRING), where the symbol SYM is `new' or `bad'. +In the `new' case, the string is a safe replacement for REGEXP. +In the `bad' case, the string is a unsafe subexpression of REGEXP, +and we do not have a simple replacement to suggest. + +See `(Gnus)Scoring Tips' for examples of good regular expressions." + (let (case-fold-search) + (and + ;; First, try a relatively fast necessary condition. + ;; Notice ranges (like [^:] or [\t-\r]), \s>, \Sw, \W, \', \`: + (string-match "\n\\|\\\\[SsW`']\\|\\[\\^\\|[\0-\n]-" regexp) + ;; Now break the regexp into tokens, and check each: + (let ((tail regexp) ; remaining regexp to check + tok ; current token + bad ; nil, or bad subexpression + new ; nil, or replacement regexp so far + end) ; length of current token + (while (and (not bad) + (string-match + "\\`\\(\\\\[sS]?.\\|\\[\\^?]?[^]]*]\\|[^\\]\\)" + tail)) + (setq end (match-end 0) + tok (substring tail 0 end) + tail (substring tail end)) + (if;; Is token `bad' (matching newline or buffer ends)? + (or (member tok '("\n" "\\W" "\\`" "\\'")) + ;; This next handles "[...]", "\\s.", and "\\S.": + (and (> end 2) (string-match tok "\n"))) + (let ((newtok + ;; Try to suggest a replacement for tok ... + (cond ((string-equal tok "\\`") "^") ; or "\\(^\\)" + ((string-equal tok "\\'") "$") ; or "\\($\\)" + ((string-match "\\[\\^" tok) ; very common + (concat (substring tok 0 -1) "\n]"))))) + (if newtok + (setq new + (concat + (or new + ;; good prefix so far: + (substring regexp 0 (- (+ (length tail) end)))) + newtok)) + ;; No replacement idea, so give up: + (setq bad tok))) + ;; tok is good, may need to extend new + (and new (setq new (concat new tok))))) + ;; Now return a value: + (cond + (bad (cons 'bad bad)) + (new (cons 'new new)) + ;; or nil + ))))) + +(provide 'gnus-score) + +;;; gnus-score.el ends here diff --git a/lisp/gnus-setup.el b/lisp/gnus-setup.el new file mode 100644 index 0000000..ae9909b --- /dev/null +++ b/lisp/gnus-setup.el @@ -0,0 +1,217 @@ +;;; gnus-setup.el --- Initialization & Setup for Gnus 5 +;; Copyright (C) 1995, 96 Free Software Foundation, Inc. + +;; Author: Steven L. Baur +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; My head is starting to spin with all the different mail/news packages. +;; Stop The Madness! + +;; Given that Emacs Lisp byte codes may be diverging, it is probably best +;; not to byte compile this, and just arrange to have the .el loaded out +;; of .emacs. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)) + +(defvar gnus-use-installed-gnus t + "*If non-nil Use installed version of Gnus.") + +(defvar gnus-use-installed-tm running-xemacs + "*If non-nil use installed version of tm.") + +(defvar gnus-use-installed-mailcrypt running-xemacs + "*If non-nil use installed version of mailcrypt.") + +(defvar gnus-emacs-lisp-directory (if running-xemacs + "/usr/local/lib/xemacs/" + "/usr/local/share/emacs/") + "Directory where Emacs site lisp is located.") + +(defvar gnus-gnus-lisp-directory (concat gnus-emacs-lisp-directory + "gnus-5.0.15/lisp/") + "Directory where Gnus Emacs lisp is found.") + +(defvar gnus-tm-lisp-directory (concat gnus-emacs-lisp-directory + "site-lisp/") + "Directory where TM Emacs lisp is found.") + +(defvar gnus-mailcrypt-lisp-directory (concat gnus-emacs-lisp-directory + "site-lisp/mailcrypt-3.4/") + "Directory where Mailcrypt Emacs Lisp is found.") + +(defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory + "site-lisp/bbdb-1.51/") + "Directory where Big Brother Database is found.") + +(defvar gnus-use-tm running-xemacs + "Set this if you want MIME support for Gnus") +(defvar gnus-use-mhe nil + "Set this if you want to use MH-E for mail reading") +(defvar gnus-use-rmail nil + "Set this if you want to use RMAIL for mail reading") +(defvar gnus-use-sendmail t + "Set this if you want to use SENDMAIL for mail reading") +(defvar gnus-use-vm nil + "Set this if you want to use the VM package for mail reading") +(defvar gnus-use-sc nil + "Set this if you want to use Supercite") +(defvar gnus-use-mailcrypt t + "Set this if you want to use Mailcrypt for dealing with PGP messages") +(defvar gnus-use-bbdb nil + "Set this if you want to use the Big Brother DataBase") + +(when (and (not gnus-use-installed-gnus) + (null (member gnus-gnus-lisp-directory load-path))) + (push gnus-gnus-lisp-directory load-path)) + +;;; We can't do this until we know where Gnus is. +(require 'message) + +;;; Tools for MIME by +;;; UMEDA Masanobu +;;; MORIOKA Tomohiko + +(when gnus-use-tm + (when (and (not gnus-use-installed-tm) + (null (member gnus-tm-lisp-directory load-path))) + (setq load-path (cons gnus-tm-lisp-directory load-path))) + ;; tm may or may not be dumped with XEmacs. In Sunpro it is, otherwise + ;; it isn't. + (unless (featurep 'mime-setup) + (load "mime-setup"))) + +;;; Mailcrypt by +;;; Jin Choi +;;; Patrick LoPresti + +(when gnus-use-mailcrypt + (when (and (not gnus-use-installed-mailcrypt) + (null (member gnus-mailcrypt-lisp-directory load-path))) + (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) + (autoload 'mc-install-write-mode "mailcrypt" nil t) + (autoload 'mc-install-read-mode "mailcrypt" nil t) + (add-hook 'message-mode-hook 'mc-install-write-mode) + (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) + (when gnus-use-mhe + (add-hook 'mh-folder-mode-hook 'mc-install-read-mode) + (add-hook 'mh-letter-mode-hook 'mc-install-write-mode))) + +;;; BBDB by +;;; Jamie Zawinski + +(when gnus-use-bbdb + ;; bbdb will never be installed with emacs. + (when (null (member gnus-bbdb-lisp-directory load-path)) + (setq load-path (cons gnus-bbdb-lisp-directory load-path))) + (autoload 'bbdb "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-name "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-company "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-net "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-notes "bbdb-com" + "Insidious Big Brother Database" t) + + (when gnus-use-vm + (autoload 'bbdb-insinuate-vm "bbdb-vm" + "Hook BBDB into VM" t)) + + (when gnus-use-rmail + (autoload 'bbdb-insinuate-rmail "bbdb-rmail" + "Hook BBDB into RMAIL" t) + (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail)) + + (when gnus-use-mhe + (autoload 'bbdb-insinuate-mh "bbdb-mh" + "Hook BBDB into MH-E" t) + (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh)) + + (autoload 'bbdb-insinuate-gnus "bbdb-gnus" + "Hook BBDB into Gnus" t) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + + (when gnus-use-sendmail + (autoload 'bbdb-insinuate-sendmail "bbdb" + "Insidious Big Brother Database" t) + (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail) + (add-hook 'message-setup-hook 'bbdb-insinuate-sendmail))) + +(when gnus-use-sc + (add-hook 'mail-citation-hook 'sc-cite-original) + (setq message-cite-function 'sc-cite-original) + (autoload 'sc-cite-original "supercite")) + +;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137)) +;;; Generated autoloads from lisp/gnus.el + +;; Don't redo this if autoloads already exist +(unless (fboundp 'gnus) + (autoload 'gnus-slave-no-server "gnus" "\ +Read network news as a slave without connecting to local server." t nil) + + (autoload 'gnus-no-server "gnus" "\ +Read network news. +If ARG is a positive number, Gnus will use that as the +startup level. If ARG is nil, Gnus will be started at level 2. +If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local server." t nil) + + (autoload 'gnus-slave "gnus" "\ +Read news as a slave." t nil) + + (autoload 'gnus "gnus" "\ +Read network news. +If ARG is non-nil and a positive number, Gnus will use that as the +startup level. If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use." t nil) + +;;;*** + +;;; These have moved out of gnus.el into other files. +;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it? + (autoload 'gnus-update-format "gnus-spec" "\ +Update the format specification near point." t nil) + + (autoload 'gnus-fetch-group "gnus-group" "\ +Start Gnus if necessary and enter GROUP. +Returns whether the fetching was successful or not." t nil) + + (defalias 'gnus-batch-kill 'gnus-batch-score) + + (autoload 'gnus-batch-score "gnus-kill" "\ +Run batched scoring. +Usage: emacs -batch -l gnus -f gnus-batch-score ... +Newsgroups is a list of strings in Bnews format. If you want to score +the comp hierarchy, you'd say \"comp.all\". If you would not like to +score the alt hierarchy, you'd say \"!alt.all\"." t nil)) + +(provide 'gnus-setup) + +(run-hooks 'gnus-setup-load-hook) + +;;; gnus-setup.el ends here diff --git a/lisp/gnus-soup.el b/lisp/gnus-soup.el new file mode 100644 index 0000000..2143f9d --- /dev/null +++ b/lisp/gnus-soup.el @@ -0,0 +1,567 @@ +;;; gnus-soup.el --- SOUP packet writing support for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen +;; Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-art) +(require 'message) +(require 'gnus-start) +(require 'gnus-range) + +;;; User Variables: + +(defvar gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/") + "*Directory containing an unpacked SOUP packet.") + +(defvar gnus-soup-replies-directory + (nnheader-concat gnus-soup-directory "SoupReplies/") + "*Directory where Gnus will do processing of replies.") + +(defvar gnus-soup-prefix-file "gnus-prefix" + "*Name of the file where Gnus stores the last used prefix.") + +(defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz" + "Format string command for packing a SOUP packet. +The SOUP files will be inserted where the %s is in the string. +This string MUST contain both %s and %d. The file number will be +inserted where %d appears.") + +(defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -" + "*Format string command for unpacking a SOUP packet. +The SOUP packet file name will be inserted at the %s.") + +(defvar gnus-soup-packet-directory gnus-home-directory + "*Where gnus-soup will look for REPLIES packets.") + +(defvar gnus-soup-packet-regexp "Soupin" + "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.") + +(defvar gnus-soup-ignored-headers "^Xref:" + "*Regexp to match headers to be removed when brewing SOUP packets.") + +;;; Internal Variables: + +(defvar gnus-soup-encoding-type ?n + "*Soup encoding type. +`n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox +format.") + +(defvar gnus-soup-index-type ?c + "*Soup index type. +`n' means no index file and `c' means standard Cnews overview +format.") + +(defvar gnus-soup-areas nil) +(defvar gnus-soup-last-prefix nil) +(defvar gnus-soup-prev-prefix nil) +(defvar gnus-soup-buffers nil) + +;;; Access macros: + +(defmacro gnus-soup-area-prefix (area) + `(aref ,area 0)) +(defmacro gnus-soup-set-area-prefix (area prefix) + `(aset ,area 0 ,prefix)) +(defmacro gnus-soup-area-name (area) + `(aref ,area 1)) +(defmacro gnus-soup-area-encoding (area) + `(aref ,area 2)) +(defmacro gnus-soup-area-description (area) + `(aref ,area 3)) +(defmacro gnus-soup-area-number (area) + `(aref ,area 4)) +(defmacro gnus-soup-area-set-number (area value) + `(aset ,area 4 ,value)) + +(defmacro gnus-soup-encoding-format (encoding) + `(aref ,encoding 0)) +(defmacro gnus-soup-encoding-index (encoding) + `(aref ,encoding 1)) +(defmacro gnus-soup-encoding-kind (encoding) + `(aref ,encoding 2)) + +(defmacro gnus-soup-reply-prefix (reply) + `(aref ,reply 0)) +(defmacro gnus-soup-reply-kind (reply) + `(aref ,reply 1)) +(defmacro gnus-soup-reply-encoding (reply) + `(aref ,reply 2)) + +;;; Commands: + +(defun gnus-soup-send-replies () + "Unpack and send all replies in the reply packet." + (interactive) + (let ((packets (directory-files + gnus-soup-packet-directory t gnus-soup-packet-regexp))) + (while packets + (when (gnus-soup-send-packet (car packets)) + (delete-file (car packets))) + (setq packets (cdr packets))))) + +(defun gnus-soup-add-article (n) + "Add the current article to SOUP packet. +If N is a positive number, add the N next articles. +If N is a negative number, add the N previous articles. +If N is nil and any articles have been marked with the process mark, +move those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let* ((articles (gnus-summary-work-articles n)) + (tmp-buf (get-buffer-create "*soup work*")) + (area (gnus-soup-area gnus-newsgroup-name)) + (prefix (gnus-soup-area-prefix area)) + headers) + (buffer-disable-undo tmp-buf) + (save-excursion + (while articles + ;; Find the header of the article. + (set-buffer gnus-summary-buffer) + (when (setq headers (gnus-summary-article-header (car articles))) + ;; Put the article in a buffer. + (set-buffer tmp-buf) + (when (gnus-request-article-this-buffer + (car articles) gnus-newsgroup-name) + (save-restriction + (message-narrow-to-head) + (message-remove-header gnus-soup-ignored-headers t)) + (gnus-soup-store gnus-soup-directory prefix headers + gnus-soup-encoding-type + gnus-soup-index-type) + (gnus-soup-area-set-number + area (1+ (or (gnus-soup-area-number area) 0))))) + ;; Mark article as read. + (set-buffer gnus-summary-buffer) + (gnus-summary-remove-process-mark (car articles)) + (gnus-summary-mark-as-read (car articles) gnus-souped-mark) + (setq articles (cdr articles))) + (kill-buffer tmp-buf)) + (gnus-soup-save-areas))) + +(defun gnus-soup-pack-packet () + "Make a SOUP packet from the SOUP areas." + (interactive) + (gnus-soup-read-areas) + (unless (file-exists-p gnus-soup-directory) + (message "No such directory: %s" gnus-soup-directory)) + (when (null (directory-files gnus-soup-directory nil "\\.MSG$")) + (message "No files to pack.")) + (gnus-soup-pack gnus-soup-directory gnus-soup-packer)) + +(defun gnus-group-brew-soup (n) + "Make a soup packet from the current group. +Uses the process/prefix convention." + (interactive "P") + (let ((groups (gnus-group-process-prefix n))) + (while groups + (gnus-group-remove-mark (car groups)) + (gnus-soup-group-brew (car groups) t) + (setq groups (cdr groups))) + (gnus-soup-save-areas))) + +(defun gnus-brew-soup (&optional level) + "Go through all groups on LEVEL or less and make a soup packet." + (interactive "P") + (let ((level (or level gnus-level-subscribed)) + (newsrc (cdr gnus-newsrc-alist))) + (while newsrc + (when (<= (nth 1 (car newsrc)) level) + (gnus-soup-group-brew (caar newsrc) t)) + (setq newsrc (cdr newsrc))) + (gnus-soup-save-areas))) + +;;;###autoload +(defun gnus-batch-brew-soup () + "Brew a SOUP packet from groups mention on the command line. +Will use the remaining command line arguments as regular expressions +for matching on group names. + +For instance, if you want to brew on all the nnml groups, as well as +groups with \"emacs\" in the name, you could say something like: + +$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"" + (interactive) + nil) + +;;; Internal Functions: + +;; Store the current buffer. +(defun gnus-soup-store (directory prefix headers format index) + ;; Create the directory, if needed. + (gnus-make-directory directory) + (let* ((msg-buf (nnheader-find-file-noselect + (concat directory prefix ".MSG"))) + (idx-buf (if (= index ?n) + nil + (nnheader-find-file-noselect + (concat directory prefix ".IDX")))) + (article-buf (current-buffer)) + from head-line beg type) + (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers))) + (buffer-disable-undo msg-buf) + (when idx-buf + (push idx-buf gnus-soup-buffers) + (buffer-disable-undo idx-buf)) + (save-excursion + ;; Make sure the last char in the buffer is a newline. + (goto-char (point-max)) + (unless (= (current-column) 0) + (insert "\n")) + ;; Find the "from". + (goto-char (point-min)) + (setq from + (gnus-mail-strip-quoted-names + (or (mail-fetch-field "from") + (mail-fetch-field "really-from") + (mail-fetch-field "sender")))) + (goto-char (point-min)) + ;; Depending on what encoding is supposed to be used, we make + ;; a soup header. + (setq head-line + (cond + ((= gnus-soup-encoding-type ?n) + (format "#! rnews %d\n" (buffer-size))) + ((= gnus-soup-encoding-type ?m) + (while (search-forward "\nFrom " nil t) + (replace-match "\n>From " t t)) + (concat "From " (or from "unknown") + " " (current-time-string) "\n")) + ((= gnus-soup-encoding-type ?M) + "\^a\^a\^a\^a\n") + (t (error "Unsupported type: %c" gnus-soup-encoding-type)))) + ;; Insert the soup header and the article in the MSG buf. + (set-buffer msg-buf) + (goto-char (point-max)) + (insert head-line) + (setq beg (point)) + (insert-buffer-substring article-buf) + ;; Insert the index in the IDX buf. + (cond ((= index ?c) + (set-buffer idx-buf) + (gnus-soup-insert-idx beg headers)) + ((/= index ?n) + (error "Unknown index type: %c" type))) + ;; Return the MSG buf. + msg-buf))) + +(defun gnus-soup-group-brew (group &optional not-all) + "Enter GROUP and add all articles to a SOUP package. +If NOT-ALL, don't pack ticked articles." + (let ((gnus-expert-user t) + (gnus-large-newsgroup nil) + (entry (gnus-gethash group gnus-newsrc-hashtb))) + (when (or (null entry) + (eq (car entry) t) + (and (car entry) + (> (car entry) 0)) + (and (not not-all) + (gnus-range-length (cdr (assq 'tick (gnus-info-marks + (nth 2 entry))))))) + (when (gnus-summary-read-group group nil t) + (setq gnus-newsgroup-processable + (reverse + (if (not not-all) + (append gnus-newsgroup-marked gnus-newsgroup-unreads) + gnus-newsgroup-unreads))) + (gnus-soup-add-article nil) + (gnus-summary-exit))))) + +(defun gnus-soup-insert-idx (offset header) + ;; [number subject from date id references chars lines xref] + (goto-char (point-max)) + (insert + (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n" + offset + (or (mail-header-subject header) "(none)") + (or (mail-header-from header) "(nobody)") + (or (mail-header-date header) "") + (or (mail-header-id header) + (concat "soup-dummy-id-" + (mapconcat + (lambda (time) (int-to-string time)) + (current-time) "-"))) + (or (mail-header-references header) "") + (or (mail-header-chars header) 0) + (or (mail-header-lines header) "0")))) + +(defun gnus-soup-save-areas () + (gnus-soup-write-areas) + (save-excursion + (let (buf) + (while gnus-soup-buffers + (setq buf (car gnus-soup-buffers) + gnus-soup-buffers (cdr gnus-soup-buffers)) + (if (not (buffer-name buf)) + () + (set-buffer buf) + (when (buffer-modified-p) + (save-buffer)) + (kill-buffer (current-buffer))))) + (gnus-soup-write-prefixes))) + +(defun gnus-soup-write-prefixes () + (let ((prefixes gnus-soup-last-prefix) + prefix) + (save-excursion + (gnus-set-work-buffer) + (while (setq prefix (pop prefixes)) + (erase-buffer) + (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) + (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))) + +(defun gnus-soup-pack (dir packer) + (let* ((files (mapconcat 'identity + '("AREAS" "*.MSG" "*.IDX" "INFO" + "LIST" "REPLIES" "COMMANDS" "ERRORS") + " ")) + (packer (if (< (string-match "%s" packer) + (string-match "%d" packer)) + (format packer files + (string-to-int (gnus-soup-unique-prefix dir))) + (format packer + (string-to-int (gnus-soup-unique-prefix dir)) + files))) + (dir (expand-file-name dir))) + (gnus-make-directory dir) + (setq gnus-soup-areas nil) + (gnus-message 4 "Packing %s..." packer) + (if (zerop (call-process shell-file-name + nil nil nil shell-command-switch + (concat "cd " dir " ; " packer))) + (progn + (call-process shell-file-name nil nil nil shell-command-switch + (concat "cd " dir " ; rm " files)) + (gnus-message 4 "Packing...done" packer)) + (error "Couldn't pack packet")))) + +(defun gnus-soup-parse-areas (file) + "Parse soup area file FILE. +The result is a of vectors, each containing one entry from the AREA file. +The vector contain five strings, + [prefix name encoding description number] +though the two last may be nil if they are missing." + (let (areas) + (save-excursion + (set-buffer (nnheader-find-file-noselect file 'force)) + (buffer-disable-undo (current-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (push (vector (gnus-soup-field) + (gnus-soup-field) + (gnus-soup-field) + (and (eq (preceding-char) ?\t) + (gnus-soup-field)) + (and (eq (preceding-char) ?\t) + (string-to-int (gnus-soup-field)))) + areas) + (when (eq (preceding-char) ?\t) + (beginning-of-line 2))) + (kill-buffer (current-buffer))) + areas)) + +(defun gnus-soup-parse-replies (file) + "Parse soup REPLIES file FILE. +The result is a of vectors, each containing one entry from the REPLIES +file. The vector contain three strings, [prefix name encoding]." + (let (replies) + (save-excursion + (set-buffer (nnheader-find-file-noselect file)) + (buffer-disable-undo (current-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (push (vector (gnus-soup-field) (gnus-soup-field) + (gnus-soup-field)) + replies) + (when (eq (preceding-char) ?\t) + (beginning-of-line 2))) + (kill-buffer (current-buffer))) + replies)) + +(defun gnus-soup-field () + (prog1 + (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point))) + (forward-char 1))) + +(defun gnus-soup-read-areas () + (or gnus-soup-areas + (setq gnus-soup-areas + (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS"))))) + +(defun gnus-soup-write-areas () + "Write the AREAS file." + (interactive) + (when gnus-soup-areas + (nnheader-temp-write (concat gnus-soup-directory "AREAS") + (let ((areas gnus-soup-areas) + area) + (while (setq area (pop areas)) + (insert + (format + "%s\t%s\t%s%s\n" + (gnus-soup-area-prefix area) + (gnus-soup-area-name area) + (gnus-soup-area-encoding area) + (if (or (gnus-soup-area-description area) + (gnus-soup-area-number area)) + (concat "\t" (or (gnus-soup-area-description + area) "") + (if (gnus-soup-area-number area) + (concat "\t" (int-to-string + (gnus-soup-area-number area))) + "")) "")))))))) + +(defun gnus-soup-write-replies (dir areas) + "Write a REPLIES file in DIR containing AREAS." + (nnheader-temp-write (concat dir "REPLIES") + (let (area) + (while (setq area (pop areas)) + (insert (format "%s\t%s\t%s\n" + (gnus-soup-reply-prefix area) + (gnus-soup-reply-kind area) + (gnus-soup-reply-encoding area))))))) + +(defun gnus-soup-area (group) + (gnus-soup-read-areas) + (let ((areas gnus-soup-areas) + (real-group (gnus-group-real-name group)) + area result) + (while areas + (setq area (car areas) + areas (cdr areas)) + (when (equal (gnus-soup-area-name area) real-group) + (setq result area))) + (unless result + (setq result + (vector (gnus-soup-unique-prefix) + real-group + (format "%c%c%c" + gnus-soup-encoding-type + gnus-soup-index-type + (if (gnus-member-of-valid 'mail group) ?m ?n)) + nil nil) + gnus-soup-areas (cons result gnus-soup-areas))) + result)) + +(defun gnus-soup-unique-prefix (&optional dir) + (let* ((dir (file-name-as-directory (or dir gnus-soup-directory))) + (entry (assoc dir gnus-soup-last-prefix)) + gnus-soup-prev-prefix) + (if entry + () + (when (file-exists-p (concat dir gnus-soup-prefix-file)) + (ignore-errors + (load (concat dir gnus-soup-prefix-file) nil t t))) + (push (setq entry (cons dir (or gnus-soup-prev-prefix 0))) + gnus-soup-last-prefix)) + (setcdr entry (1+ (cdr entry))) + (gnus-soup-write-prefixes) + (int-to-string (cdr entry)))) + +(defun gnus-soup-unpack-packet (dir unpacker packet) + "Unpack PACKET into DIR using UNPACKER. +Return whether the unpacking was successful." + (gnus-make-directory dir) + (gnus-message 4 "Unpacking: %s" (format unpacker packet)) + (prog1 + (zerop (call-process + shell-file-name nil nil nil shell-command-switch + (format "cd %s ; %s" (expand-file-name dir) + (format unpacker packet)))) + (gnus-message 4 "Unpacking...done"))) + +(defun gnus-soup-send-packet (packet) + (gnus-soup-unpack-packet + gnus-soup-replies-directory gnus-soup-unpacker packet) + (let ((replies (gnus-soup-parse-replies + (concat gnus-soup-replies-directory "REPLIES")))) + (save-excursion + (while replies + (let* ((msg-file (concat gnus-soup-replies-directory + (gnus-soup-reply-prefix (car replies)) + ".MSG")) + (msg-buf (and (file-exists-p msg-file) + (nnheader-find-file-noselect msg-file))) + (tmp-buf (get-buffer-create " *soup send*")) + beg end) + (cond + ((/= (gnus-soup-encoding-format + (gnus-soup-reply-encoding (car replies))) + ?n) + (error "Unsupported encoding")) + ((null msg-buf) + t) + (t + (buffer-disable-undo msg-buf) + (buffer-disable-undo tmp-buf) + (set-buffer msg-buf) + (goto-char (point-min)) + (while (not (eobp)) + (unless (looking-at "#! *rnews +\\([0-9]+\\)") + (error "Bad header")) + (forward-line 1) + (setq beg (point) + end (+ (point) (string-to-int + (buffer-substring + (match-beginning 1) (match-end 1))))) + (switch-to-buffer tmp-buf) + (erase-buffer) + (insert-buffer-substring msg-buf beg end) + (goto-char (point-min)) + (search-forward "\n\n") + (forward-char -1) + (insert mail-header-separator) + (setq message-newsreader (setq message-mailer + (gnus-extended-version))) + (cond + ((string= (gnus-soup-reply-kind (car replies)) "news") + (gnus-message 5 "Sending news message to %s..." + (mail-fetch-field "newsgroups")) + (sit-for 1) + (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (funcall message-send-news-function))) + ((string= (gnus-soup-reply-kind (car replies)) "mail") + (gnus-message 5 "Sending mail to %s..." + (mail-fetch-field "to")) + (sit-for 1) + (message-send-mail)) + (t + (error "Unknown reply kind"))) + (set-buffer msg-buf) + (goto-char end)) + (delete-file (buffer-file-name)) + (kill-buffer msg-buf) + (kill-buffer tmp-buf) + (gnus-message 4 "Sent packet")))) + (setq replies (cdr replies))) + t))) + +(provide 'gnus-soup) + +;;; gnus-soup.el ends here diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el new file mode 100644 index 0000000..33333b4 --- /dev/null +++ b/lisp/gnus-spec.el @@ -0,0 +1,538 @@ +;;; gnus-spec.el --- format spec functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) + +;;; Internal variables. + +(defvar gnus-summary-mark-positions nil) +(defvar gnus-group-mark-positions nil) +(defvar gnus-group-indentation "") + +;; Format specs. The chunks below are the machine-generated forms +;; that are to be evaled as the result of the default format strings. +;; We write them in here to get them byte-compiled. That way the +;; default actions will be quite fast, while still retaining the full +;; flexibility of the user-defined format specs. + +;; First we have lots of dummy defvars to let the compiler know these +;; are really dynamic variables. + +(defvar gnus-tmp-unread) +(defvar gnus-tmp-replied) +(defvar gnus-tmp-score-char) +(defvar gnus-tmp-indentation) +(defvar gnus-tmp-opening-bracket) +(defvar gnus-tmp-lines) +(defvar gnus-tmp-name) +(defvar gnus-tmp-closing-bracket) +(defvar gnus-tmp-subject-or-nil) +(defvar gnus-tmp-subject) +(defvar gnus-tmp-marked) +(defvar gnus-tmp-marked-mark) +(defvar gnus-tmp-subscribed) +(defvar gnus-tmp-process-marked) +(defvar gnus-tmp-number-of-unread) +(defvar gnus-tmp-group-name) +(defvar gnus-tmp-group) +(defvar gnus-tmp-article-number) +(defvar gnus-tmp-unread-and-unselected) +(defvar gnus-tmp-news-method) +(defvar gnus-tmp-news-server) +(defvar gnus-tmp-article-number) +(defvar gnus-mouse-face) +(defvar gnus-mouse-face-prop) + +(defun gnus-summary-line-format-spec () + (insert gnus-tmp-unread gnus-tmp-replied + gnus-tmp-score-char gnus-tmp-indentation) + (gnus-put-text-property + (point) + (progn + (insert + gnus-tmp-opening-bracket + (format "%4d: %-20s" + gnus-tmp-lines + (if (> (length gnus-tmp-name) 20) + (substring gnus-tmp-name 0 20) + gnus-tmp-name)) + gnus-tmp-closing-bracket) + (point)) + gnus-mouse-face-prop gnus-mouse-face) + (insert " " gnus-tmp-subject-or-nil "\n")) + +(defvar gnus-summary-line-format-spec + (gnus-byte-code 'gnus-summary-line-format-spec)) + +(defun gnus-summary-dummy-line-format-spec () + (insert "* ") + (gnus-put-text-property + (point) + (progn + (insert ": :") + (point)) + gnus-mouse-face-prop gnus-mouse-face) + (insert " " gnus-tmp-subject "\n")) + +(defvar gnus-summary-dummy-line-format-spec + (gnus-byte-code 'gnus-summary-dummy-line-format-spec)) + +(defun gnus-group-line-format-spec () + (insert gnus-tmp-marked-mark gnus-tmp-subscribed + gnus-tmp-process-marked + gnus-group-indentation + (format "%5s: " gnus-tmp-number-of-unread)) + (gnus-put-text-property + (point) + (progn + (insert gnus-tmp-group "\n") + (1- (point))) + gnus-mouse-face-prop gnus-mouse-face)) +(defvar gnus-group-line-format-spec + (gnus-byte-code 'gnus-group-line-format-spec)) + +(defvar gnus-format-specs + `((version . ,emacs-version) + (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec) + (summary-dummy "* %(: :%) %S\n" + ,gnus-summary-dummy-line-format-spec) + (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + ,gnus-summary-line-format-spec)) + "Alist of format specs.") + +(defvar gnus-article-mode-line-format-spec nil) +(defvar gnus-summary-mode-line-format-spec nil) +(defvar gnus-group-mode-line-format-spec nil) + +;;; Phew. All that gruft is over, fortunately. + +;;;###autoload +(defun gnus-update-format (var) + "Update the format specification near point." + (interactive + (list + (save-excursion + (eval-defun nil) + ;; Find the end of the current word. + (re-search-forward "[ \t\n]" nil t) + ;; Search backward. + (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t) + (match-string 1))))) + (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var) + (match-string 1 var)))) + (entry (assq type gnus-format-specs)) + value spec) + (when entry + (setq gnus-format-specs (delq entry gnus-format-specs))) + (set + (intern (format "%s-spec" var)) + (gnus-parse-format (setq value (symbol-value (intern var))) + (symbol-value (intern (format "%s-alist" var))) + (not (string-match "mode" var)))) + (setq spec (symbol-value (intern (format "%s-spec" var)))) + (push (list type value spec) gnus-format-specs) + + (pop-to-buffer "*Gnus Format*") + (erase-buffer) + (lisp-interaction-mode) + (insert (pp-to-string spec)))) + +(defun gnus-update-format-specifications (&optional force &rest types) + "Update all (necessary) format specifications." + ;; Make the indentation array. + ;; See whether all the stored info needs to be flushed. + (when (or force + (not (equal emacs-version + (cdr (assq 'version gnus-format-specs))))) + (setq gnus-format-specs nil)) + + ;; Go through all the formats and see whether they need updating. + (let (new-format entry type val) + (while (setq type (pop types)) + ;; Jump to the proper buffer to find out the value of + ;; the variable, if possible. (It may be buffer-local.) + (save-excursion + (let ((buffer (intern (format "gnus-%s-buffer" type))) + val) + (when (and (boundp buffer) + (setq val (symbol-value buffer)) + (get-buffer val) + (buffer-name (get-buffer val))) + (set-buffer (get-buffer val))) + (setq new-format (symbol-value + (intern (format "gnus-%s-line-format" type))))) + (setq entry (cdr (assq type gnus-format-specs))) + (if (and (car entry) + (equal (car entry) new-format)) + ;; Use the old format. + (set (intern (format "gnus-%s-line-format-spec" type)) + (cadr entry)) + ;; This is a new format. + (setq val + (if (not (stringp new-format)) + ;; This is a function call or something. + new-format + ;; This is a "real" format. + (gnus-parse-format + new-format + (symbol-value + (intern (format "gnus-%s-line-format-alist" + (if (eq type 'article-mode) + 'summary-mode type)))) + (not (string-match "mode$" (symbol-name type)))))) + ;; Enter the new format spec into the list. + (if entry + (progn + (setcar (cdr entry) val) + (setcar entry new-format)) + (push (list type new-format val) gnus-format-specs)) + (set (intern (format "gnus-%s-line-format-spec" type)) val))))) + + (unless (assq 'version gnus-format-specs) + (push (cons 'version emacs-version) gnus-format-specs))) + +(defvar gnus-mouse-face-0 'highlight) +(defvar gnus-mouse-face-1 'highlight) +(defvar gnus-mouse-face-2 'highlight) +(defvar gnus-mouse-face-3 'highlight) +(defvar gnus-mouse-face-4 'highlight) + +(defun gnus-mouse-face-function (form type) + `(gnus-put-text-property + (point) (progn ,@form (point)) + gnus-mouse-face-prop + ,(if (equal type 0) + 'gnus-mouse-face + `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) + +(defvar gnus-face-0 'bold) +(defvar gnus-face-1 'italic) +(defvar gnus-face-2 'bold-italic) +(defvar gnus-face-3 'bold) +(defvar gnus-face-4 'bold) + +(defun gnus-face-face-function (form type) + `(gnus-put-text-property + (point) (progn ,@form (point)) + 'face ',(symbol-value (intern (format "gnus-face-%d" type))))) + +(defun gnus-tilde-max-form (el max-width) + "Return a form that limits EL to MAX-WIDTH." + (let ((max (abs max-width))) + (if (symbolp el) + `(if (> (length ,el) ,max) + ,(if (< max-width 0) + `(substring ,el (- (length el) ,max)) + `(substring ,el 0 ,max)) + ,el) + `(let ((val (eval ,el))) + (if (> (length val) ,max) + ,(if (< max-width 0) + `(substring val (- (length val) ,max)) + `(substring val 0 ,max)) + val))))) + +(defun gnus-tilde-cut-form (el cut-width) + "Return a form that cuts CUT-WIDTH off of EL." + (let ((cut (abs cut-width))) + (if (symbolp el) + `(if (> (length ,el) ,cut) + ,(if (< cut-width 0) + `(substring ,el 0 (- (length el) ,cut)) + `(substring ,el ,cut)) + ,el) + `(let ((val (eval ,el))) + (if (> (length val) ,cut) + ,(if (< cut-width 0) + `(substring val 0 (- (length val) ,cut)) + `(substring val ,cut)) + val))))) + +(defun gnus-tilde-ignore-form (el ignore-value) + "Return a form that is blank when EL is IGNORE-VALUE." + (if (symbolp el) + `(if (equal ,el ,ignore-value) + "" ,el) + `(let ((val (eval ,el))) + (if (equal val ,ignore-value) + "" val)))) + +(defun gnus-parse-format (format spec-alist &optional insert) + ;; This function parses the FORMAT string with the help of the + ;; SPEC-ALIST and returns a list that can be eval'ed to return the + ;; string. If the FORMAT string contains the specifiers %( and %) + ;; the text between them will have the mouse-face text property. + (if (string-match + "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'" + format) + (gnus-parse-complex-format format spec-alist) + ;; This is a simple format. + (gnus-parse-simple-format format spec-alist insert))) + +(defun gnus-parse-complex-format (format spec-alist) + (save-excursion + (gnus-set-work-buffer) + (insert format) + (goto-char (point-min)) + (while (re-search-forward "\"" nil t) + (replace-match "\\\"" nil t)) + (goto-char (point-min)) + (insert "(\"") + (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t) + (let ((number (if (match-beginning 1) + (match-string 1) "0")) + (delim (aref (match-string 2) 0))) + (if (or (= delim ?\() (= delim ?\{)) + (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face") + " " number " \"")) + (replace-match "\")\"")))) + (goto-char (point-max)) + (insert "\")") + (goto-char (point-min)) + (let ((form (read (current-buffer)))) + (cons 'progn (gnus-complex-form-to-spec form spec-alist))))) + +(defun gnus-complex-form-to-spec (form spec-alist) + (delq nil + (mapcar + (lambda (sform) + (if (stringp sform) + (gnus-parse-simple-format sform spec-alist t) + (funcall (intern (format "gnus-%s-face-function" (car sform))) + (gnus-complex-form-to-spec (cddr sform) spec-alist) + (nth 1 sform)))) + form))) + +(defun gnus-parse-simple-format (format spec-alist &optional insert) + ;; This function parses the FORMAT string with the help of the + ;; SPEC-ALIST and returns a list that can be eval'ed to return a + ;; string. + (let ((max-width 0) + spec flist fstring elem result dontinsert user-defined + type value pad-width spec-beg cut-width ignore-value + tilde-form tilde elem-type) + (save-excursion + (gnus-set-work-buffer) + (insert format) + (goto-char (point-min)) + (while (re-search-forward "%" nil t) + (setq user-defined nil + spec-beg nil + pad-width nil + max-width nil + cut-width nil + ignore-value nil + tilde-form nil) + (setq spec-beg (1- (point))) + + ;; Parse this spec fully. + (while + (cond + ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?") + (setq pad-width (string-to-number (match-string 1))) + (when (match-beginning 2) + (setq max-width (string-to-number (buffer-substring + (1+ (match-beginning 2)) + (match-end 2))))) + (goto-char (match-end 0))) + ((looking-at "~") + (forward-char 1) + (setq tilde (read (current-buffer)) + type (car tilde) + value (cadr tilde)) + (cond + ((memq type '(pad pad-left)) + (setq pad-width value)) + ((eq type 'pad-right) + (setq pad-width (- value))) + ((memq type '(max-right max)) + (setq max-width value)) + ((eq type 'max-left) + (setq max-width (- value))) + ((memq type '(cut cut-left)) + (setq cut-width value)) + ((eq type 'cut-right) + (setq cut-width (- value))) + ((eq type 'ignore) + (setq ignore-value + (if (stringp value) value (format "%s" value)))) + ((eq type 'form) + (setq tilde-form value)) + (t + (error "Unknown tilde type: %s" tilde))) + t) + (t + nil))) + ;; User-defined spec -- find the spec name. + (when (= (setq spec (following-char)) ?u) + (forward-char 1) + (setq user-defined (following-char))) + (forward-char 1) + (delete-region spec-beg (point)) + + ;; Now we have all the relevant data on this spec, so + ;; we start doing stuff. + (insert "%") + (if (eq spec ?%) + ;; "%%" just results in a "%". + (insert "%") + (cond + ;; Do tilde forms. + ((eq spec ?@) + (setq elem (list tilde-form ?s))) + ;; Treat user defined format specifiers specially. + (user-defined + (setq elem + (list + (list (intern (format "gnus-user-format-function-%c" + user-defined)) + 'gnus-tmp-header) + ?s))) + ;; Find the specification from `spec-alist'. + ((setq elem (cdr (assq spec spec-alist)))) + (t + (setq elem '("*" ?s)))) + (setq elem-type (cadr elem)) + ;; Insert the new format elements. + (when pad-width + (insert (number-to-string pad-width))) + ;; Create the form to be evaled. + (if (or max-width cut-width ignore-value) + (progn + (insert ?s) + (let ((el (car elem))) + (cond ((= (cadr elem) ?c) + (setq el (list 'char-to-string el))) + ((= (cadr elem) ?d) + (setq el (list 'int-to-string el)))) + (when ignore-value + (setq el (gnus-tilde-ignore-form el ignore-value))) + (when cut-width + (setq el (gnus-tilde-cut-form el cut-width))) + (when max-width + (setq el (gnus-tilde-max-form el max-width))) + (push el flist))) + (insert elem-type) + (push (car elem) flist)))) + (setq fstring (buffer-string))) + + ;; Do some postprocessing to increase efficiency. + (setq + result + (cond + ;; Emptyness. + ((string= fstring "") + nil) + ;; Not a format string. + ((not (string-match "%" fstring)) + (list fstring)) + ;; A format string with just a single string spec. + ((string= fstring "%s") + (list (car flist))) + ;; A single character. + ((string= fstring "%c") + (list (car flist))) + ;; A single number. + ((string= fstring "%d") + (setq dontinsert) + (if insert + (list `(princ ,(car flist))) + (list `(int-to-string ,(car flist))))) + ;; Just lots of chars and strings. + ((string-match "\\`\\(%[cs]\\)+\\'" fstring) + (nreverse flist)) + ;; A single string spec at the beginning of the spec. + ((string-match "\\`%[sc][^%]+\\'" fstring) + (list (car flist) (substring fstring 2))) + ;; A single string spec in the middle of the spec. + ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring) + (list (match-string 1 fstring) (car flist) (match-string 2 fstring))) + ;; A single string spec in the end of the spec. + ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring) + (list (match-string 1 fstring) (car flist))) + ;; A more complex spec. + (t + (list (cons 'format (cons fstring (nreverse flist))))))) + + (if insert + (when result + (if dontinsert + result + (cons 'insert result))) + (cond ((stringp result) + result) + ((consp result) + (cons 'concat result)) + (t ""))))) + +(defun gnus-eval-format (format &optional alist props) + "Eval the format variable FORMAT, using ALIST. +If PROPS, insert the result." + (let ((form (gnus-parse-format format alist props))) + (if props + (gnus-add-text-properties (point) (progn (eval form) (point)) props) + (eval form)))) + +(defun gnus-compile () + "Byte-compile the user-defined format specs." + (interactive) + (when gnus-xemacs + (error "Can't compile specs under XEmacs")) + (let ((entries gnus-format-specs) + (byte-compile-warnings '(unresolved callargs redefine)) + entry gnus-tmp-func) + (save-excursion + (gnus-message 7 "Compiling format specs...") + + (while entries + (setq entry (pop entries)) + (if (eq (car entry) 'version) + (setq gnus-format-specs (delq entry gnus-format-specs)) + (when (and (listp (caddr entry)) + (not (eq 'byte-code (caaddr entry)))) + (fset 'gnus-tmp-func `(lambda () ,(caddr entry))) + (byte-compile 'gnus-tmp-func) + (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))) + + (push (cons 'version emacs-version) gnus-format-specs) + ;; Mark the .newsrc.eld file as "dirty". + (gnus-dribble-enter " ") + (gnus-message 7 "Compiling user specs...done")))) + +(defun gnus-set-format (type &optional insertable) + (set (intern (format "gnus-%s-line-format-spec" type)) + (gnus-parse-format + (symbol-value (intern (format "gnus-%s-line-format" type))) + (symbol-value (intern (format "gnus-%s-line-format-alist" type))) + insertable))) + + +(provide 'gnus-spec) + +;;; gnus-spec.el ends here diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el new file mode 100644 index 0000000..d5122fe --- /dev/null +++ b/lisp/gnus-srvr.el @@ -0,0 +1,762 @@ +;;; gnus-srvr.el --- virtual server support for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-spec) +(require 'gnus-group) +(require 'gnus-int) +(require 'gnus-range) + +(defvar gnus-server-mode-hook nil + "Hook run in `gnus-server-mode' buffers.") + +(defconst gnus-server-line-format " {%(%h:%w%)} %s\n" + "Format of server lines. +It works along the same lines as a normal formatting string, +with some simple extensions. + +The following specs are understood: + +%h backend +%n name +%w address +%s status") + +(defvar gnus-server-mode-line-format "Gnus: %%b" + "The format specification for the server mode line.") + +(defvar gnus-server-exit-hook nil + "*Hook run when exiting the server buffer.") + +;;; Internal variables. + +(defvar gnus-inserted-opened-servers nil) + +(defvar gnus-server-line-format-alist + `((?h how ?s) + (?n name ?s) + (?w where ?s) + (?s status ?s))) + +(defvar gnus-server-mode-line-format-alist + `((?S news-server ?s) + (?M news-method ?s) + (?u user-defined ?s))) + +(defvar gnus-server-line-format-spec nil) +(defvar gnus-server-mode-line-format-spec nil) +(defvar gnus-server-killed-servers nil) + +(defvar gnus-server-mode-map) + +(defvar gnus-server-menu-hook nil + "*Hook run after the creation of the server mode menu.") + +(defun gnus-server-make-menu-bar () + (gnus-turn-off-edit-menu 'server) + (unless (boundp 'gnus-server-server-menu) + (easy-menu-define + gnus-server-server-menu gnus-server-mode-map "" + '("Server" + ["Add" gnus-server-add-server t] + ["Browse" gnus-server-read-server t] + ["Scan" gnus-server-scan-server t] + ["List" gnus-server-list-servers t] + ["Kill" gnus-server-kill-server t] + ["Yank" gnus-server-yank-server t] + ["Copy" gnus-server-copy-server t] + ["Edit" gnus-server-edit-server t] + ["Regenerate" gnus-server-regenerate-server t] + ["Exit" gnus-server-exit t])) + + (easy-menu-define + gnus-server-connections-menu gnus-server-mode-map "" + '("Connections" + ["Open" gnus-server-open-server t] + ["Close" gnus-server-close-server t] + ["Deny" gnus-server-deny-server t] + "---" + ["Open All" gnus-server-open-all-servers t] + ["Close All" gnus-server-close-all-servers t] + ["Reset All" gnus-server-remove-denials t])) + + (run-hooks 'gnus-server-menu-hook))) + +(defvar gnus-server-mode-map nil) +(put 'gnus-server-mode 'mode-class 'special) + +(unless gnus-server-mode-map + (setq gnus-server-mode-map (make-sparse-keymap)) + (suppress-keymap gnus-server-mode-map) + + (gnus-define-keys gnus-server-mode-map + " " gnus-server-read-server + "\r" gnus-server-read-server + gnus-mouse-2 gnus-server-pick-server + "q" gnus-server-exit + "l" gnus-server-list-servers + "k" gnus-server-kill-server + "y" gnus-server-yank-server + "c" gnus-server-copy-server + "a" gnus-server-add-server + "e" gnus-server-edit-server + "s" gnus-server-scan-server + + "O" gnus-server-open-server + "\M-o" gnus-server-open-all-servers + "C" gnus-server-close-server + "\M-c" gnus-server-close-all-servers + "D" gnus-server-deny-server + "R" gnus-server-remove-denials + + "g" gnus-server-regenerate-server + + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) + +(defun gnus-server-mode () + "Major mode for listing and editing servers. + +All normal editing commands are switched off. +\\ +For more in-depth information on this mode, read the manual +(`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-server-mode-map}" + (interactive) + (when (gnus-visual-p 'server-menu 'menu) + (gnus-server-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-server-mode) + (setq mode-name "Server") + (gnus-set-default-directory) + (setq mode-line-process nil) + (use-local-map gnus-server-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (setq buffer-read-only t) + (run-hooks 'gnus-server-mode-hook)) + +(defun gnus-server-insert-server-line (name method) + (let* ((how (car method)) + (where (nth 1 method)) + (elem (assoc method gnus-opened-servers)) + (status (cond ((eq (nth 1 elem) 'denied) + "(denied)") + ((or (gnus-server-opened method) + (eq (nth 1 elem) 'ok)) + "(opened)") + (t + "(closed)")))) + (beginning-of-line) + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + ;; Insert the text. + (eval gnus-server-line-format-spec)) + (list 'gnus-server (intern name))))) + +(defun gnus-enter-server-buffer () + "Set up the server buffer." + (gnus-server-setup-buffer) + (gnus-configure-windows 'server) + (gnus-server-prepare)) + +(defun gnus-server-setup-buffer () + "Initialize the server buffer." + (unless (get-buffer gnus-server-buffer) + (save-excursion + (set-buffer (get-buffer-create gnus-server-buffer)) + (gnus-server-mode) + (when gnus-carpal + (gnus-carpal-setup-buffer 'server))))) + +(defun gnus-server-prepare () + (gnus-set-format 'server-mode) + (gnus-set-format 'server t) + (let ((alist gnus-server-alist) + (buffer-read-only nil) + (opened gnus-opened-servers) + done server op-ser) + (erase-buffer) + (setq gnus-inserted-opened-servers nil) + ;; First we do the real list of servers. + (while alist + (unless (member (cdar alist) done) + (push (cdar alist) done) + (cdr (setq server (pop alist))) + (when (and server (car server) (cdr server)) + (gnus-server-insert-server-line (car server) (cdr server)))) + (when (member (cdar alist) done) + (pop alist))) + ;; Then we insert the list of servers that have been opened in + ;; this session. + (while opened + (unless (member (caar opened) done) + (push (caar opened) done) + (gnus-server-insert-server-line + (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) + (caar opened)) + (push (list op-ser (caar opened)) gnus-inserted-opened-servers)) + (setq opened (cdr opened)))) + (goto-char (point-min)) + (gnus-server-position-point)) + +(defun gnus-server-server-name () + (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) + (and server (symbol-name server)))) + +(defalias 'gnus-server-position-point 'gnus-goto-colon) + +(defconst gnus-server-edit-buffer "*Gnus edit server*") + +(defun gnus-server-update-server (server) + (save-excursion + (set-buffer gnus-server-buffer) + (let* ((buffer-read-only nil) + (entry (assoc server gnus-server-alist)) + (oentry (assoc (gnus-server-to-method server) + gnus-opened-servers))) + (when entry + (gnus-dribble-enter + (concat "(gnus-server-set-info \"" server "\" '" + (prin1-to-string (cdr entry)) ")\n"))) + (when (or entry oentry) + ;; Buffer may be narrowed. + (save-restriction + (widen) + (when (gnus-server-goto-server server) + (gnus-delete-line)) + (if entry + (gnus-server-insert-server-line (car entry) (cdr entry)) + (gnus-server-insert-server-line + (format "%s:%s" (caar oentry) (nth 1 (car oentry))) + (car oentry))) + (gnus-server-position-point)))))) + +(defun gnus-server-set-info (server info) + ;; Enter a select method into the virtual server alist. + (when (and server info) + (gnus-dribble-enter + (concat "(gnus-server-set-info \"" server "\" '" + (prin1-to-string info) ")")) + (let* ((server (nth 1 info)) + (entry (assoc server gnus-server-alist))) + (if entry (setcdr entry info) + (setq gnus-server-alist + (nconc gnus-server-alist (list (cons server info)))))))) + +;;; Interactive server functions. + +(defun gnus-server-kill-server (server) + "Kill the server on the current line." + (interactive (list (gnus-server-server-name))) + (unless (gnus-server-goto-server server) + (if server (error "No such server: %s" server) + (error "No server on the current line"))) + (unless (assoc server gnus-server-alist) + (error "Read-only server %s" server)) + (gnus-dribble-enter "") + (let ((buffer-read-only nil)) + (gnus-delete-line)) + (push (assoc server gnus-server-alist) gnus-server-killed-servers) + (setq gnus-server-alist (delq (car gnus-server-killed-servers) + gnus-server-alist)) + (gnus-server-position-point)) + +(defun gnus-server-yank-server () + "Yank the previously killed server." + (interactive) + (unless gnus-server-killed-servers + (error "No killed servers to be yanked")) + (let ((alist gnus-server-alist) + (server (gnus-server-server-name)) + (killed (car gnus-server-killed-servers))) + (if (not server) + (setq gnus-server-alist (nconc gnus-server-alist (list killed))) + (if (string= server (caar gnus-server-alist)) + (push killed gnus-server-alist) + (while (and (cdr alist) + (not (string= server (caadr alist)))) + (setq alist (cdr alist))) + (if alist + (setcdr alist (cons killed (cdr alist))) + (setq gnus-server-alist (list killed))))) + (gnus-server-update-server (car killed)) + (setq gnus-server-killed-servers (cdr gnus-server-killed-servers)) + (gnus-server-position-point))) + +(defun gnus-server-exit () + "Return to the group buffer." + (interactive) + (run-hooks 'gnus-server-exit-hook) + (kill-buffer (current-buffer)) + (gnus-configure-windows 'group t)) + +(defun gnus-server-list-servers () + "List all available servers." + (interactive) + (let ((cur (gnus-server-server-name))) + (gnus-server-prepare) + (if cur (gnus-server-goto-server cur) + (goto-char (point-max)) + (forward-line -1)) + (gnus-server-position-point))) + +(defun gnus-server-set-status (method status) + "Make METHOD have STATUS." + (let ((entry (assoc method gnus-opened-servers))) + (if entry + (setcar (cdr entry) status) + (push (list method status) gnus-opened-servers)))) + +(defun gnus-opened-servers-remove (method) + "Remove METHOD from the list of opened servers." + (setq gnus-opened-servers (delq (assoc method gnus-opened-servers) + gnus-opened-servers))) + +(defun gnus-server-open-server (server) + "Force an open of SERVER." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (unless method + (error "No such server: %s" server)) + (gnus-server-set-status method 'ok) + (prog1 + (or (gnus-open-server method) + (progn (message "Couldn't open %s" server) nil)) + (gnus-server-update-server server) + (gnus-server-position-point)))) + +(defun gnus-server-open-all-servers () + "Open all servers." + (interactive) + (let ((servers gnus-inserted-opened-servers)) + (while servers + (gnus-server-open-server (car (pop servers)))))) + +(defun gnus-server-close-server (server) + "Close SERVER." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (unless method + (error "No such server: %s" server)) + (gnus-server-set-status method 'closed) + (prog1 + (gnus-close-server method) + (gnus-server-update-server server) + (gnus-server-position-point)))) + +(defun gnus-server-close-all-servers () + "Close all servers." + (interactive) + (let ((servers gnus-inserted-opened-servers)) + (while servers + (gnus-server-close-server (car (pop servers)))))) + +(defun gnus-server-deny-server (server) + "Make sure SERVER will never be attempted opened." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (unless method + (error "No such server: %s" server)) + (gnus-server-set-status method 'denied)) + (gnus-server-update-server server) + (gnus-server-position-point) + t) + +(defun gnus-server-remove-denials () + "Make all denied servers into closed servers." + (interactive) + (let ((servers gnus-opened-servers)) + (while servers + (when (eq (nth 1 (car servers)) 'denied) + (setcar (nthcdr 1 (car servers)) 'closed)) + (setq servers (cdr servers)))) + (gnus-server-list-servers)) + +(defun gnus-server-copy-server (from to) + (interactive + (list + (or (gnus-server-server-name) + (error "No server on the current line")) + (read-string "Copy to: "))) + (unless from + (error "No server on current line")) + (unless (and to (not (string= to ""))) + (error "No name to copy to")) + (when (assoc to gnus-server-alist) + (error "%s already exists" to)) + (unless (gnus-server-to-method from) + (error "%s: no such server" from)) + (let ((to-entry (cons from (gnus-copy-sequence + (gnus-server-to-method from))))) + (setcar to-entry to) + (setcar (nthcdr 2 to-entry) to) + (push to-entry gnus-server-killed-servers) + (gnus-server-yank-server))) + +(defun gnus-server-add-server (how where) + (interactive + (list (intern (completing-read "Server method: " + gnus-valid-select-methods nil t)) + (read-string "Server name: "))) + (when (assq where gnus-server-alist) + (error "Server with that name already defined")) + (push (list where how where) gnus-server-killed-servers) + (gnus-server-yank-server)) + +(defun gnus-server-goto-server (server) + "Jump to a server line." + (interactive + (list (completing-read "Goto server: " gnus-server-alist nil t))) + (let ((to (text-property-any (point-min) (point-max) + 'gnus-server (intern server)))) + (when to + (goto-char to) + (gnus-server-position-point)))) + +(defun gnus-server-edit-server (server) + "Edit the server on the current line." + (interactive (list (gnus-server-server-name))) + (unless server + (error "No server on current line")) + (unless (assoc server gnus-server-alist) + (error "This server can't be edited")) + (let ((info (cdr (assoc server gnus-server-alist)))) + (gnus-close-server info) + (gnus-edit-form + info "Editing the server." + `(lambda (form) + (gnus-server-set-info ,server form) + (gnus-server-list-servers) + (gnus-server-position-point))))) + +(defun gnus-server-scan-server (server) + "Request a scan from the current server." + (interactive (list (gnus-server-server-name))) + (gnus-message 3 "Scanning %s...done" server) + (gnus-request-scan nil (gnus-server-to-method server)) + (gnus-message 3 "Scanning %s...done" server)) + +(defun gnus-server-read-server (server) + "Browse a server." + (interactive (list (gnus-server-server-name))) + (let ((buf (current-buffer))) + (prog1 + (gnus-browse-foreign-server (gnus-server-to-method server) buf) + (save-excursion + (set-buffer buf) + (gnus-server-update-server (gnus-server-server-name)) + (gnus-server-position-point))))) + +(defun gnus-server-pick-server (e) + (interactive "e") + (mouse-set-point e) + (gnus-server-read-server (gnus-server-server-name))) + + +;;; +;;; Browse Server Mode +;;; + +(defvar gnus-browse-menu-hook nil + "*Hook run after the creation of the browse mode menu.") + +(defvar gnus-browse-mode-hook nil) +(defvar gnus-browse-mode-map nil) +(put 'gnus-browse-mode 'mode-class 'special) + +(unless gnus-browse-mode-map + (setq gnus-browse-mode-map (make-keymap)) + (suppress-keymap gnus-browse-mode-map) + + (gnus-define-keys + gnus-browse-mode-map + " " gnus-browse-read-group + "=" gnus-browse-select-group + "n" gnus-browse-next-group + "p" gnus-browse-prev-group + "\177" gnus-browse-prev-group + [delete] gnus-browse-prev-group + "N" gnus-browse-next-group + "P" gnus-browse-prev-group + "\M-n" gnus-browse-next-group + "\M-p" gnus-browse-prev-group + "\r" gnus-browse-select-group + "u" gnus-browse-unsubscribe-current-group + "l" gnus-browse-exit + "L" gnus-browse-exit + "q" gnus-browse-exit + "Q" gnus-browse-exit + "\C-c\C-c" gnus-browse-exit + "?" gnus-browse-describe-briefly + + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) + +(defun gnus-browse-make-menu-bar () + (gnus-turn-off-edit-menu 'browse) + (unless (boundp 'gnus-browse-menu) + (easy-menu-define + gnus-browse-menu gnus-browse-mode-map "" + '("Browse" + ["Subscribe" gnus-browse-unsubscribe-current-group t] + ["Read" gnus-browse-read-group t] + ["Select" gnus-browse-read-group t] + ["Next" gnus-browse-next-group t] + ["Prev" gnus-browse-next-group t] + ["Exit" gnus-browse-exit t])) + (run-hooks 'gnus-browse-menu-hook))) + +(defvar gnus-browse-current-method nil) +(defvar gnus-browse-return-buffer nil) + +(defvar gnus-browse-buffer "*Gnus Browse Server*") + +(defun gnus-browse-foreign-server (method &optional return-buffer) + "Browse the server METHOD." + (setq gnus-browse-current-method method) + (setq gnus-browse-return-buffer return-buffer) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let ((gnus-select-method method) + groups group) + (gnus-message 5 "Connecting to %s..." (nth 1 method)) + (cond + ((not (gnus-check-server method)) + (gnus-message + 1 "Unable to contact server %s: %s" (nth 1 method) + (gnus-status-message method)) + nil) + ((not + (prog2 + (gnus-message 6 "Reading active file...") + (gnus-request-list method) + (gnus-message 6 "Reading active file...done"))) + (gnus-message + 1 "Couldn't request list: %s" (gnus-status-message method)) + nil) + (t + (get-buffer-create gnus-browse-buffer) + (gnus-add-current-to-buffer-list) + (when gnus-carpal + (gnus-carpal-setup-buffer 'browse)) + (gnus-configure-windows 'browse) + (buffer-disable-undo (current-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer)) + (gnus-browse-mode) + (setq mode-line-buffer-identification + (list + (format + "Gnus: %%b {%s:%s}" (car method) (cadr method)))) + (save-excursion + (set-buffer nntp-server-buffer) + (let ((cur (current-buffer))) + (goto-char (point-min)) + (unless (string= gnus-ignored-newsgroups "") + (delete-matching-lines gnus-ignored-newsgroups)) + (while (re-search-forward + "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t) + (goto-char (match-end 1)) + (push (cons (match-string 1) + (max 0 (- (1+ (read cur)) (read cur)))) + groups)))) + (setq groups (sort groups + (lambda (l1 l2) + (string< (car l1) (car l2))))) + (let ((buffer-read-only nil)) + (while groups + (setq group (car groups)) + (insert + (format "K%7d: %s\n" (cdr group) (car group))) + (setq groups (cdr groups)))) + (switch-to-buffer (current-buffer)) + (goto-char (point-min)) + (gnus-group-position-point) + (gnus-message 5 "Connecting to %s...done" (nth 1 method)) + t)))) + +(defun gnus-browse-mode () + "Major mode for browsing a foreign server. + +All normal editing commands are switched off. + +\\ +The only things you can do in this buffer is + +1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group. +The group will be inserted into the group buffer upon exit from this +buffer. + +2) `\\[gnus-browse-read-group]' to read a group ephemerally. + +3) `\\[gnus-browse-exit]' to return to the group buffer." + (interactive) + (kill-all-local-variables) + (when (gnus-visual-p 'browse-menu 'menu) + (gnus-browse-make-menu-bar)) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-browse-mode) + (setq mode-name "Browse Server") + (setq mode-line-process nil) + (use-local-map gnus-browse-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (gnus-set-default-directory) + (setq buffer-read-only t) + (run-hooks 'gnus-browse-mode-hook)) + +(defun gnus-browse-read-group (&optional no-article) + "Enter the group at the current line." + (interactive) + (let ((group (gnus-browse-group-name))) + (unless (gnus-group-read-ephemeral-group + group gnus-browse-current-method nil + (cons (current-buffer) 'browse)) + (error "Couldn't enter %s" group)))) + +(defun gnus-browse-select-group () + "Select the current group." + (interactive) + (gnus-browse-read-group 'no)) + +(defun gnus-browse-next-group (n) + "Go to the next group." + (interactive "p") + (prog1 + (forward-line n) + (gnus-group-position-point))) + +(defun gnus-browse-prev-group (n) + "Go to the next group." + (interactive "p") + (gnus-browse-next-group (- n))) + +(defun gnus-browse-unsubscribe-current-group (arg) + "(Un)subscribe to the next ARG groups." + (interactive "p") + (when (eobp) + (error "No group at current line")) + (let ((ward (if (< arg 0) -1 1)) + (arg (abs arg))) + (while (and (> arg 0) + (not (eobp)) + (gnus-browse-unsubscribe-group) + (zerop (gnus-browse-next-group ward))) + (decf arg)) + (gnus-group-position-point) + (when (/= 0 arg) + (gnus-message 7 "No more newsgroups")) + arg)) + +(defun gnus-browse-group-name () + (save-excursion + (beginning-of-line) + (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) + (gnus-group-prefixed-name + ;; Remove text props. + (format "%s" (match-string 1)) + gnus-browse-current-method)))) + +(defun gnus-browse-unsubscribe-group () + "Toggle subscription of the current group in the browse buffer." + (let ((sub nil) + (buffer-read-only nil) + group) + (save-excursion + (beginning-of-line) + ;; If this group it killed, then we want to subscribe it. + (when (= (following-char) ?K) + (setq sub t)) + (when (gnus-gethash (setq group (gnus-browse-group-name)) + gnus-newsrc-hashtb) + (error "Group already subscribed")) + ;; Make sure the group has been properly removed before we + ;; subscribe to it. + (gnus-kill-ephemeral-group group) + (delete-char 1) + (if sub + (progn + (gnus-group-change-level + (list t group gnus-level-default-subscribed + nil nil gnus-browse-current-method) + gnus-level-default-subscribed gnus-level-killed + (and (car (nth 1 gnus-newsrc-alist)) + (gnus-gethash (car (nth 1 gnus-newsrc-alist)) + gnus-newsrc-hashtb)) + t) + (insert ? )) + (gnus-group-change-level + group gnus-level-killed gnus-level-default-subscribed) + (insert ?K))) + t)) + +(defun gnus-browse-exit () + "Quit browsing and return to the group buffer." + (interactive) + (when (eq major-mode 'gnus-browse-mode) + (kill-buffer (current-buffer))) + ;; Insert the newly subscribed groups in the group buffer. + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-list-groups nil)) + (if gnus-browse-return-buffer + (gnus-configure-windows 'server 'force) + (gnus-configure-windows 'group 'force))) + +(defun gnus-browse-describe-briefly () + "Give a one line description of the group mode commands." + (interactive) + (gnus-message 6 + (substitute-command-keys "\\\\[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"))) + +(defun gnus-server-regenerate-server () + "Issue a command to the server to regenerate all its data structures." + (interactive) + (let ((server (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (if (not (gnus-check-backend-function + 'request-regenerate (car (gnus-server-to-method server)))) + (error "This backend doesn't support regeneration") + (gnus-message 5 "Requesting regeneration of %s..." server) + (unless (gnus-open-server server) + (error "Couldn't open server")) + (if (gnus-request-regenerate server) + (gnus-message 5 "Requesting regeneration of %s...done" server) + (gnus-message 5 "Couldn't regenerate %s" server))))) + +(provide 'gnus-srvr) + +;;; gnus-srvr.el ends here. diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el new file mode 100644 index 0000000..6110061 --- /dev/null +++ b/lisp/gnus-start.el @@ -0,0 +1,2512 @@ +;;; gnus-start.el --- startup functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-win) +(require 'gnus-int) +(require 'gnus-spec) +(require 'gnus-range) +(require 'gnus-util) +(require 'message) +(eval-when-compile (require 'cl)) + +(defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc") + "Your `.newsrc' file. +`.newsrc-SERVER' will be used instead if that exists." + :group 'gnus-start + :type 'file) + +(defcustom gnus-init-file (nnheader-concat gnus-home-directory ".gnus") + "Your Gnus Emacs-Lisp startup file name. +If a file with the `.el' or `.elc' suffixes exists, it will be read instead." + :group 'gnus-start + :type 'file) + +(defcustom gnus-site-init-file + (condition-case nil + (concat (file-name-directory + (directory-file-name installation-directory)) + "site-lisp/gnus-init") + (error nil)) + "The site-wide Gnus Emacs-Lisp startup file name, or nil if none. +If a file with the `.el' or `.elc' suffixes exists, it will be read instead." + :group 'gnus-start + :type '(choice file (const nil))) + +(defcustom gnus-default-subscribed-newsgroups nil + "List of newsgroups to subscribe, when a user runs Gnus the first time. +The value should be a list of strings. +If it is t, Gnus will not do anything special the first time it is +started; it'll just use the normal newsgroups subscription methods." + :group 'gnus-start + :type '(choice (repeat string) (const :tag "Nothing special" t))) + +(defcustom gnus-use-dribble-file t + "*Non-nil means that Gnus will use a dribble file to store user updates. +If Emacs should crash without saving the .newsrc files, complete +information can be restored from the dribble file." + :group 'gnus-dribble-file + :type 'boolean) + +(defcustom gnus-dribble-directory nil + "*The directory where dribble files will be saved. +If this variable is nil, the directory where the .newsrc files are +saved will be used." + :group 'gnus-dribble-file + :type '(choice directory (const nil))) + +(defcustom gnus-check-new-newsgroups 'ask-server + "*Non-nil means that Gnus will run gnus-find-new-newsgroups at startup. +This normally finds new newsgroups by comparing the active groups the +servers have already reported with those Gnus already knows, either alive +or killed. + +When any of the following are true, gnus-find-new-newsgroups will instead +ask the servers (primary, secondary, and archive servers) to list new +groups since the last time it checked: + 1. This variable is `ask-server'. + 2. This variable is a list of select methods (see below). + 3. `gnus-read-active-file' is nil or `some'. + 4. A prefix argument is given to gnus-find-new-newsgroups interactively. + +Thus, if this variable is `ask-server' or a list of select methods or +`gnus-read-active-file' is nil or `some', then the killed list is no +longer necessary, so you could safely set `gnus-save-killed-list' to nil. + +This variable can be a list of select methods which Gnus will query with +the `ask-server' method in addition to the primary, secondary, and archive +servers. + +Eg. + (setq gnus-check-new-newsgroups + '((nntp \"some.server\") (nntp \"other.server\"))) + +If this variable is nil, then you have to tell Gnus explicitly to +check for new newsgroups with \\\\[gnus-find-new-newsgroups]." + :group 'gnus-start + :type '(choice (const :tag "no" nil) + (const :tag "by brute force" t) + (const :tag "ask servers" ask-server) + (repeat :menu-tag "ask additional servers" + :tag "ask additional servers" + :value ((nntp "")) + (sexp :format "%v")))) + +(defcustom gnus-check-bogus-newsgroups nil + "*Non-nil means that Gnus will check and remove bogus newsgroup at startup. +If this variable is nil, then you have to tell Gnus explicitly to +check for bogus newsgroups with \\\\[gnus-group-check-bogus-groups]." + :group 'gnus-start-server + :type 'boolean) + +(defcustom gnus-read-active-file 'some + "*Non-nil means that Gnus will read the entire active file at startup. +If this variable is nil, Gnus will only know about the groups in your +`.newsrc' file. + +If this variable is `some', Gnus will try to only read the relevant +parts of the active file from the server. Not all servers support +this, and it might be quite slow with other servers, but this should +generally be faster than both the t and nil value. + +If you set this variable to nil or `some', you probably still want to +be told about new newsgroups that arrive. To do that, set +`gnus-check-new-newsgroups' to `ask-server'. This may not work +properly with all servers." + :group 'gnus-start-server + :type '(choice (const nil) + (const some) + (const t))) + +(defcustom gnus-level-subscribed 5 + "*Groups with levels less than or equal to this variable are subscribed." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-level-unsubscribed 7 + "*Groups with levels less than or equal to this variable are unsubscribed. +Groups with levels less than `gnus-level-subscribed', which should be +less than this variable, are subscribed." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-level-zombie 8 + "*Groups with this level are zombie groups." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-level-killed 9 + "*Groups with this level are killed." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-level-default-subscribed 3 + "*New subscribed groups will be subscribed at this level." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-level-default-unsubscribed 6 + "*New unsubscribed groups will be unsubscribed at this level." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-activate-level (1+ gnus-level-subscribed) + "*Groups higher than this level won't be activated on startup. +Setting this variable to something low might save lots of time when +you have many groups that you aren't interested in." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-activate-foreign-newsgroups 4 + "*If nil, Gnus will not check foreign newsgroups at startup. +If it is non-nil, it should be a number between one and nine. Foreign +newsgroups that have a level lower or equal to this number will be +activated on startup. For instance, if you want to active all +subscribed newsgroups, but not the rest, you'd set this variable to +`gnus-level-subscribed'. + +If you subscribe to lots of newsgroups from different servers, startup +might take a while. By setting this variable to nil, you'll save time, +but you won't be told how many unread articles there are in the +groups." + :group 'gnus-group-levels + :type 'integer) + +(defcustom gnus-save-newsrc-file t + "*Non-nil means that Gnus will save the `.newsrc' file. +Gnus always saves its own startup file, which is called +\".newsrc.eld\". The file called \".newsrc\" is in a format that can +be readily understood by other newsreaders. If you don't plan on +using other newsreaders, set this variable to nil to save some time on +exit." + :group 'gnus-newsrc + :type 'boolean) + +(defcustom gnus-save-killed-list t + "*If non-nil, save the list of killed groups to the startup file. +If you set this variable to nil, you'll save both time (when starting +and quitting) and space (both memory and disk), but it will also mean +that Gnus has no record of which groups are new and which are old, so +the automatic new newsgroups subscription methods become meaningless. + +You should always set `gnus-check-new-newsgroups' to `ask-server' or +nil if you set this variable to nil. + +This variable can also be a regexp. In that case, all groups that do +not match this regexp will be removed before saving the list." + :group 'gnus-newsrc + :type 'boolean) + +(defcustom gnus-ignored-newsgroups + (purecopy (mapconcat 'identity + '("^to\\." ; not "real" groups + "^[0-9. \t]+ " ; all digits in name + "[][\"#'()]" ; bogus characters + ) + "\\|")) + "A regexp to match uninteresting newsgroups in the active file. +Any lines in the active file matching this regular expression are +removed from the newsgroup list before anything else is done to it, +thus making them effectively non-existent." + :group 'gnus-group-new + :type 'regexp) + +(defcustom gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies + "*Function called with a group name when new group is detected. +A few pre-made functions are supplied: `gnus-subscribe-randomly' +inserts new groups at the beginning of the list of groups; +`gnus-subscribe-alphabetically' inserts new groups in strict +alphabetic order; `gnus-subscribe-hierarchically' inserts new groups +in hierarchical newsgroup order; `gnus-subscribe-interactively' asks +for your decision; `gnus-subscribe-killed' kills all new groups; +`gnus-subscribe-zombies' will make all new groups into zombies." + :group 'gnus-group-new + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + function)) + +;; Suggested by a bug report by Hallvard B Furuseth. +;; . +(defcustom gnus-subscribe-options-newsgroup-method + 'gnus-subscribe-alphabetically + "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines. +If, for instance, you want to subscribe to all newsgroups in the +\"no\" and \"alt\" hierarchies, you'd put the following in your +.newsrc file: + +options -n no.all alt.all + +Gnus will the subscribe all new newsgroups in these hierarchies with +the subscription method in this variable." + :group 'gnus-group-new + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + function)) + +(defcustom gnus-subscribe-hierarchical-interactive nil + "*If non-nil, Gnus will offer to subscribe hierarchically. +When a new hierarchy appears, Gnus will ask the user: + +'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys): + +If the user pressed `d', Gnus will descend the hierarchy, `y' will +subscribe to all newsgroups in the hierarchy and `s' will skip this +hierarchy in its entirety." + :group 'gnus-group-new + :type 'boolean) + +(defcustom gnus-auto-subscribed-groups + "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" + "*All new groups that match this regexp will be subscribed automatically. +Note that this variable only deals with new groups. It has no effect +whatsoever on old groups. + +New groups that match this regexp will not be handled by +`gnus-subscribe-newsgroup-method'. Instead, they will +be subscribed using `gnus-subscribe-options-newsgroup-method'." + :group 'gnus-group-new + :type 'regexp) + +(defcustom gnus-options-subscribe nil + "*All new groups matching this regexp will be subscribed unconditionally. +Note that this variable deals only with new newsgroups. This variable +does not affect old newsgroups. + +New groups that match this regexp will not be handled by +`gnus-subscribe-newsgroup-method'. Instead, they will +be subscribed using `gnus-subscribe-options-newsgroup-method'." + :group 'gnus-group-new + :type '(choice regexp + (const :tag "none" nil))) + +(defcustom gnus-options-not-subscribe nil + "*All new groups matching this regexp will be ignored. +Note that this variable deals only with new newsgroups. This variable +does not affect old (already subscribed) newsgroups." + :group 'gnus-group-new + :type '(choice regexp + (const :tag "none" nil))) + +(defcustom gnus-modtime-botch nil + "*Non-nil means .newsrc should be deleted prior to save. +Its use is due to the bogus appearance that .newsrc was modified on +disc." + :group 'gnus-newsrc + :type 'boolean) + +(defcustom gnus-check-bogus-groups-hook nil + "A hook run after removing bogus groups." + :group 'gnus-start-server + :type 'hook) + +(defcustom gnus-startup-hook nil + "A hook called at startup. +This hook is called after Gnus is connected to the NNTP server." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-startup-hook nil + "A hook called at before startup. +This hook is called as the first thing when Gnus is started." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-started-hook nil + "A hook called as the last thing after startup." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-setup-news-hook nil + "A hook after reading the .newsrc file, but before generating the buffer." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-get-new-news-hook nil + "A hook run just before Gnus checks for new news." + :group 'gnus-group-new + :type 'hook) + +(defcustom gnus-after-getting-new-news-hook + (when (gnus-boundp 'display-time-timer) + '(display-time-event-handler)) + "A hook run after Gnus checks for new news." + :group 'gnus-group-new + :type 'hook) + +(defcustom gnus-save-newsrc-hook nil + "A hook called before saving any of the newsrc files." + :group 'gnus-newsrc + :type 'hook) + +(defcustom gnus-save-quick-newsrc-hook nil + "A hook called just before saving the quick newsrc file. +Can be used to turn version control on or off." + :group 'gnus-newsrc + :type 'hook) + +(defcustom gnus-save-standard-newsrc-hook nil + "A hook called just before saving the standard newsrc file. +Can be used to turn version control on or off." + :group 'gnus-newsrc + :type 'hook) + +;;; Internal variables + +(defvar gnus-newsrc-file-version nil) +(defvar gnus-override-subscribe-method nil) +(defvar gnus-dribble-buffer nil) +(defvar gnus-newsrc-options nil + "Options line in the .newsrc file.") + +(defvar gnus-newsrc-options-n nil + "List of regexps representing groups to be subscribed/ignored unconditionally.") + +(defvar gnus-newsrc-last-checked-date nil + "Date Gnus last asked server for new newsgroups.") + +(defvar gnus-current-startup-file nil + "Startup file for the current host.") + +;; Byte-compiler warning. +(defvar gnus-group-line-format) + +;; Suggested by Brian Edmonds . +(defvar gnus-init-inhibit nil) +(defun gnus-read-init-file (&optional inhibit-next) + ;; Don't load .gnus if the -q option was used. + (when init-file-user + (if gnus-init-inhibit + (setq gnus-init-inhibit nil) + (setq gnus-init-inhibit inhibit-next) + (let ((files (list gnus-site-init-file gnus-init-file)) + file) + (while files + (and (setq file (pop files)) + (or (and (file-exists-p file) + ;; Don't try to load a directory. + (not (file-directory-p file))) + (file-exists-p (concat file ".el")) + (file-exists-p (concat file ".elc"))) + (condition-case var + (load file nil t) + (error + (error "Error in %s: %s" file var))))))))) + +;; For subscribing new newsgroup + +(defun gnus-subscribe-hierarchical-interactive (groups) + (let ((groups (sort groups 'string<)) + prefixes prefix start ans group starts) + (while groups + (setq prefixes (list "^")) + (while (and groups prefixes) + (while (not (string-match (car prefixes) (car groups))) + (setq prefixes (cdr prefixes))) + (setq prefix (car prefixes)) + (setq start (1- (length prefix))) + (if (and (string-match "[^\\.]\\." (car groups) start) + (cdr groups) + (setq prefix + (concat "^" (substring (car groups) 0 (match-end 0)))) + (string-match prefix (cadr groups))) + (progn + (push prefix prefixes) + (message "Descend hierarchy %s? ([y]nsq): " + (substring prefix 1 (1- (length prefix)))) + (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?n ?s ?q))) + (ding) + (message "Descend hierarchy %s? ([y]nsq): " + (substring prefix 1 (1- (length prefix))))) + (cond ((= ans ?n) + (while (and groups + (string-match prefix + (setq group (car groups)))) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb) + (setq groups (cdr groups))) + (setq starts (cdr starts))) + ((= ans ?s) + (while (and groups + (string-match prefix + (setq group (car groups)))) + (gnus-sethash group group gnus-killed-hashtb) + (gnus-subscribe-alphabetically (car groups)) + (setq groups (cdr groups))) + (setq starts (cdr starts))) + ((= ans ?q) + (while groups + (setq group (car groups)) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb) + (setq groups (cdr groups)))) + (t nil))) + (message "Subscribe %s? ([n]yq)" (car groups)) + (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?q ?n))) + (ding) + (message "Subscribe %s? ([n]yq)" (car groups))) + (setq group (car groups)) + (cond ((= ans ?y) + (gnus-subscribe-alphabetically (car groups)) + (gnus-sethash group group gnus-killed-hashtb)) + ((= ans ?q) + (while groups + (setq group (car groups)) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb) + (setq groups (cdr groups)))) + (t + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb))) + (setq groups (cdr groups))))))) + +(defun gnus-subscribe-randomly (newsgroup) + "Subscribe new NEWSGROUP by making it the first newsgroup." + (gnus-subscribe-newsgroup newsgroup)) + +(defun gnus-subscribe-alphabetically (newgroup) + "Subscribe new NEWSGROUP and insert it in alphabetical order." + (let ((groups (cdr gnus-newsrc-alist)) + before) + (while (and (not before) groups) + (if (string< newgroup (caar groups)) + (setq before (caar groups)) + (setq groups (cdr groups)))) + (gnus-subscribe-newsgroup newgroup before))) + +(defun gnus-subscribe-hierarchically (newgroup) + "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order." + ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) + (save-excursion + (set-buffer (nnheader-find-file-noselect gnus-current-startup-file)) + (let ((groupkey newgroup) + before) + (while (and (not before) groupkey) + (goto-char (point-min)) + (let ((groupkey-re + (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]"))) + (while (and (re-search-forward groupkey-re nil t) + (progn + (setq before (match-string 1)) + (string< before newgroup))))) + ;; Remove tail of newsgroup name (eg. a.b.c -> a.b) + (setq groupkey + (when (string-match "^\\(.*\\)\\.[^.]+$" groupkey) + (substring groupkey (match-beginning 1) (match-end 1))))) + (gnus-subscribe-newsgroup newgroup before)) + (kill-buffer (current-buffer)))) + +(defun gnus-subscribe-interactively (group) + "Subscribe the new GROUP interactively. +It is inserted in hierarchical newsgroup order if subscribed. If not, +it is killed." + (if (gnus-y-or-n-p (format "Subscribe new newsgroup: %s " group)) + (gnus-subscribe-hierarchically group) + (push group gnus-killed-list))) + +(defun gnus-subscribe-zombies (group) + "Make the new GROUP into a zombie group." + (push group gnus-zombie-list)) + +(defun gnus-subscribe-killed (group) + "Make the new GROUP a killed group." + (push group gnus-killed-list)) + +(defun gnus-subscribe-newsgroup (newsgroup &optional next) + "Subscribe new NEWSGROUP. +If NEXT is non-nil, it is inserted before NEXT. Otherwise it is made +the first newsgroup." + (save-excursion + (goto-char (point-min)) + ;; We subscribe the group by changing its level to `subscribed'. + (gnus-group-change-level + newsgroup gnus-level-default-subscribed + gnus-level-killed (gnus-gethash (or next "dummy.group") + gnus-newsrc-hashtb)) + (gnus-message 5 "Subscribe newsgroup: %s" newsgroup))) + +(defun gnus-read-active-file-p () + "Say whether the active file has been read from `gnus-select-method'." + (memq gnus-select-method gnus-have-read-active-file)) + +;;; General various misc type functions. + +;; Silence byte-compiler. +(defvar gnus-current-headers) +(defvar gnus-thread-indent-array) +(defvar gnus-newsgroup-name) +(defvar gnus-newsgroup-headers) +(defvar gnus-group-list-mode) +(defvar gnus-group-mark-positions) +(defvar gnus-newsgroup-data) +(defvar gnus-newsgroup-unreads) +(defvar nnoo-state-alist) +(defvar gnus-current-select-method) +(defun gnus-clear-system () + "Clear all variables and buffers." + ;; Clear Gnus variables. + (let ((variables gnus-variable-list)) + (while variables + (set (car variables) nil) + (setq variables (cdr variables)))) + ;; Clear other internal variables. + (setq gnus-list-of-killed-groups nil + gnus-have-read-active-file nil + gnus-newsrc-alist nil + gnus-newsrc-hashtb nil + gnus-killed-list nil + gnus-zombie-list nil + gnus-killed-hashtb nil + gnus-active-hashtb nil + gnus-moderated-hashtb nil + gnus-description-hashtb nil + gnus-current-headers nil + gnus-thread-indent-array nil + gnus-newsgroup-headers nil + gnus-newsgroup-name nil + gnus-server-alist nil + gnus-group-list-mode nil + gnus-opened-servers nil + gnus-group-mark-positions nil + gnus-newsgroup-data nil + gnus-newsgroup-unreads nil + nnoo-state-alist nil + gnus-current-select-method nil) + (gnus-shutdown 'gnus) + ;; Kill the startup file. + (and gnus-current-startup-file + (get-file-buffer gnus-current-startup-file) + (kill-buffer (get-file-buffer gnus-current-startup-file))) + ;; Clear the dribble buffer. + (gnus-dribble-clear) + ;; Kill global KILL file buffer. + (when (get-file-buffer (gnus-newsgroup-kill-file nil)) + (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) + (gnus-kill-buffer nntp-server-buffer) + ;; Kill Gnus buffers. + (while gnus-buffer-list + (gnus-kill-buffer (pop gnus-buffer-list))) + ;; Remove Gnus frames. + (gnus-kill-gnus-frames)) + +(defun gnus-no-server-1 (&optional arg slave) + "Read network news. +If ARG is a positive number, Gnus will use that as the +startup level. If ARG is nil, Gnus will be started at level 2. +If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local server." + (interactive "P") + (let ((val (or arg (1- gnus-level-default-subscribed)))) + (gnus val t slave) + (make-local-variable 'gnus-group-use-permanent-levels) + (setq gnus-group-use-permanent-levels val))) + +(defun gnus-1 (&optional arg dont-connect slave) + "Read network news. +If ARG is non-nil and a positive number, Gnus will use that as the +startup level. If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use." + (interactive "P") + + (if (and (get-buffer gnus-group-buffer) + (save-excursion + (set-buffer gnus-group-buffer) + (eq major-mode 'gnus-group-mode))) + (progn + (switch-to-buffer gnus-group-buffer) + (gnus-group-get-new-news + (and (numberp arg) + (> arg 0) + (max (car gnus-group-list-mode) arg)))) + + (gnus-splash) + (gnus-clear-system) + (run-hooks 'gnus-before-startup-hook) + (nnheader-init-server-buffer) + (setq gnus-slave slave) + (gnus-read-init-file) + + (when gnus-simple-splash + (setq gnus-simple-splash nil) + (cond + (gnus-xemacs + (gnus-xmas-splash)) + ((and (eq window-system 'x) + (= (frame-height) (1+ (window-height)))) + (gnus-x-splash)))) + + (let ((level (and (numberp arg) (> arg 0) arg)) + did-connect) + (unwind-protect + (progn + (unless dont-connect + (setq did-connect + (gnus-start-news-server (and arg (not level)))))) + (if (and (not dont-connect) + (not did-connect)) + (gnus-group-quit) + (run-hooks 'gnus-startup-hook) + ;; NNTP server is successfully open. + + ;; Find the current startup file name. + (setq gnus-current-startup-file + (gnus-make-newsrc-file gnus-startup-file)) + + ;; Read the dribble file. + (when (or gnus-slave gnus-use-dribble-file) + (gnus-dribble-read-file)) + + ;; Allow using GroupLens predictions. + (when gnus-use-grouplens + (bbb-login) + (add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode)) + + ;; Do the actual startup. + (gnus-setup-news nil level dont-connect) + (run-hooks 'gnus-setup-news-hook) + (gnus-start-draft-setup) + ;; Generate the group buffer. + (gnus-group-list-groups level) + (gnus-group-first-unread-group) + (gnus-configure-windows 'group) + (gnus-group-set-mode-line) + (run-hooks 'gnus-started-hook)))))) + +(defun gnus-start-draft-setup () + "Make sure the draft group exists." + (unless (gnus-gethash "nndraft:drafts" gnus-newsrc-hashtb) + (gnus-request-create-group "drafts" '(nndraft "")) + (let ((gnus-level-default-subscribed 1)) + (gnus-subscribe-group "nndraft:drafts" nil '(nndraft ""))) + (gnus-group-set-parameter + "nndraft:drafts" 'gnus-dummy '((gnus-draft-mode))))) + +;;;###autoload +(defun gnus-unload () + "Unload all Gnus features." + (interactive) + (unless (boundp 'load-history) + (error "Sorry, `gnus-unload' is not implemented in this Emacs version")) + (let ((history load-history) + feature) + (while history + (and (string-match "^\\(gnus\\|nn\\)" (caar history)) + (setq feature (cdr (assq 'provide (car history)))) + (unload-feature feature 'force)) + (setq history (cdr history))))) + + +;;; +;;; Dribble file +;;; + +(defvar gnus-dribble-ignore nil) +(defvar gnus-dribble-eval-file nil) + +(defun gnus-dribble-file-name () + "Return the dribble file for the current .newsrc." + (concat + (if gnus-dribble-directory + (concat (file-name-as-directory gnus-dribble-directory) + (file-name-nondirectory gnus-current-startup-file)) + gnus-current-startup-file) + "-dribble")) + +(defun gnus-dribble-enter (string) + "Enter STRING into the dribble buffer." + (when (and (not gnus-dribble-ignore) + gnus-dribble-buffer + (buffer-name gnus-dribble-buffer)) + (let ((obuf (current-buffer))) + (set-buffer gnus-dribble-buffer) + (goto-char (point-max)) + (insert string "\n") + (set-window-point (get-buffer-window (current-buffer)) (point-max)) + (bury-buffer gnus-dribble-buffer) + (set-buffer obuf)))) + +(defun gnus-dribble-touch () + "Touch the dribble buffer." + (gnus-dribble-enter "")) + +(defun gnus-dribble-read-file () + "Read the dribble file from disk." + (let ((dribble-file (gnus-dribble-file-name))) + (save-excursion + (set-buffer (setq gnus-dribble-buffer + (get-buffer-create + (file-name-nondirectory dribble-file)))) + (gnus-add-current-to-buffer-list) + (erase-buffer) + (setq buffer-file-name dribble-file) + (auto-save-mode t) + (buffer-disable-undo (current-buffer)) + (bury-buffer (current-buffer)) + (set-buffer-modified-p nil) + (let ((auto (make-auto-save-file-name)) + (gnus-dribble-ignore t) + modes) + (when (or (file-exists-p auto) (file-exists-p dribble-file)) + ;; Load whichever file is newest -- the auto save file + ;; or the "real" file. + (if (file-newer-than-file-p auto dribble-file) + (nnheader-insert-file-contents auto) + (nnheader-insert-file-contents dribble-file)) + (unless (zerop (buffer-size)) + (set-buffer-modified-p t)) + ;; Set the file modes to reflect the .newsrc file modes. + (save-buffer) + (when (and (file-exists-p gnus-current-startup-file) + (file-exists-p dribble-file) + (setq modes (file-modes gnus-current-startup-file))) + (set-file-modes dribble-file modes)) + ;; Possibly eval the file later. + (when (gnus-y-or-n-p + "Gnus auto-save file exists. Do you want to read it? ") + (setq gnus-dribble-eval-file t))))))) + +(defun gnus-dribble-eval-file () + (when gnus-dribble-eval-file + (setq gnus-dribble-eval-file nil) + (save-excursion + (let ((gnus-dribble-ignore t)) + (set-buffer gnus-dribble-buffer) + (eval-buffer (current-buffer)))))) + +(defun gnus-dribble-delete-file () + (when (file-exists-p (gnus-dribble-file-name)) + (delete-file (gnus-dribble-file-name))) + (when gnus-dribble-buffer + (save-excursion + (set-buffer gnus-dribble-buffer) + (let ((auto (make-auto-save-file-name))) + (when (file-exists-p auto) + (delete-file auto)) + (erase-buffer) + (set-buffer-modified-p nil))))) + +(defun gnus-dribble-save () + (when (and gnus-dribble-buffer + (buffer-name gnus-dribble-buffer)) + (save-excursion + (set-buffer gnus-dribble-buffer) + (save-buffer)))) + +(defun gnus-dribble-clear () + (when (gnus-buffer-exists-p gnus-dribble-buffer) + (save-excursion + (set-buffer gnus-dribble-buffer) + (erase-buffer) + (set-buffer-modified-p nil) + (setq buffer-saved-size (buffer-size))))) + + +;;; +;;; Active & Newsrc File Handling +;;; + +(defun gnus-setup-news (&optional rawfile level dont-connect) + "Setup news information. +If RAWFILE is non-nil, the .newsrc file will also be read. +If LEVEL is non-nil, the news will be set up at level LEVEL." + (let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile))))) + + (when init + ;; Clear some variables to re-initialize news information. + (setq gnus-newsrc-alist nil + gnus-active-hashtb nil) + ;; Read the newsrc file and create `gnus-newsrc-hashtb'. + (gnus-read-newsrc-file rawfile)) + + (when (and (not (assoc "archive" gnus-server-alist)) + (gnus-archive-server-wanted-p)) + (push (cons "archive" gnus-message-archive-method) + gnus-server-alist)) + + ;; If we don't read the complete active file, we fill in the + ;; hashtb here. + (when (or (null gnus-read-active-file) + (eq gnus-read-active-file 'some)) + (gnus-update-active-hashtb-from-killed)) + + ;; Read the active file and create `gnus-active-hashtb'. + ;; If `gnus-read-active-file' is nil, then we just create an empty + ;; hash table. The partial filling out of the hash table will be + ;; done in `gnus-get-unread-articles'. + (and gnus-read-active-file + (not level) + (gnus-read-active-file nil dont-connect)) + + (unless gnus-active-hashtb + (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + + ;; Initialize the cache. + (when gnus-use-cache + (gnus-cache-open)) + + ;; Possibly eval the dribble file. + (and init + (or gnus-use-dribble-file gnus-slave) + (gnus-dribble-eval-file)) + + ;; Slave Gnusii should then clear the dribble buffer. + (when (and init gnus-slave) + (gnus-dribble-clear)) + + (gnus-update-format-specifications) + + ;; See whether we need to read the description file. + (when (and (boundp 'gnus-group-line-format) + (let ((case-fold-search nil)) + (string-match "%[-,0-9]*D" gnus-group-line-format)) + (not gnus-description-hashtb) + (not dont-connect) + gnus-read-active-file) + (gnus-read-all-descriptions-files)) + + ;; Find new newsgroups and treat them. + (when (and init gnus-check-new-newsgroups (not level) + (gnus-check-server gnus-select-method) + (not gnus-slave)) + (gnus-find-new-newsgroups)) + + ;; We might read in new NoCeM messages here. + (when (and gnus-use-nocem + (not level) + (not dont-connect)) + (gnus-nocem-scan-groups)) + + ;; Read any slave files. + (gnus-master-read-slave-newsrc) + + ;; Find the number of unread articles in each non-dead group. + (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) + (gnus-get-unread-articles level)) + + (when (and init gnus-check-bogus-newsgroups + gnus-read-active-file (not level) + (gnus-server-opened gnus-select-method)) + (gnus-check-bogus-newsgroups)))) + +(defun gnus-find-new-newsgroups (&optional arg) + "Search for new newsgroups and add them. +Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' +The `-n' option line from .newsrc is respected. +If ARG (the prefix), use the `ask-server' method to query the server +for new groups." + (interactive "P") + (let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups))) + (null gnus-read-active-file) + (eq gnus-read-active-file 'some)) + 'ask-server gnus-check-new-newsgroups))) + (unless (gnus-check-first-time-used) + (if (or (consp check) + (eq check 'ask-server)) + ;; Ask the server for new groups. + (gnus-ask-server-for-new-groups) + ;; Go through the active hashtb and look for new groups. + (let ((groups 0) + group new-newsgroups) + (gnus-message 5 "Looking for new newsgroups...") + (unless gnus-have-read-active-file + (gnus-read-active-file)) + (setq gnus-newsrc-last-checked-date (current-time-string)) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + ;; Go though every newsgroup in `gnus-active-hashtb' and compare + ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. + (mapatoms + (lambda (sym) + (if (or (null (setq group (symbol-name sym))) + (not (boundp sym)) + (null (symbol-value sym)) + (gnus-gethash group gnus-killed-hashtb) + (gnus-gethash group gnus-newsrc-hashtb)) + () + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (funcall gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (if gnus-subscribe-hierarchical-interactive + (push group new-newsgroups) + (funcall gnus-subscribe-newsgroup-method group))))))) + gnus-active-hashtb) + (when new-newsgroups + (gnus-subscribe-hierarchical-interactive new-newsgroups)) + (if (> groups 0) + (gnus-message 5 "%d new newsgroup%s arrived." + groups (if (> groups 1) "s have" " has")) + (gnus-message 5 "No new newsgroups."))))))) + +(defun gnus-matches-options-n (group) + ;; Returns `subscribe' if the group is to be unconditionally + ;; subscribed, `ignore' if it is to be ignored, and nil if there is + ;; no match for the group. + + ;; First we check the two user variables. + (cond + ((and gnus-options-subscribe + (string-match gnus-options-subscribe group)) + 'subscribe) + ((and gnus-auto-subscribed-groups + (string-match gnus-auto-subscribed-groups group)) + 'subscribe) + ((and gnus-options-not-subscribe + (string-match gnus-options-not-subscribe group)) + 'ignore) + ;; Then we go through the list that was retrieved from the .newsrc + ;; file. This list has elements on the form + ;; `(REGEXP . {ignore,subscribe})'. The first match found (the list + ;; is in the reverse order of the options line) is returned. + (t + (let ((regs gnus-newsrc-options-n)) + (while (and regs + (not (string-match (caar regs) group))) + (setq regs (cdr regs))) + (and regs (cdar regs)))))) + +(defun gnus-ask-server-for-new-groups () + (let* ((date (or gnus-newsrc-last-checked-date (current-time-string))) + (methods (cons gnus-select-method + (nconc + (when (gnus-archive-server-wanted-p) + (list "archive")) + (append + (and (consp gnus-check-new-newsgroups) + gnus-check-new-newsgroups) + gnus-secondary-select-methods)))) + (groups 0) + (new-date (current-time-string)) + group new-newsgroups got-new method hashtb + gnus-override-subscribe-method) + ;; Go through both primary and secondary select methods and + ;; request new newsgroups. + (while (setq method (gnus-server-get-method nil (pop methods))) + (setq new-newsgroups nil) + (setq gnus-override-subscribe-method method) + (when (and (gnus-check-server method) + (gnus-request-newgroups date method)) + (save-excursion + (setq got-new t) + (setq hashtb (gnus-make-hashtable 100)) + (set-buffer nntp-server-buffer) + ;; Enter all the new groups into a hashtable. + (gnus-active-to-gnus-format method hashtb 'ignore)) + ;; Now all new groups from `method' are in `hashtb'. + (mapatoms + (lambda (group-sym) + (if (or (null (setq group (symbol-name group-sym))) + (not (boundp group-sym)) + (null (symbol-value group-sym)) + (gnus-gethash group gnus-newsrc-hashtb) + (member group gnus-zombie-list) + (member group gnus-killed-list)) + ;; The group is already known. + () + ;; Make this group active. + (when (symbol-value group-sym) + (gnus-set-active group (symbol-value group-sym))) + ;; Check whether we want it or not. + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (incf groups) + (gnus-sethash group group gnus-killed-hashtb) + (funcall gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (incf groups) + (gnus-sethash group group gnus-killed-hashtb) + (if gnus-subscribe-hierarchical-interactive + (push group new-newsgroups) + (funcall gnus-subscribe-newsgroup-method group))))))) + hashtb)) + (when new-newsgroups + (gnus-subscribe-hierarchical-interactive new-newsgroups))) + ;; Suggested by Per Abrahamsen . + (when (> groups 0) + (gnus-message 6 "%d new newsgroup%s arrived." + groups (if (> groups 1) "s have" " has"))) + (when got-new + (setq gnus-newsrc-last-checked-date new-date)) + got-new)) + +(defun gnus-check-first-time-used () + (if (or (> (length gnus-newsrc-alist) 1) + (file-exists-p gnus-startup-file) + (file-exists-p (concat gnus-startup-file ".el")) + (file-exists-p (concat gnus-startup-file ".eld"))) + nil + (gnus-message 6 "First time user; subscribing you to default groups") + (unless (gnus-read-active-file-p) + (let ((gnus-read-active-file t)) + (gnus-read-active-file))) + (setq gnus-newsrc-last-checked-date (current-time-string)) + (let ((groups gnus-default-subscribed-newsgroups) + group) + (if (eq groups t) + nil + (setq groups (or groups gnus-backup-default-subscribed-newsgroups)) + (mapatoms + (lambda (sym) + (if (null (setq group (symbol-name sym))) + () + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (gnus-sethash group group gnus-killed-hashtb) + (funcall gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (push group gnus-killed-list)))))) + gnus-active-hashtb) + (while groups + (when (gnus-active (car groups)) + (gnus-group-change-level + (car groups) gnus-level-default-subscribed gnus-level-killed)) + (setq groups (cdr groups))) + (gnus-group-make-help-group) + (when gnus-novice-user + (gnus-message 7 "`A k' to list killed groups")))))) + +(defun gnus-subscribe-group (group previous &optional method) + (gnus-group-change-level + (if method + (list t group gnus-level-default-subscribed nil nil method) + group) + gnus-level-default-subscribed gnus-level-killed previous t)) + +;; `gnus-group-change-level' is the fundamental function for changing +;; subscription levels of newsgroups. This might mean just changing +;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back +;; again, which subscribes/unsubscribes a group, which is equally +;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and +;; from 8-9 to 1-7 means that you remove the group from the list of +;; killed (or zombie) groups and add them to the (kinda) subscribed +;; groups. And last but not least, moving from 8 to 9 and 9 to 8, +;; which is trivial. +;; ENTRY can either be a string (newsgroup name) or a list (if +;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST), +;; otherwise it's a list in the format of the `gnus-newsrc-hashtb' +;; entries. +;; LEVEL is the new level of the group, OLDLEVEL is the old level and +;; PREVIOUS is the group (in hashtb entry format) to insert this group +;; after. +(defun gnus-group-change-level (entry level &optional oldlevel + previous fromkilled) + (let (group info active num) + ;; Glean what info we can from the arguments + (if (consp entry) + (if fromkilled (setq group (nth 1 entry)) + (setq group (car (nth 2 entry)))) + (setq group entry)) + (when (and (stringp entry) + oldlevel + (< oldlevel gnus-level-zombie)) + (setq entry (gnus-gethash entry gnus-newsrc-hashtb))) + (if (and (not oldlevel) + (consp entry)) + (setq oldlevel (gnus-info-level (nth 2 entry))) + (setq oldlevel (or oldlevel 9))) + (when (stringp previous) + (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) + + (if (and (>= oldlevel gnus-level-zombie) + (gnus-gethash group gnus-newsrc-hashtb)) + ;; We are trying to subscribe a group that is already + ;; subscribed. + () ; Do nothing. + + (unless (gnus-ephemeral-group-p group) + (gnus-dribble-enter + (format "(gnus-group-change-level %S %S %S %S %S)" + group level oldlevel (car (nth 2 previous)) fromkilled))) + + ;; Then we remove the newgroup from any old structures, if needed. + ;; If the group was killed, we remove it from the killed or zombie + ;; list. If not, and it is in fact going to be killed, we remove + ;; it from the newsrc hash table and assoc. + (cond + ((>= oldlevel gnus-level-zombie) + (if (= oldlevel gnus-level-zombie) + (setq gnus-zombie-list (delete group gnus-zombie-list)) + (setq gnus-killed-list (delete group gnus-killed-list)))) + (t + (when (and (>= level gnus-level-zombie) + entry) + (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) + (when (nth 3 entry) + (setcdr (gnus-gethash (car (nth 3 entry)) + gnus-newsrc-hashtb) + (cdr entry))) + (setcdr (cdr entry) (cdddr entry))))) + + ;; Finally we enter (if needed) the list where it is supposed to + ;; go, and change the subscription level. If it is to be killed, + ;; we enter it into the killed or zombie list. + (cond + ((>= level gnus-level-zombie) + ;; Remove from the hash table. + (gnus-sethash group nil gnus-newsrc-hashtb) + ;; We do not enter foreign groups into the list of dead + ;; groups. + (unless (gnus-group-foreign-p group) + (if (= level gnus-level-zombie) + (push group gnus-zombie-list) + (push group gnus-killed-list)))) + (t + ;; If the list is to be entered into the newsrc assoc, and + ;; it was killed, we have to create an entry in the newsrc + ;; hashtb format and fix the pointers in the newsrc assoc. + (if (< oldlevel gnus-level-zombie) + ;; It was alive, and it is going to stay alive, so we + ;; just change the level and don't change any pointers or + ;; hash table entries. + (setcar (cdaddr entry) level) + (if (listp entry) + (setq info (cdr entry) + num (car entry)) + (setq active (gnus-active group)) + (setq num + (if active (- (1+ (cdr active)) (car active)) t)) + ;; Check whether the group is foreign. If so, the + ;; foreign select method has to be entered into the + ;; info. + (let ((method (or gnus-override-subscribe-method + (gnus-group-method group)))) + (if (eq method gnus-select-method) + (setq info (list group level nil)) + (setq info (list group level nil nil method))))) + (unless previous + (setq previous + (let ((p gnus-newsrc-alist)) + (while (cddr p) + (setq p (cdr p))) + p))) + (setq entry (cons info (cddr previous))) + (if (cdr previous) + (progn + (setcdr (cdr previous) entry) + (gnus-sethash group (cons num (cdr previous)) + gnus-newsrc-hashtb)) + (setcdr previous entry) + (gnus-sethash group (cons num previous) + gnus-newsrc-hashtb)) + (when (cdr entry) + (setcdr (gnus-gethash (caadr entry) gnus-newsrc-hashtb) entry)) + (gnus-dribble-enter + (format + "(gnus-group-set-info '%S)" info))))) + (when gnus-group-change-level-function + (funcall gnus-group-change-level-function + group level oldlevel previous))))) + +(defun gnus-kill-newsgroup (newsgroup) + "Obsolete function. Kills a newsgroup." + (gnus-group-change-level + (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed)) + +(defun gnus-check-bogus-newsgroups (&optional confirm) + "Remove bogus newsgroups. +If CONFIRM is non-nil, the user has to confirm the deletion of every +newsgroup." + (let ((newsrc (cdr gnus-newsrc-alist)) + bogus group entry info) + (gnus-message 5 "Checking bogus newsgroups...") + (unless (gnus-read-active-file-p) + (gnus-read-active-file t)) + (when (gnus-read-active-file-p) + ;; Find all bogus newsgroup that are subscribed. + (while newsrc + (setq info (pop newsrc) + group (gnus-info-group info)) + (unless (or (gnus-active group) ; Active + (gnus-info-method info)) ; Foreign + ;; Found a bogus newsgroup. + (push group bogus))) + (if confirm + (map-y-or-n-p + "Remove bogus group %s? " + (lambda (group) + ;; Remove all bogus subscribed groups by first killing them, and + ;; then removing them from the list of killed groups. + (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-change-level entry gnus-level-killed) + (setq gnus-killed-list (delete group gnus-killed-list)))) + bogus '("group" "groups" "remove")) + (while (setq group (pop bogus)) + ;; Remove all bogus subscribed groups by first killing them, and + ;; then removing them from the list of killed groups. + (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-change-level entry gnus-level-killed) + (setq gnus-killed-list (delete group gnus-killed-list))))) + ;; Then we remove all bogus groups from the list of killed and + ;; zombie groups. They are removed without confirmation. + (let ((dead-lists '(gnus-killed-list gnus-zombie-list)) + killed) + (while dead-lists + (setq killed (symbol-value (car dead-lists))) + (while killed + (unless (gnus-active (setq group (pop killed))) + ;; The group is bogus. + ;; !!!Slow as hell. + (set (car dead-lists) + (delete group (symbol-value (car dead-lists)))))) + (setq dead-lists (cdr dead-lists)))) + (run-hooks 'gnus-check-bogus-groups-hook) + (gnus-message 5 "Checking bogus newsgroups...done")))) + +(defun gnus-check-duplicate-killed-groups () + "Remove duplicates from the list of killed groups." + (interactive) + (let ((killed gnus-killed-list)) + (while killed + (gnus-message 9 "%d" (length killed)) + (setcdr killed (delete (car killed) (cdr killed))) + (setq killed (cdr killed))))) + +;; We want to inline a function from gnus-cache, so we cheat here: +(eval-when-compile + (defvar gnus-cache-active-hashtb) + (defun gnus-cache-possibly-alter-active (group active) + "Alter the ACTIVE info for GROUP to reflect the articles in the cache." + (when gnus-cache-active-hashtb + (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (when cache-active + (when (< (car cache-active) (car active)) + (setcar active (car cache-active))) + (when (> (cdr cache-active) (cdr active)) + (setcdr active (cdr cache-active)))))))) + +(defun gnus-activate-group (group &optional scan dont-check method) + ;; Check whether a group has been activated or not. + ;; If SCAN, request a scan of that group as well. + (let ((method (or method (inline (gnus-find-method-for-group group)))) + active) + (and (inline (gnus-check-server method)) + ;; We escape all bugs and quit here to make it possible to + ;; continue if a group is so out-there that it reports bugs + ;; and stuff. + (progn + (and scan + (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan group method)) + t) + (condition-case () + (inline (gnus-request-group group dont-check method)) + (error nil) + (quit nil)) + (setq active (gnus-parse-active)) + ;; If there are no articles in the group, the GROUP + ;; command may have responded with the `(0 . 0)'. We + ;; ignore this if we already have an active entry + ;; for the group. + (if (and (zerop (car active)) + (zerop (cdr active)) + (gnus-active group)) + (gnus-active group) + (gnus-set-active group active) + ;; Return the new active info. + active)))) + +(defun gnus-get-unread-articles-in-group (info active &optional update) + (when active + ;; Allow the backend to update the info in the group. + (when (and update + (gnus-request-update-info + info (inline (gnus-find-method-for-group + (gnus-info-group info))))) + (gnus-activate-group (gnus-info-group info) nil t)) + (let* ((range (gnus-info-read info)) + (num 0)) + ;; If a cache is present, we may have to alter the active info. + (when (and gnus-use-cache info) + (inline (gnus-cache-possibly-alter-active + (gnus-info-group info) active))) + ;; Modify the list of read articles according to what articles + ;; are available; then tally the unread articles and add the + ;; number to the group hash table entry. + (cond + ((zerop (cdr active)) + (setq num 0)) + ((not range) + (setq num (- (1+ (cdr active)) (car active)))) + ((not (listp (cdr range))) + ;; Fix a single (num . num) range according to the + ;; active hash table. + ;; Fix by Carsten Bormann . + (and (< (cdr range) (car active)) (setcdr range (1- (car active)))) + (and (> (cdr range) (cdr active)) (setcdr range (cdr active))) + ;; Compute number of unread articles. + (setq num (max 0 (- (cdr active) (- (1+ (cdr range)) (car range)))))) + (t + ;; The read list is a list of ranges. Fix them according to + ;; the active hash table. + ;; First peel off any elements that are below the lower + ;; active limit. + (while (and (cdr range) + (>= (car active) + (or (and (atom (cadr range)) (cadr range)) + (caadr range)))) + (if (numberp (car range)) + (setcar range + (cons (car range) + (or (and (numberp (cadr range)) + (cadr range)) + (cdadr range)))) + (setcdr (car range) + (or (and (numberp (nth 1 range)) (nth 1 range)) + (cdadr range)))) + (setcdr range (cddr range))) + ;; Adjust the first element to be the same as the lower limit. + (when (and (not (atom (car range))) + (< (cdar range) (car active))) + (setcdr (car range) (1- (car active)))) + ;; Then we want to peel off any elements that are higher + ;; than the upper active limit. + (let ((srange range)) + ;; Go past all legal elements. + (while (and (cdr srange) + (<= (or (and (atom (cadr srange)) + (cadr srange)) + (caadr srange)) + (cdr active))) + (setq srange (cdr srange))) + (when (cdr srange) + ;; Nuke all remaining illegal elements. + (setcdr srange nil)) + + ;; Adjust the final element. + (when (and (not (atom (car srange))) + (> (cdar srange) (cdr active))) + (setcdr (car srange) (cdr active)))) + ;; Compute the number of unread articles. + (while range + (setq num (+ num (- (1+ (or (and (atom (car range)) (car range)) + (cdar range))) + (or (and (atom (car range)) (car range)) + (caar range))))) + (setq range (cdr range))) + (setq num (max 0 (- (cdr active) num))))) + ;; Set the number of unread articles. + (when info + (setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num)) + num))) + +;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' +;; and compute how many unread articles there are in each group. +(defun gnus-get-unread-articles (&optional level) + (let* ((newsrc (cdr gnus-newsrc-alist)) + (level (or level gnus-activate-level (1+ gnus-level-subscribed))) + (foreign-level + (min + (cond ((and gnus-activate-foreign-newsgroups + (not (numberp gnus-activate-foreign-newsgroups))) + (1+ gnus-level-subscribed)) + ((numberp gnus-activate-foreign-newsgroups) + gnus-activate-foreign-newsgroups) + (t 0)) + level)) + info group active method) + (gnus-message 5 "Checking new news...") + + (while newsrc + (setq active (gnus-active (setq group (gnus-info-group + (setq info (pop newsrc)))))) + + ;; Check newsgroups. If the user doesn't want to check them, or + ;; they can't be checked (for instance, if the news server can't + ;; be reached) we just set the number of unread articles in this + ;; newsgroup to t. This means that Gnus thinks that there are + ;; unread articles, but it has no idea how many. + (if (and (setq method (gnus-info-method info)) + (not (inline + (gnus-server-equal + gnus-select-method + (setq method (gnus-server-get-method nil method))))) + (not (gnus-secondary-method-p method))) + ;; These groups are foreign. Check the level. + (when (<= (gnus-info-level info) foreign-level) + (setq active (gnus-activate-group group 'scan)) + (unless (inline (gnus-virtual-group-p group)) + (inline (gnus-close-group group))) + (when (fboundp (intern (concat (symbol-name (car method)) + "-request-update-info"))) + (inline (gnus-request-update-info info method)))) + ;; These groups are native or secondary. + (when (and (<= (gnus-info-level info) level) + (not gnus-read-active-file)) + (setq active (gnus-activate-group group 'scan)) + (inline (gnus-close-group group)))) + + ;; Get the number of unread articles in the group. + (if active + (inline (gnus-get-unread-articles-in-group info active t)) + ;; The group couldn't be reached, so we nix out the number of + ;; unread articles and stuff. + (gnus-set-active group nil) + (setcar (gnus-gethash group gnus-newsrc-hashtb) t))) + + (gnus-message 5 "Checking new news...done"))) + +;; Create a hash table out of the newsrc alist. The `car's of the +;; alist elements are used as keys. +(defun gnus-make-hashtable-from-newsrc-alist () + (let ((alist gnus-newsrc-alist) + (ohashtb gnus-newsrc-hashtb) + prev) + (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) + (setq alist + (setq prev (setq gnus-newsrc-alist + (if (equal (caar gnus-newsrc-alist) + "dummy.group") + gnus-newsrc-alist + (cons (list "dummy.group" 0 nil) alist))))) + (while alist + (gnus-sethash + (caar alist) + ;; Preserve number of unread articles in groups. + (cons (and ohashtb (car (gnus-gethash (caar alist) ohashtb))) + prev) + gnus-newsrc-hashtb) + (setq prev alist + alist (cdr alist))))) + +(defun gnus-make-hashtable-from-killed () + "Create a hash table from the killed and zombie lists." + (let ((lists '(gnus-killed-list gnus-zombie-list)) + list) + (setq gnus-killed-hashtb + (gnus-make-hashtable + (+ (length gnus-killed-list) (length gnus-zombie-list)))) + (while lists + (setq list (symbol-value (pop lists))) + (while list + (gnus-sethash (car list) (pop list) gnus-killed-hashtb))))) + +(defun gnus-parse-active () + "Parse active info in the nntp server buffer." + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + ;; Parse the result we got from `gnus-request-group'. + (when (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+") + (goto-char (match-beginning 1)) + (cons (read (current-buffer)) + (read (current-buffer)))))) + +(defun gnus-make-articles-unread (group articles) + "Mark ARTICLES in GROUP as unread." + (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb) + (gnus-gethash (gnus-group-real-name group) + gnus-newsrc-hashtb)))) + (ranges (gnus-info-read info)) + news article) + (while articles + (when (gnus-member-of-range + (setq article (pop articles)) ranges) + (push article news))) + (when news + (gnus-info-set-read + info (gnus-remove-from-range (gnus-info-read info) (nreverse news))) + (gnus-group-update-group group t)))) + +;; Enter all dead groups into the hashtb. +(defun gnus-update-active-hashtb-from-killed () + (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + (lists (list gnus-killed-list gnus-zombie-list)) + killed) + (while lists + (setq killed (car lists)) + (while killed + (gnus-sethash (car killed) nil hashtb) + (setq killed (cdr killed))) + (setq lists (cdr lists))))) + +(defun gnus-get-killed-groups () + "Go through the active hashtb and mark all unknown groups as killed." + ;; First make sure active file has been read. + (unless (gnus-read-active-file-p) + (let ((gnus-read-active-file t)) + (gnus-read-active-file))) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + ;; Go through all newsgroups that are known to Gnus - enlarge kill list. + (mapatoms + (lambda (sym) + (let ((groups 0) + (group (symbol-name sym))) + (if (or (null group) + (gnus-gethash group gnus-killed-hashtb) + (gnus-gethash group gnus-newsrc-hashtb)) + () + (let ((do-sub (gnus-matches-options-n group))) + (if (or (eq do-sub 'subscribe) (eq do-sub 'ignore)) + () + (setq groups (1+ groups)) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb)))))) + gnus-active-hashtb) + (gnus-dribble-touch)) + +;; Get the active file(s) from the backend(s). +(defun gnus-read-active-file (&optional force not-native) + (gnus-group-set-mode-line) + (let ((methods + (append + (if (and (not not-native) + (gnus-check-server gnus-select-method)) + ;; The native server is available. + (cons gnus-select-method gnus-secondary-select-methods) + ;; The native server is down, so we just do the + ;; secondary ones. + gnus-secondary-select-methods) + ;; Also read from the archive server. + (when (gnus-archive-server-wanted-p) + (list "archive")))) + list-type) + (setq gnus-have-read-active-file nil) + (save-excursion + (set-buffer nntp-server-buffer) + (while methods + (let* ((method (if (stringp (car methods)) + (gnus-server-get-method nil (car methods)) + (car methods))) + (where (nth 1 method)) + (mesg (format "Reading active file%s via %s..." + (if (and where (not (zerop (length where)))) + (concat " from " where) "") + (car method)))) + (gnus-message 5 mesg) + (when (gnus-check-server method) + ;; Request that the backend scan its incoming messages. + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + (cond + ((and (eq gnus-read-active-file 'some) + (gnus-check-backend-function 'retrieve-groups (car method)) + (not force)) + (let ((newsrc (cdr gnus-newsrc-alist)) + (gmethod (gnus-server-get-method nil method)) + groups info) + (while (setq info (pop newsrc)) + (when (inline + (gnus-server-equal + (inline + (gnus-find-method-for-group + (gnus-info-group info) info)) + gmethod)) + (push (gnus-group-real-name (gnus-info-group info)) + groups))) + (when groups + (gnus-check-server method) + (setq list-type (gnus-retrieve-groups groups method)) + (cond + ((not list-type) + (gnus-error + 1.2 "Cannot read partial active file from %s server." + (car method))) + ((eq list-type 'active) + (gnus-active-to-gnus-format + method gnus-active-hashtb nil t)) + (t + (gnus-groups-to-gnus-format + method gnus-active-hashtb t)))))) + ((null method) + t) + (t + (if (not (gnus-request-list method)) + (unless (equal method gnus-message-archive-method) + (gnus-error 1 "Cannot read active file from %s server" + (car method))) + (gnus-message 5 mesg) + (gnus-active-to-gnus-format method gnus-active-hashtb nil t) + ;; We mark this active file as read. + (push method gnus-have-read-active-file) + (gnus-message 5 "%sdone" mesg)))))) + (setq methods (cdr methods)))))) + + +(defun gnus-ignored-newsgroups-has-to-p () + "T only when gnus-ignored-newsgroups includes \"^to\\\\.\" as an element." + ;; note this regexp is the same as: + ;; (concat (regexp-quote "^to\\.") "\\($\\|" (regexp-quote "\\|") "\\)") + (string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" + gnus-ignored-newsgroups)) + +;; Read an active file and place the results in `gnus-active-hashtb'. +(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors + real-active) + (unless method + (setq method gnus-select-method)) + (let ((cur (current-buffer)) + (hashtb (or hashtb + (if (and gnus-active-hashtb + (not (equal method gnus-select-method))) + gnus-active-hashtb + (setq gnus-active-hashtb + (if (equal method gnus-select-method) + (gnus-make-hashtable + (count-lines (point-min) (point-max))) + (gnus-make-hashtable 4096))))))) + ;; Delete unnecessary lines. + (goto-char (point-min)) + (cond ((gnus-ignored-newsgroups-has-to-p) + (delete-matching-lines gnus-ignored-newsgroups)) + ((string= gnus-ignored-newsgroups "") + (delete-matching-lines "^to\\.")) + (t + (delete-matching-lines (concat "^to\\.\\|" + gnus-ignored-newsgroups)))) + + ;; Make the group names readable as a lisp expression even if they + ;; contain special characters. + (goto-char (point-max)) + (while (re-search-backward "[][';?()#]" nil t) + (insert ?\\)) + + ;; Let the Gnus agent save the active file. + (when (and gnus-agent real-active) + (gnus-agent-save-active method)) + + ;; If these are groups from a foreign select method, we insert the + ;; group prefix in front of the group names. + (when (not (gnus-server-equal + (gnus-server-get-method nil method) + (gnus-server-get-method nil gnus-select-method))) + (let ((prefix (gnus-group-prefixed-name "" method))) + (goto-char (point-min)) + (while (and (not (eobp)) + (progn (insert prefix) + (zerop (forward-line 1))))))) + ;; Store the active file in a hash table. + (goto-char (point-min)) + (let (group max min) + (while (not (eobp)) + (condition-case () + (progn + (narrow-to-region (point) (gnus-point-at-eol)) + ;; group gets set to a symbol interned in the hash table + ;; (what a hack!!) - jwz + (setq group (let ((obarray hashtb)) (read cur))) + (if (and (numberp (setq max (read cur))) + (numberp (setq min (read cur))) + (progn + (skip-chars-forward " \t") + (not + (or (= (following-char) ?=) + (= (following-char) ?x) + (= (following-char) ?j))))) + (progn + (set group (cons min max)) + ;; if group is moderated, stick in moderation table + (when (= (following-char) ?m) + (unless gnus-moderated-hashtb + (setq gnus-moderated-hashtb (gnus-make-hashtable))) + (gnus-sethash (symbol-name group) t + gnus-moderated-hashtb))) + (set group nil))) + (error + (and group + (symbolp group) + (set group nil)) + (unless ignore-errors + (gnus-message 3 "Warning - illegal active: %s" + (buffer-substring + (gnus-point-at-bol) (gnus-point-at-eol)))))) + (widen) + (forward-line 1))))) + +(defun gnus-groups-to-gnus-format (method &optional hashtb real-active) + ;; Parse a "groups" active file. + (let ((cur (current-buffer)) + (hashtb (or hashtb + (if (and method gnus-active-hashtb) + gnus-active-hashtb + (setq gnus-active-hashtb + (gnus-make-hashtable + (count-lines (point-min) (point-max))))))) + (prefix (and method + (not (gnus-server-equal + (gnus-server-get-method nil method) + (gnus-server-get-method nil gnus-select-method))) + (gnus-group-prefixed-name "" method)))) + + ;; Let the Gnus agent save the active file. + (when (and gnus-agent real-active) + (gnus-agent-save-groups method)) + + (goto-char (point-min)) + ;; We split this into to separate loops, one with the prefix + ;; and one without to speed the reading up somewhat. + (if prefix + (let (min max opoint group) + (while (not (eobp)) + (condition-case () + (progn + (read cur) (read cur) + (setq min (read cur) + max (read cur) + opoint (point)) + (skip-chars-forward " \t") + (insert prefix) + (goto-char opoint) + (set (let ((obarray hashtb)) (read cur)) + (cons min max))) + (error (and group (symbolp group) (set group nil)))) + (forward-line 1))) + (let (min max group) + (while (not (eobp)) + (condition-case () + (when (= (following-char) ?2) + (read cur) (read cur) + (setq min (read cur) + max (read cur)) + (set (setq group (let ((obarray hashtb)) (read cur))) + (cons min max))) + (error (and group (symbolp group) (set group nil)))) + (forward-line 1)))))) + +(defun gnus-read-newsrc-file (&optional force) + "Read startup file. +If FORCE is non-nil, the .newsrc file is read." + ;; Reset variables that might be defined in the .newsrc.eld file. + (let ((variables gnus-variable-list)) + (while variables + (set (car variables) nil) + (setq variables (cdr variables)))) + (let* ((newsrc-file gnus-current-startup-file) + (quick-file (concat newsrc-file ".el"))) + (save-excursion + ;; We always load the .newsrc.eld file. If always contains + ;; much information that can not be gotten from the .newsrc + ;; file (ticked articles, killed groups, foreign methods, etc.) + (gnus-read-newsrc-el-file quick-file) + + (when (and (file-exists-p gnus-current-startup-file) + (or force + (and (file-newer-than-file-p newsrc-file quick-file) + (file-newer-than-file-p newsrc-file + (concat quick-file "d"))) + (not gnus-newsrc-alist))) + ;; We read the .newsrc file. Note that if there if a + ;; .newsrc.eld file exists, it has already been read, and + ;; the `gnus-newsrc-hashtb' has been created. While reading + ;; the .newsrc file, Gnus will only use the information it + ;; can find there for changing the data already read - + ;; i. e., reading the .newsrc file will not trash the data + ;; already read (except for read articles). + (save-excursion + (gnus-message 5 "Reading %s..." newsrc-file) + (set-buffer (nnheader-find-file-noselect newsrc-file)) + (buffer-disable-undo (current-buffer)) + (gnus-newsrc-to-gnus-format) + (kill-buffer (current-buffer)) + (gnus-message 5 "Reading %s...done" newsrc-file))) + + ;; Convert old to new. + (gnus-convert-old-newsrc)))) + +(defun gnus-convert-old-newsrc () + "Convert old newsrc into the new format, if needed." + (let ((fcv (and gnus-newsrc-file-version + (gnus-continuum-version gnus-newsrc-file-version)))) + (cond + ;; No .newsrc.eld file was loaded. + ((null fcv) nil) + ;; Gnus 5 .newsrc.eld was loaded. + ((< fcv (gnus-continuum-version "September Gnus v0.1")) + (gnus-convert-old-ticks))))) + +(defun gnus-convert-old-ticks () + (let ((newsrc (cdr gnus-newsrc-alist)) + marks info dormant ticked) + (while (setq info (pop newsrc)) + (when (setq marks (gnus-info-marks info)) + (setq dormant (cdr (assq 'dormant marks)) + ticked (cdr (assq 'tick marks))) + (when (or dormant ticked) + (gnus-info-set-read + info + (gnus-add-to-range + (gnus-info-read info) + (nconc (gnus-uncompress-range dormant) + (gnus-uncompress-range ticked))))))))) + +(defun gnus-read-newsrc-el-file (file) + (let ((ding-file (concat file "d"))) + ;; We always, always read the .eld file. + (gnus-message 5 "Reading %s..." ding-file) + (let (gnus-newsrc-assoc) + (condition-case nil + (load ding-file t t t) + (error + (ding) + (unless (gnus-yes-or-no-p + (format "Error in %s; continue? " ding-file)) + (error "Error in %s" ding-file)))) + (when gnus-newsrc-assoc + (setq gnus-newsrc-alist gnus-newsrc-assoc))) + (gnus-make-hashtable-from-newsrc-alist) + (when (file-newer-than-file-p file ding-file) + ;; Old format quick file + (gnus-message 5 "Reading %s..." file) + ;; The .el file is newer than the .eld file, so we read that one + ;; as well. + (gnus-read-old-newsrc-el-file file)))) + +;; Parse the old-style quick startup file +(defun gnus-read-old-newsrc-el-file (file) + (let (newsrc killed marked group m info) + (prog1 + (let ((gnus-killed-assoc nil) + gnus-marked-assoc gnus-newsrc-alist gnus-newsrc-assoc) + (prog1 + (ignore-errors + (load file t t t)) + (setq newsrc gnus-newsrc-assoc + killed gnus-killed-assoc + marked gnus-marked-assoc))) + (setq gnus-newsrc-alist nil) + (while (setq group (pop newsrc)) + (if (setq info (gnus-get-info (car group))) + (progn + (gnus-info-set-read info (cddr group)) + (gnus-info-set-level + info (if (nth 1 group) gnus-level-default-subscribed + gnus-level-default-unsubscribed)) + (push info gnus-newsrc-alist)) + (push (setq info + (list (car group) + (if (nth 1 group) gnus-level-default-subscribed + gnus-level-default-unsubscribed) + (cddr group))) + gnus-newsrc-alist)) + ;; Copy marks into info. + (when (setq m (assoc (car group) marked)) + (unless (nthcdr 3 info) + (nconc info (list nil))) + (gnus-info-set-marks + info (list (cons 'tick (gnus-compress-sequence + (sort (cdr m) '<) t)))))) + (setq newsrc killed) + (while newsrc + (setcar newsrc (caar newsrc)) + (setq newsrc (cdr newsrc))) + (setq gnus-killed-list killed)) + ;; The .el file version of this variable does not begin with + ;; "options", while the .eld version does, so we just add it if it + ;; isn't there. + (when + gnus-newsrc-options + (when (not (string-match "^ *options" gnus-newsrc-options)) + (setq gnus-newsrc-options (concat "options " gnus-newsrc-options))) + (when (not (string-match "\n$" gnus-newsrc-options)) + (setq gnus-newsrc-options (concat gnus-newsrc-options "\n"))) + ;; Finally, if we read some options lines, we parse them. + (unless (string= gnus-newsrc-options "") + (gnus-newsrc-parse-options gnus-newsrc-options))) + + (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)) + (gnus-make-hashtable-from-newsrc-alist))) + +(defun gnus-make-newsrc-file (file) + "Make server dependent file name by catenating FILE and server host name." + (let* ((file (expand-file-name file nil)) + (real-file (concat file "-" (nth 1 gnus-select-method)))) + (if (or (file-exists-p real-file) + (file-exists-p (concat real-file ".el")) + (file-exists-p (concat real-file ".eld"))) + real-file file))) + +(defun gnus-newsrc-to-gnus-format () + (setq gnus-newsrc-options "") + (setq gnus-newsrc-options-n nil) + + (unless gnus-active-hashtb + (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + (let ((buf (current-buffer)) + (already-read (> (length gnus-newsrc-alist) 1)) + group subscribed options-symbol newsrc Options-symbol + symbol reads num1) + (goto-char (point-min)) + ;; We intern the symbol `options' in the active hashtb so that we + ;; can `eq' against it later. + (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil) + (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil) + + (while (not (eobp)) + ;; We first read the first word on the line by narrowing and + ;; then reading into `gnus-active-hashtb'. Most groups will + ;; already exist in that hashtb, so this will save some string + ;; space. + (narrow-to-region + (point) + (progn (skip-chars-forward "^ \t!:\n") (point))) + (goto-char (point-min)) + (setq symbol + (and (/= (point-min) (point-max)) + (let ((obarray gnus-active-hashtb)) (read buf)))) + (widen) + ;; Now, the symbol we have read is either `options' or a group + ;; name. If it is an options line, we just add it to a string. + (cond + ((or (eq symbol options-symbol) + (eq symbol Options-symbol)) + (setq gnus-newsrc-options + ;; This concating is quite inefficient, but since our + ;; thorough studies show that approx 99.37% of all + ;; .newsrc files only contain a single options line, we + ;; don't give a damn, frankly, my dear. + (concat gnus-newsrc-options + (buffer-substring + (gnus-point-at-bol) + ;; Options may continue on the next line. + (or (and (re-search-forward "^[^ \t]" nil 'move) + (progn (beginning-of-line) (point))) + (point))))) + (forward-line -1)) + (symbol + ;; Group names can be just numbers. + (when (numberp symbol) + (setq symbol (intern (int-to-string symbol) gnus-active-hashtb))) + (unless (boundp symbol) + (set symbol nil)) + ;; It was a group name. + (setq subscribed (= (following-char) ?:) + group (symbol-name symbol) + reads nil) + (if (eolp) + ;; If the line ends here, this is clearly a buggy line, so + ;; we put point a the beginning of line and let the cond + ;; below do the error handling. + (beginning-of-line) + ;; We skip to the beginning of the ranges. + (skip-chars-forward "!: \t")) + ;; We are now at the beginning of the list of read articles. + ;; We read them range by range. + (while + (cond + ((looking-at "[0-9]+") + ;; We narrow and read a number instead of buffer-substring/ + ;; string-to-int because it's faster. narrow/widen is + ;; faster than save-restriction/narrow, and save-restriction + ;; produces a garbage object. + (setq num1 (progn + (narrow-to-region (match-beginning 0) (match-end 0)) + (read buf))) + (widen) + ;; If the next character is a dash, then this is a range. + (if (= (following-char) ?-) + (progn + ;; We read the upper bound of the range. + (forward-char 1) + (if (not (looking-at "[0-9]+")) + ;; This is a buggy line, by we pretend that + ;; it's kinda OK. Perhaps the user should be + ;; dinged? + (push num1 reads) + (push + (cons num1 + (progn + (narrow-to-region (match-beginning 0) + (match-end 0)) + (read buf))) + reads) + (widen))) + ;; It was just a simple number, so we add it to the + ;; list of ranges. + (push num1 reads)) + ;; If the next char in ?\n, then we have reached the end + ;; of the line and return nil. + (/= (following-char) ?\n)) + ((= (following-char) ?\n) + ;; End of line, so we end. + nil) + (t + ;; Not numbers and not eol, so this might be a buggy + ;; line... + (unless (eobp) + ;; If it was eob instead of ?\n, we allow it. + ;; The line was buggy. + (setq group nil) + (gnus-error 3.1 "Mangled line: %s" + (buffer-substring (gnus-point-at-bol) + (gnus-point-at-eol)))) + nil)) + ;; Skip past ", ". Spaces are illegal in these ranges, but + ;; we allow them, because it's a common mistake to put a + ;; space after the comma. + (skip-chars-forward ", ")) + + ;; We have already read .newsrc.eld, so we gently update the + ;; data in the hash table with the information we have just + ;; read. + (when group + (let ((info (gnus-get-info group)) + level) + (if info + ;; There is an entry for this file in the alist. + (progn + (gnus-info-set-read info (nreverse reads)) + ;; We update the level very gently. In fact, we + ;; only change it if there's been a status change + ;; from subscribed to unsubscribed, or vice versa. + (setq level (gnus-info-level info)) + (cond ((and (<= level gnus-level-subscribed) + (not subscribed)) + (setq level (if reads + gnus-level-default-unsubscribed + (1+ gnus-level-default-unsubscribed)))) + ((and (> level gnus-level-subscribed) subscribed) + (setq level gnus-level-default-subscribed))) + (gnus-info-set-level info level)) + ;; This is a new group. + (setq info (list group + (if subscribed + gnus-level-default-subscribed + (if reads + (1+ gnus-level-subscribed) + gnus-level-default-unsubscribed)) + (nreverse reads)))) + (push info newsrc))))) + (forward-line 1)) + + (setq newsrc (nreverse newsrc)) + + (if (not already-read) + () + ;; We now have two newsrc lists - `newsrc', which is what we + ;; have read from .newsrc, and `gnus-newsrc-alist', which is + ;; what we've read from .newsrc.eld. We have to merge these + ;; lists. We do this by "attaching" any (foreign) groups in the + ;; gnus-newsrc-alist to the (native) group that precedes them. + (let ((rc (cdr gnus-newsrc-alist)) + (prev gnus-newsrc-alist) + entry mentry) + (while rc + (or (null (nth 4 (car rc))) ; It's a native group. + (assoc (caar rc) newsrc) ; It's already in the alist. + (if (setq entry (assoc (caar prev) newsrc)) + (setcdr (setq mentry (memq entry newsrc)) + (cons (car rc) (cdr mentry))) + (push (car rc) newsrc))) + (setq prev rc + rc (cdr rc))))) + + (setq gnus-newsrc-alist newsrc) + ;; We make the newsrc hashtb. + (gnus-make-hashtable-from-newsrc-alist) + + ;; Finally, if we read some options lines, we parse them. + (unless (string= gnus-newsrc-options "") + (gnus-newsrc-parse-options gnus-newsrc-options)))) + +;; Parse options lines to find "options -n !all rec.all" and stuff. +;; The return value will be a list on the form +;; ((regexp1 . ignore) +;; (regexp2 . subscribe)...) +;; When handling new newsgroups, groups that match a `ignore' regexp +;; will be ignored, and groups that match a `subscribe' regexp will be +;; subscribed. A line like +;; options -n !all rec.all +;; will lead to a list that looks like +;; (("^rec\\..+" . subscribe) +;; ("^.+" . ignore)) +;; So all "rec.*" groups will be subscribed, while all the other +;; groups will be ignored. Note that "options -n !all rec.all" is very +;; different from "options -n rec.all !all". +(defun gnus-newsrc-parse-options (options) + (let (out eol) + (save-excursion + (gnus-set-work-buffer) + (insert (regexp-quote options)) + ;; First we treat all continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\n[ \t]+" nil t) + (replace-match " " t t)) + ;; Then we transform all "all"s into ".+"s. + (goto-char (point-min)) + (while (re-search-forward "\\ball\\b" nil t) + (replace-match ".+" t t)) + (goto-char (point-min)) + ;; We remove all other options than the "-n" ones. + (while (re-search-forward "[ \t]-[^n][^-]*" nil t) + (replace-match " ") + (forward-char -1)) + (goto-char (point-min)) + + ;; We are only interested in "options -n" lines - we + ;; ignore the other option lines. + (while (re-search-forward "[ \t]-n" nil t) + (setq eol + (or (save-excursion + (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t) + (- (point) 2))) + (gnus-point-at-eol))) + ;; Search for all "words"... + (while (re-search-forward "[^ \t,\n]+" eol t) + (if (= (char-after (match-beginning 0)) ?!) + ;; If the word begins with a bang (!), this is a "not" + ;; spec. We put this spec (minus the bang) and the + ;; symbol `ignore' into the list. + (push (cons (concat + "^" (buffer-substring + (1+ (match-beginning 0)) + (match-end 0))) + 'ignore) + out) + ;; There was no bang, so this is a "yes" spec. + (push (cons (concat "^" (match-string 0)) + 'subscribe) + out)))) + + (setq gnus-newsrc-options-n out)))) + +(defun gnus-save-newsrc-file (&optional force) + "Save .newsrc file." + ;; Note: We cannot save .newsrc file if all newsgroups are removed + ;; from the variable gnus-newsrc-alist. + (when (and (or gnus-newsrc-alist gnus-killed-list) + gnus-current-startup-file) + (save-excursion + (if (and (or gnus-use-dribble-file gnus-slave) + (not force) + (or (not gnus-dribble-buffer) + (not (buffer-name gnus-dribble-buffer)) + (zerop (save-excursion + (set-buffer gnus-dribble-buffer) + (buffer-size))))) + (gnus-message 4 "(No changes need to be saved)") + (run-hooks 'gnus-save-newsrc-hook) + (if gnus-slave + (gnus-slave-save-newsrc) + ;; Save .newsrc. + (when gnus-save-newsrc-file + (gnus-message 8 "Saving %s..." gnus-current-startup-file) + (gnus-gnus-to-newsrc-format) + (gnus-message 8 "Saving %s...done" gnus-current-startup-file)) + ;; Save .newsrc.eld. + (set-buffer (get-buffer-create " *Gnus-newsrc*")) + (make-local-variable 'version-control) + (setq version-control 'never) + (setq buffer-file-name + (concat gnus-current-startup-file ".eld")) + (setq default-directory (file-name-directory buffer-file-name)) + (gnus-add-current-to-buffer-list) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) + (gnus-gnus-to-quick-newsrc-format) + (run-hooks 'gnus-save-quick-newsrc-hook) + (save-buffer) + (kill-buffer (current-buffer)) + (gnus-message + 5 "Saving %s.eld...done" gnus-current-startup-file)) + (gnus-dribble-delete-file) + (gnus-group-set-mode-line))))) + +(defun gnus-gnus-to-quick-newsrc-format () + "Insert Gnus variables such as gnus-newsrc-alist in lisp format." + (let ((print-quoted t) + (print-escape-newlines t)) + (insert ";; -*- emacs-lisp -*-\n") + (insert ";; Gnus startup file.\n") + (insert + ";; Never delete this file - touch .newsrc instead to force Gnus\n") + (insert ";; to read .newsrc.\n") + (insert "(setq gnus-newsrc-file-version " + (prin1-to-string gnus-version) ")\n") + (let* ((gnus-killed-list + (if (and gnus-save-killed-list + (stringp gnus-save-killed-list)) + (gnus-strip-killed-list) + gnus-killed-list)) + (variables + (if gnus-save-killed-list gnus-variable-list + ;; Remove the `gnus-killed-list' from the list of variables + ;; to be saved, if required. + (delq 'gnus-killed-list (copy-sequence gnus-variable-list)))) + ;; Peel off the "dummy" group. + (gnus-newsrc-alist (cdr gnus-newsrc-alist)) + variable) + ;; Insert the variables into the file. + (while variables + (when (and (boundp (setq variable (pop variables))) + (symbol-value variable)) + (insert "(setq " (symbol-name variable) " '") + (gnus-prin1 (symbol-value variable)) + (insert ")\n")))))) + +(defun gnus-strip-killed-list () + "Return the killed list minus the groups that match `gnus-save-killed-list'." + (let ((list gnus-killed-list) + olist) + (while list + (when (string-match gnus-save-killed-list) + (push (car list) olist)) + (pop list)) + (nreverse olist))) + +(defun gnus-gnus-to-newsrc-format () + ;; Generate and save the .newsrc file. + (save-excursion + (set-buffer (create-file-buffer gnus-current-startup-file)) + (let ((newsrc (cdr gnus-newsrc-alist)) + (standard-output (current-buffer)) + info ranges range method) + (setq buffer-file-name gnus-current-startup-file) + (setq default-directory (file-name-directory buffer-file-name)) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + ;; Write options. + (when gnus-newsrc-options + (insert gnus-newsrc-options)) + ;; Write subscribed and unsubscribed. + (while (setq info (pop newsrc)) + ;; Don't write foreign groups to .newsrc. + (when (or (null (setq method (gnus-info-method info))) + (equal method "native") + (inline (gnus-server-equal method gnus-select-method))) + (insert (gnus-info-group info) + (if (> (gnus-info-level info) gnus-level-subscribed) + "!" ":")) + (when (setq ranges (gnus-info-read info)) + (insert " ") + (if (not (listp (cdr ranges))) + (if (= (car ranges) (cdr ranges)) + (princ (car ranges)) + (princ (car ranges)) + (insert "-") + (princ (cdr ranges))) + (while (setq range (pop ranges)) + (if (or (atom range) (= (car range) (cdr range))) + (princ (or (and (atom range) range) (car range))) + (princ (car range)) + (insert "-") + (princ (cdr range))) + (when ranges + (insert ","))))) + (insert "\n"))) + (make-local-variable 'version-control) + (setq version-control 'never) + ;; It has been reported that sometime the modtime on the .newsrc + ;; file seems to be off. We really do want to overwrite it, so + ;; we clear the modtime here before saving. It's a bit odd, + ;; though... + ;; sometimes the modtime clear isn't sufficient. most brute force: + ;; delete the silly thing entirely first. but this fails to provide + ;; such niceties as .newsrc~ creation. + (if gnus-modtime-botch + (delete-file gnus-startup-file) + (clear-visited-file-modtime)) + (run-hooks 'gnus-save-standard-newsrc-hook) + (save-buffer) + (kill-buffer (current-buffer))))) + + +;;; +;;; Slave functions. +;;; + +(defun gnus-slave-save-newsrc () + (save-excursion + (set-buffer gnus-dribble-buffer) + (let ((slave-name + (make-temp-name (concat gnus-current-startup-file "-slave-"))) + (modes (ignore-errors + (file-modes (concat gnus-current-startup-file ".eld"))))) + (gnus-write-buffer slave-name) + (when modes + (set-file-modes slave-name modes))))) + +(defun gnus-master-read-slave-newsrc () + (let ((slave-files + (directory-files + (file-name-directory gnus-current-startup-file) + t (concat + "^" (regexp-quote + (concat + (file-name-nondirectory gnus-current-startup-file) + "-slave-"))) + t)) + file) + (if (not slave-files) + () ; There are no slave files to read. + (gnus-message 7 "Reading slave newsrcs...") + (save-excursion + (set-buffer (get-buffer-create " *gnus slave*")) + (buffer-disable-undo (current-buffer)) + (setq slave-files + (sort (mapcar (lambda (file) + (list (nth 5 (file-attributes file)) file)) + slave-files) + (lambda (f1 f2) + (or (< (caar f1) (caar f2)) + (< (nth 1 (car f1)) (nth 1 (car f2))))))) + (while slave-files + (erase-buffer) + (setq file (nth 1 (car slave-files))) + (insert-file-contents file) + (when (condition-case () + (progn + (eval-buffer (current-buffer)) + t) + (error + (gnus-error 3.2 "Possible error in %s" file) + nil)) + (unless gnus-slave ; Slaves shouldn't delete these files. + (ignore-errors + (delete-file file)))) + (setq slave-files (cdr slave-files)))) + (gnus-dribble-touch) + (gnus-message 7 "Reading slave newsrcs...done")))) + + +;;; +;;; Group description. +;;; + +(defun gnus-read-all-descriptions-files () + (let ((methods (cons gnus-select-method + (nconc + (when (gnus-archive-server-wanted-p) + (list "archive")) + gnus-secondary-select-methods)))) + (while methods + (gnus-read-descriptions-file (car methods)) + (setq methods (cdr methods))) + t)) + +(defun gnus-read-descriptions-file (&optional method) + (let ((method (or method gnus-select-method)) + group) + (when (stringp method) + (setq method (gnus-server-to-method method))) + ;; We create the hashtable whether we manage to read the desc file + ;; to avoid trying to re-read after a failed read. + (unless gnus-description-hashtb + (setq gnus-description-hashtb + (gnus-make-hashtable (length gnus-active-hashtb)))) + ;; Mark this method's desc file as read. + (gnus-sethash (gnus-group-prefixed-name "" method) "Has read" + gnus-description-hashtb) + + (gnus-message 5 "Reading descriptions file via %s..." (car method)) + (cond + ((not (gnus-check-server method)) + (gnus-message 1 "Couldn't open server") + nil) + ((not (gnus-request-list-newsgroups method)) + (gnus-message 1 "Couldn't read newsgroups descriptions") + nil) + (t + (save-excursion + (save-restriction + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (or (search-forward "\n.\n" nil t) + (goto-char (point-max))) + (beginning-of-line) + (narrow-to-region (point-min) (point))) + ;; If these are groups from a foreign select method, we insert the + ;; group prefix in front of the group names. + (and method (not (inline + (gnus-server-equal + (gnus-server-get-method nil method) + (gnus-server-get-method + nil gnus-select-method)))) + (let ((prefix (gnus-group-prefixed-name "" method))) + (goto-char (point-min)) + (while (and (not (eobp)) + (progn (insert prefix) + (zerop (forward-line 1))))))) + (goto-char (point-min)) + (while (not (eobp)) + ;; If we get an error, we set group to 0, which is not a + ;; symbol... + (setq group + (condition-case () + (let ((obarray gnus-description-hashtb)) + ;; Group is set to a symbol interned in this + ;; hash table. + (read nntp-server-buffer)) + (error 0))) + (skip-chars-forward " \t") + ;; ... which leads to this line being effectively ignored. + (when (symbolp group) + (set group (buffer-substring + (point) (progn (end-of-line) (point))))) + (forward-line 1)))) + (gnus-message 5 "Reading descriptions file...done") + t)))) + +(defun gnus-group-get-description (group) + "Get the description of a group by sending XGTITLE to the server." + (when (gnus-request-group-description group) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (looking-at "[^ \t]+[ \t]+\\(.*\\)") + (match-string 1))))) + +;;;###autoload +(defun gnus-declare-backend (name &rest abilities) + "Declare backend NAME with ABILITIES as a Gnus backend." + (setq gnus-valid-select-methods + (nconc gnus-valid-select-methods + (list (apply 'list name abilities))))) + +(defun gnus-set-default-directory () + "Set the default directory in the current buffer to `gnus-default-directory'. +If this variable is nil, don't do anything." + (setq default-directory + (if (and gnus-default-directory + (file-exists-p gnus-default-directory)) + (file-name-as-directory (expand-file-name gnus-default-directory)) + default-directory))) + +(provide 'gnus-start) + +;;; gnus-start.el ends here diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el new file mode 100644 index 0000000..5d5a4f0 --- /dev/null +++ b/lisp/gnus-sum.el @@ -0,0 +1,8921 @@ +;;; gnus-sum.el --- summary mode commands for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-group) +(require 'gnus-spec) +(require 'gnus-range) +(require 'gnus-int) +(require 'gnus-undo) + +(defcustom gnus-kill-summary-on-exit t + "*If non-nil, kill the summary buffer when you exit from it. +If nil, the summary will become a \"*Dead Summary*\" buffer, and +it will be killed sometime later." + :group 'gnus-summary-exit + :type 'boolean) + +(defcustom gnus-fetch-old-headers nil + "*Non-nil means that Gnus will try to build threads by grabbing old headers. +If an unread article in the group refers to an older, already read (or +just marked as read) article, the old article will not normally be +displayed in the Summary buffer. If this variable is non-nil, Gnus +will attempt to grab the headers to the old articles, and thereby +build complete threads. If it has the value `some', only enough +headers to connect otherwise loose threads will be displayed. This +variable can also be a number. In that case, no more than that number +of old headers will be fetched. If it has the value `invisible', all +old headers will be fetched, but none will be displayed. + +The server has to support NOV for any of this to work." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const some) + number + (sexp :menu-tag "other" t))) + +(defcustom gnus-refer-thread-limit 200 + "*The number of old headers to fetch when doing \\\\[gnus-summary-refer-thread]. +If t, fetch all the available old headers." + :group 'gnus-thread + :type '(choice number + (sexp :menu-tag "other" t))) + +(defcustom gnus-summary-make-false-root 'adopt + "*nil means that Gnus won't gather loose threads. +If the root of a thread has expired or been read in a previous +session, the information necessary to build a complete thread has been +lost. Instead of having many small sub-threads from this original thread +scattered all over the summary buffer, Gnus can gather them. + +If non-nil, Gnus will try to gather all loose sub-threads from an +original thread into one large thread. + +If this variable is non-nil, it should be one of `none', `adopt', +`dummy' or `empty'. + +If this variable is `none', Gnus will not make a false root, but just +present the sub-threads after another. +If this variable is `dummy', Gnus will create a dummy root that will +have all the sub-threads as children. +If this variable is `adopt', Gnus will make one of the \"children\" +the parent and mark all the step-children as such. +If this variable is `empty', the \"children\" are printed with empty +subject fields. (Or rather, they will be printed with a string +given by the `gnus-summary-same-subject' variable.)" + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const none) + (const dummy) + (const adopt) + (const empty))) + +(defcustom gnus-summary-gather-exclude-subject "^ *$\\|^(none)$" + "*A regexp to match subjects to be excluded from loose thread gathering. +As loose thread gathering is done on subjects only, that means that +there can be many false gatherings performed. By rooting out certain +common subjects, gathering might become saner." + :group 'gnus-thread + :type 'regexp) + +(defcustom gnus-summary-gather-subject-limit nil + "*Maximum length of subject comparisons when gathering loose threads. +Use nil to compare full subjects. Setting this variable to a low +number will help gather threads that have been corrupted by +newsreaders chopping off subject lines, but it might also mean that +unrelated articles that have subject that happen to begin with the +same few characters will be incorrectly gathered. + +If this variable is `fuzzy', Gnus will use a fuzzy algorithm when +comparing subjects." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const fuzzy) + (sexp :menu-tag "on" t))) + +(defcustom gnus-simplify-subject-functions nil + "List of functions taking a string argument that simplify subjects. +The functions are applied recursively." + :group 'gnus-thread + :type '(repeat (list function))) + +(defcustom gnus-simplify-ignored-prefixes nil + "*Regexp, matches for which are removed from subject lines when simplifying fuzzily." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + regexp)) + +(defcustom gnus-build-sparse-threads nil + "*If non-nil, fill in the gaps in threads. +If `some', only fill in the gaps that are needed to tie loose threads +together. If `more', fill in all leaf nodes that Gnus can find. If +non-nil and non-`some', fill in all gaps that Gnus manages to guess." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const some) + (const more) + (sexp :menu-tag "all" t))) + +(defcustom gnus-summary-thread-gathering-function + 'gnus-gather-threads-by-subject + "Function used for gathering loose threads. +There are two pre-defined functions: `gnus-gather-threads-by-subject', +which only takes Subjects into consideration; and +`gnus-gather-threads-by-references', which compared the References +headers of the articles to find matches." + :group 'gnus-thread + :type '(radio (function-item gnus-gather-threads-by-subject) + (function-item gnus-gather-threads-by-references) + (function :tag "other"))) + +(defcustom gnus-summary-same-subject "" + "*String indicating that the current article has the same subject as the previous. +This variable will only be used if the value of +`gnus-summary-make-false-root' is `empty'." + :group 'gnus-summary-format + :type 'string) + +(defcustom gnus-summary-goto-unread t + "*If t, marking commands will go to the next unread article. +If `never', commands that usually go to the next unread article, will +go to the next article, whether it is read or not. +If nil, only the marking commands will go to the next (un)read article." + :group 'gnus-summary-marks + :link '(custom-manual "(gnus)Setting Marks") + :type '(choice (const :tag "off" nil) + (const never) + (sexp :menu-tag "on" t))) + +(defcustom gnus-summary-default-score 0 + "*Default article score level. +All scores generated by the score files will be added to this score. +If this variable is nil, scoring will be disabled." + :group 'gnus-score-default + :type '(choice (const :tag "disable") + integer)) + +(defcustom gnus-summary-zcore-fuzz 0 + "*Fuzziness factor for the zcore in the summary buffer. +Articles with scores closer than this to `gnus-summary-default-score' +will not be marked." + :group 'gnus-summary-format + :type 'integer) + +(defcustom gnus-simplify-subject-fuzzy-regexp nil + "*Strings to be removed when doing fuzzy matches. +This can either be a regular expression or list of regular expressions +that will be removed from subject strings if fuzzy subject +simplification is selected." + :group 'gnus-thread + :type '(repeat regexp)) + +(defcustom gnus-show-threads t + "*If non-nil, display threads in summary mode." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-hide-subtree nil + "*If non-nil, hide all threads initially. +If threads are hidden, you have to run the command +`gnus-summary-show-thread' by hand or use `gnus-select-article-hook' +to expose hidden threads." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-hide-killed t + "*If non-nil, hide killed threads automatically." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-ignore-subject nil + "*If non-nil, ignore subjects and do all threading based on the Reference header. +If nil, which is the default, articles that have different subjects +from their parents will start separate threads." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-operation-ignore-subject t + "*If non-nil, subjects will be ignored when doing thread commands. +This affects commands like `gnus-summary-kill-thread' and +`gnus-summary-lower-thread'. + +If this variable is nil, articles in the same thread with different +subjects will not be included in the operation in question. If this +variable is `fuzzy', only articles that have subjects that are fuzzily +equal will be included." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const fuzzy) + (sexp :tag "on" t))) + +(defcustom gnus-thread-indent-level 4 + "*Number that says how much each sub-thread should be indented." + :group 'gnus-thread + :type 'integer) + +(defcustom gnus-auto-extend-newsgroup t + "*If non-nil, extend newsgroup forward and backward when requested." + :group 'gnus-summary-choose + :type 'boolean) + +(defcustom gnus-auto-select-first t + "*If nil, don't select the first unread article when entering a group. +If this variable is `best', select the highest-scored unread article +in the group. If neither nil nor `best', select the first unread +article. + +If you want to prevent automatic selection of the first unread article +in some newsgroups, set the variable to nil in +`gnus-select-group-hook'." + :group 'gnus-group-select + :type '(choice (const :tag "none" nil) + (const best) + (sexp :menu-tag "first" t))) + +(defcustom gnus-auto-select-next t + "*If non-nil, offer to go to the next group from the end of the previous. +If the value is t and the next newsgroup is empty, Gnus will exit +summary mode and go back to group mode. If the value is neither nil +nor t, Gnus will select the following unread newsgroup. In +particular, if the value is the symbol `quietly', the next unread +newsgroup will be selected without any confirmation, and if it is +`almost-quietly', the next group will be selected without any +confirmation if you are located on the last article in the group. +Finally, if this variable is `slightly-quietly', the `Z n' command +will go to the next group without confirmation." + :group 'gnus-summary-maneuvering + :type '(choice (const :tag "off" nil) + (const quietly) + (const almost-quietly) + (const slightly-quietly) + (sexp :menu-tag "on" t))) + +(defcustom gnus-auto-select-same nil + "*If non-nil, select the next article with the same subject." + :group 'gnus-summary-maneuvering + :type 'boolean) + +(defcustom gnus-summary-check-current nil + "*If non-nil, consider the current article when moving. +The \"unread\" movement commands will stay on the same line if the +current article is unread." + :group 'gnus-summary-maneuvering + :type 'boolean) + +(defcustom gnus-auto-center-summary t + "*If non-nil, always center the current summary buffer. +In particular, if `vertical' do only vertical recentering. If non-nil +and non-`vertical', do both horizontal and vertical recentering." + :group 'gnus-summary-maneuvering + :type '(choice (const :tag "none" nil) + (const vertical) + (sexp :menu-tag "both" t))) + +(defcustom gnus-show-all-headers nil + "*If non-nil, don't hide any headers." + :group 'gnus-article-hiding + :group 'gnus-article-headers + :type 'boolean) + +(defcustom gnus-summary-ignore-duplicates nil + "*If non-nil, ignore articles with identical Message-ID headers." + :group 'gnus-summary + :type 'boolean) + +(defcustom gnus-single-article-buffer t + "*If non-nil, display all articles in the same buffer. +If nil, each group will get its own article buffer." + :group 'gnus-article-various + :type 'boolean) + +(defcustom gnus-break-pages t + "*If non-nil, do page breaking on articles. +The page delimiter is specified by the `gnus-page-delimiter' +variable." + :group 'gnus-article-various + :type 'boolean) + +(defcustom gnus-show-mime nil + "*If non-nil, do mime processing of articles. +The articles will simply be fed to the function given by +`gnus-show-mime-method'." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-move-split-methods nil + "*Variable used to suggest where articles are to be moved to. +It uses the same syntax as the `gnus-split-methods' variable." + :group 'gnus-summary-mail + :type '(repeat (choice (list function) + (cons regexp (repeat string)) + sexp))) + +(defcustom gnus-unread-mark ? + "*Mark used for unread articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-ticked-mark ?! + "*Mark used for ticked articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-dormant-mark ?? + "*Mark used for dormant articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-del-mark ?r + "*Mark used for del'd articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-read-mark ?R + "*Mark used for read articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-expirable-mark ?E + "*Mark used for expirable articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-killed-mark ?K + "*Mark used for killed articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-souped-mark ?F + "*Mark used for killed articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-kill-file-mark ?X + "*Mark used for articles killed by kill files." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-low-score-mark ?Y + "*Mark used for articles with a low score." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-catchup-mark ?C + "*Mark used for articles that are caught up." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-replied-mark ?A + "*Mark used for articles that have been replied to." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-cached-mark ?* + "*Mark used for articles that are in the cache." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-saved-mark ?S + "*Mark used for articles that have been saved to." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-ancient-mark ?O + "*Mark used for ancient articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-sparse-mark ?Q + "*Mark used for sparsely reffed articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-canceled-mark ?G + "*Mark used for canceled articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-duplicate-mark ?M + "*Mark used for duplicate articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-undownloaded-mark ?@ + "*Mark used for articles that weren't downloaded." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-downloadable-mark ?% + "*Mark used for articles that are to be downloaded." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-unsendable-mark ?= + "*Mark used for articles that won't be sent." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-score-over-mark ?+ + "*Score mark used for articles with high scores." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-score-below-mark ?- + "*Score mark used for articles with low scores." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-empty-thread-mark ? + "*There is no thread under the article." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-not-empty-thread-mark ?= + "*There is a thread under the article." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-view-pseudo-asynchronously nil + "*If non-nil, Gnus will view pseudo-articles asynchronously." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-view-pseudos nil + "*If `automatic', pseudo-articles will be viewed automatically. +If `not-confirm', pseudos will be viewed automatically, and the user +will not be asked to confirm the command." + :group 'gnus-extract-view + :type '(choice (const :tag "off" nil) + (const automatic) + (const not-confirm))) + +(defcustom gnus-view-pseudos-separately t + "*If non-nil, one pseudo-article will be created for each file to be viewed. +If nil, all files that use the same viewing command will be given as a +list of parameters to that command." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-insert-pseudo-articles t + "*If non-nil, insert pseudo-articles when decoding articles." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-summary-dummy-line-format + "* %(: :%) %S\n" + "*The format specification for the dummy roots in the summary buffer. +It works along the same lines as a normal formatting string, +with some simple extensions. + +%S The subject" + :group 'gnus-threading + :type 'string) + +(defcustom gnus-summary-mode-line-format "Gnus: %%b [%A] %Z" + "*The format specification for the summary mode line. +It works along the same lines as a normal formatting string, +with some simple extensions: + +%G Group name +%p Unprefixed group name +%A Current article number +%V Gnus version +%U Number of unread articles in the group +%e Number of unselected articles in the group +%Z A string with unread/unselected article counts +%g Shortish group name +%S Subject of the current article +%u User-defined spec +%s Current score file name +%d Number of dormant articles +%r Number of articles that have been marked as read in this session +%E Number of articles expunged by the score files" + :group 'gnus-summary-format + :type 'string) + +(defcustom gnus-summary-mark-below 0 + "*Mark all articles with a score below this variable as read. +This variable is local to each summary buffer and usually set by the +score file." + :group 'gnus-score-default + :type 'integer) + +(defcustom gnus-article-sort-functions '(gnus-article-sort-by-number) + "*List of functions used for sorting articles in the summary buffer. +This variable is only used when not using a threaded display." + :group 'gnus-summary-sort + :type '(repeat (choice (function-item gnus-article-sort-by-number) + (function-item gnus-article-sort-by-author) + (function-item gnus-article-sort-by-subject) + (function-item gnus-article-sort-by-date) + (function-item gnus-article-sort-by-score) + (function :tag "other")))) + +(defcustom gnus-thread-sort-functions '(gnus-thread-sort-by-number) + "*List of functions used for sorting threads in the summary buffer. +By default, threads are sorted by article number. + +Each function takes two threads and return non-nil if the first thread +should be sorted before the other. If you use more than one function, +the primary sort function should be the last. You should probably +always include `gnus-thread-sort-by-number' in the list of sorting +functions -- preferably first. + +Ready-made functions include `gnus-thread-sort-by-number', +`gnus-thread-sort-by-author', `gnus-thread-sort-by-subject', +`gnus-thread-sort-by-date', `gnus-thread-sort-by-score' and +`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function')." + :group 'gnus-summary-sort + :type '(repeat (choice (function-item gnus-thread-sort-by-number) + (function-item gnus-thread-sort-by-author) + (function-item gnus-thread-sort-by-subject) + (function-item gnus-thread-sort-by-date) + (function-item gnus-thread-sort-by-score) + (function-item gnus-thread-sort-by-total-score) + (function :tag "other")))) + +(defcustom gnus-thread-score-function '+ + "*Function used for calculating the total score of a thread. + +The function is called with the scores of the article and each +subthread and should then return the score of the thread. + +Some functions you can use are `+', `max', or `min'." + :group 'gnus-summary-sort + :type 'function) + +(defcustom gnus-summary-expunge-below nil + "All articles that have a score less than this variable will be expunged." + :group 'gnus-score-default + :type '(choice (const :tag "off" nil) + integer)) + +(defcustom gnus-thread-expunge-below nil + "All threads that have a total score less than this variable will be expunged. +See `gnus-thread-score-function' for en explanation of what a +\"thread score\" is." + :group 'gnus-treading + :group 'gnus-score-default + :type '(choice (const :tag "off" nil) + integer)) + +(defcustom gnus-summary-mode-hook nil + "*A hook for Gnus summary mode. +This hook is run before any variables are set in the summary buffer." + :group 'gnus-summary-various + :type 'hook) + +(defcustom gnus-summary-menu-hook nil + "*Hook run after the creation of the summary mode menu." + :group 'gnus-summary-visual + :type 'hook) + +(defcustom gnus-summary-exit-hook nil + "*A hook called on exit from the summary buffer. +It will be called with point in the group buffer." + :group 'gnus-summary-exit + :type 'hook) + +(defcustom gnus-summary-prepare-hook nil + "*A hook called after the summary buffer has been generated. +If you want to modify the summary buffer, you can use this hook." + :group 'gnus-summary-various + :type 'hook) + +(defcustom gnus-summary-generate-hook nil + "*A hook run just before generating the summary buffer. +This hook is commonly used to customize threading variables and the +like." + :group 'gnus-summary-various + :type 'hook) + +(defcustom gnus-select-group-hook nil + "*A hook called when a newsgroup is selected. + +If you'd like to simplify subjects like the +`gnus-summary-next-same-subject' command does, you can use the +following hook: + + (setq gnus-select-group-hook + (list + (lambda () + (mapcar (lambda (header) + (mail-header-set-subject + header + (gnus-simplify-subject + (mail-header-subject header) 're-only))) + gnus-newsgroup-headers))))" + :group 'gnus-group-select + :type 'hook) + +(defcustom gnus-select-article-hook nil + "*A hook called when an article is selected." + :group 'gnus-summary-choose + :type 'hook) + +(defcustom gnus-visual-mark-article-hook + (list 'gnus-highlight-selected-summary) + "*Hook run after selecting an article in the summary buffer. +It is meant to be used for highlighting the article in some way. It +is not run if `gnus-visual' is nil." + :group 'gnus-summary-visual + :type 'hook) + +;; 1997/5/4 by MORIOKA Tomohiko +(defcustom gnus-structured-field-decoder 'identity + "Function to decode non-ASCII characters in structured field for summary." + :group 'gnus-various + :type 'function) + +(defcustom gnus-unstructured-field-decoder 'identity + "Function to decode non-ASCII characters in unstructured field for summary." + :group 'gnus-various + :type 'function) + +(defcustom gnus-parse-headers-hook + (list 'gnus-hack-decode-rfc1522 'gnus-decode-rfc1522) + "*A hook called before parsing the headers." + :group 'gnus-various + :type 'hook) + +(defcustom gnus-exit-group-hook nil + "*A hook called when exiting (not quitting) summary mode." + :group 'gnus-various + :type 'hook) + +(defcustom gnus-summary-update-hook + (list 'gnus-summary-highlight-line) + "*A hook called when a summary line is changed. +The hook will not be called if `gnus-visual' is nil. + +The default function `gnus-summary-highlight-line' will +highlight the line according to the `gnus-summary-highlight' +variable." + :group 'gnus-summary-visual + :type 'hook) + +(defcustom gnus-mark-article-hook '(gnus-summary-mark-read-and-unread-as-read) + "*A hook called when an article is selected for the first time. +The hook is intended to mark an article as read (or unread) +automatically when it is selected." + :group 'gnus-summary-choose + :type 'hook) + +(defcustom gnus-group-no-more-groups-hook nil + "*A hook run when returning to group mode having no more (unread) groups." + :group 'gnus-group-select + :type 'hook) + +(defcustom gnus-ps-print-hook nil + "*A hook run before ps-printing something from Gnus." + :group 'gnus-summary + :type 'hook) + +(defcustom gnus-summary-selected-face 'gnus-summary-selected-face + "Face used for highlighting the current article in the summary buffer." + :group 'gnus-summary-visual + :type 'face) + +(defcustom gnus-summary-highlight + '(((= mark gnus-canceled-mark) + . gnus-summary-cancelled-face) + ((and (> score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + . gnus-summary-high-ticked-face) + ((and (< score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + . gnus-summary-low-ticked-face) + ((or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark)) + . gnus-summary-normal-ticked-face) + ((and (> score default) (= mark gnus-ancient-mark)) + . gnus-summary-high-ancient-face) + ((and (< score default) (= mark gnus-ancient-mark)) + . gnus-summary-low-ancient-face) + ((= mark gnus-ancient-mark) + . gnus-summary-normal-ancient-face) + ((and (> score default) (= mark gnus-unread-mark)) + . gnus-summary-high-unread-face) + ((and (< score default) (= mark gnus-unread-mark)) + . gnus-summary-low-unread-face) + ((and (= mark gnus-unread-mark)) + . gnus-summary-normal-unread-face) + ((> score default) + . gnus-summary-high-read-face) + ((< score default) + . gnus-summary-low-read-face) + (t + . gnus-summary-normal-read-face)) + "Controls the highlighting of summary buffer lines. + +A list of (FORM . FACE) pairs. When deciding how a a particular +summary line should be displayed, each form is evaluated. The content +of the face field after the first true form is used. You can change +how those summary lines are displayed, by editing the face field. + +You can use the following variables in the FORM field. + +score: The articles score +default: The default article score. +below: The score below which articles are automatically marked as read. +mark: The articles mark." + :group 'gnus-summary-visual + :type '(repeat (cons (sexp :tag "Form" nil) + face))) + +(defcustom gnus-alter-header-function nil + "Function called to allow alteration of article header structures. +The function is called with one parameter, the article header vector, +which it may alter in any way.") + +;;; Internal variables + +(defvar gnus-scores-exclude-files nil) +(defvar gnus-page-broken nil) + +(defvar gnus-original-article nil) +(defvar gnus-article-internal-prepare-hook nil) +(defvar gnus-newsgroup-process-stack nil) + +(defvar gnus-thread-indent-array nil) +(defvar gnus-thread-indent-array-level gnus-thread-indent-level) + +;; Avoid highlighting in kill files. +(defvar gnus-summary-inhibit-highlight nil) +(defvar gnus-newsgroup-selected-overlay nil) +(defvar gnus-inhibit-limiting nil) +(defvar gnus-newsgroup-adaptive-score-file nil) +(defvar gnus-current-score-file nil) +(defvar gnus-current-move-group nil) +(defvar gnus-current-copy-group nil) +(defvar gnus-current-crosspost-group nil) + +(defvar gnus-newsgroup-dependencies nil) +(defvar gnus-newsgroup-adaptive nil) +(defvar gnus-summary-display-article-function nil) +(defvar gnus-summary-highlight-line-function nil + "Function called after highlighting a summary line.") + +(defvar gnus-summary-line-format-alist + `((?N ,(macroexpand '(mail-header-number gnus-tmp-header)) ?d) + (?S ,(macroexpand '(mail-header-subject gnus-tmp-header)) ?s) + (?s gnus-tmp-subject-or-nil ?s) + (?n gnus-tmp-name ?s) + (?A (car (cdr (funcall gnus-extract-address-components gnus-tmp-from))) + ?s) + (?a (or (car (funcall gnus-extract-address-components gnus-tmp-from)) + gnus-tmp-from) ?s) + (?F gnus-tmp-from ?s) + (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s) + (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s) + (?d (gnus-dd-mmm (mail-header-date gnus-tmp-header)) ?s) + (?o (gnus-date-iso8601 gnus-tmp-header) ?s) + (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s) + (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s) + (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) + (?L gnus-tmp-lines ?d) + (?I gnus-tmp-indentation ?s) + (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) + (?R gnus-tmp-replied ?c) + (?\[ gnus-tmp-opening-bracket ?c) + (?\] gnus-tmp-closing-bracket ?c) + (?\> (make-string gnus-tmp-level ? ) ?s) + (?\< (make-string (max 0 (- 20 gnus-tmp-level)) ? ) ?s) + (?i gnus-tmp-score ?d) + (?z gnus-tmp-score-char ?c) + (?l (bbb-grouplens-score gnus-tmp-header) ?s) + (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) + (?U gnus-tmp-unread ?c) + (?t (gnus-summary-number-of-articles-in-thread + (and (boundp 'thread) (car thread)) gnus-tmp-level) + ?d) + (?e (gnus-summary-number-of-articles-in-thread + (and (boundp 'thread) (car thread)) gnus-tmp-level t) + ?c) + (?u gnus-tmp-user-defined ?s) + (?P (gnus-pick-line-number) ?d)) + "An alist of format specifications that can appear in summary lines, +and what variables they correspond with, along with the type of the +variable (string, integer, character, etc).") + +(defvar gnus-summary-dummy-line-format-alist + `((?S gnus-tmp-subject ?s) + (?N gnus-tmp-number ?d) + (?u gnus-tmp-user-defined ?s))) + +(defvar gnus-summary-mode-line-format-alist + `((?G gnus-tmp-group-name ?s) + (?g (gnus-short-group-name gnus-tmp-group-name) ?s) + (?p (gnus-group-real-name gnus-tmp-group-name) ?s) + (?A gnus-tmp-article-number ?d) + (?Z gnus-tmp-unread-and-unselected ?s) + (?V gnus-version ?s) + (?U gnus-tmp-unread-and-unticked ?d) + (?S gnus-tmp-subject ?s) + (?e gnus-tmp-unselected ?d) + (?u gnus-tmp-user-defined ?s) + (?d (length gnus-newsgroup-dormant) ?d) + (?t (length gnus-newsgroup-marked) ?d) + (?r (length gnus-newsgroup-reads) ?d) + (?E gnus-newsgroup-expunged-tally ?d) + (?s (gnus-current-score-file-nondirectory) ?s))) + +(defvar gnus-last-search-regexp nil + "Default regexp for article search command.") + +(defvar gnus-last-shell-command nil + "Default shell command on article.") + +(defvar gnus-newsgroup-begin nil) +(defvar gnus-newsgroup-end nil) +(defvar gnus-newsgroup-last-rmail nil) +(defvar gnus-newsgroup-last-mail nil) +(defvar gnus-newsgroup-last-folder nil) +(defvar gnus-newsgroup-last-file nil) +(defvar gnus-newsgroup-auto-expire nil) +(defvar gnus-newsgroup-active nil) + +(defvar gnus-newsgroup-data nil) +(defvar gnus-newsgroup-data-reverse nil) +(defvar gnus-newsgroup-limit nil) +(defvar gnus-newsgroup-limits nil) + +(defvar gnus-newsgroup-unreads nil + "List of unread articles in the current newsgroup.") + +(defvar gnus-newsgroup-unselected nil + "List of unselected unread articles in the current newsgroup.") + +(defvar gnus-newsgroup-reads nil + "Alist of read articles and article marks in the current newsgroup.") + +(defvar gnus-newsgroup-expunged-tally nil) + +(defvar gnus-newsgroup-marked nil + "List of ticked articles in the current newsgroup (a subset of unread art).") + +(defvar gnus-newsgroup-killed nil + "List of ranges of articles that have been through the scoring process.") + +(defvar gnus-newsgroup-cached nil + "List of articles that come from the article cache.") + +(defvar gnus-newsgroup-saved nil + "List of articles that have been saved.") + +(defvar gnus-newsgroup-kill-headers nil) + +(defvar gnus-newsgroup-replied nil + "List of articles that have been replied to in the current newsgroup.") + +(defvar gnus-newsgroup-expirable nil + "List of articles in the current newsgroup that can be expired.") + +(defvar gnus-newsgroup-processable nil + "List of articles in the current newsgroup that can be processed.") + +(defvar gnus-newsgroup-downloadable nil + "List of articles in the current newsgroup that can be processed.") + +(defvar gnus-newsgroup-undownloaded nil + "List of articles in the current newsgroup that haven't been downloaded..") + +(defvar gnus-newsgroup-unsendable nil + "List of articles in the current newsgroup that won't be sent.") + +(defvar gnus-newsgroup-bookmarks nil + "List of articles in the current newsgroup that have bookmarks.") + +(defvar gnus-newsgroup-dormant nil + "List of dormant articles in the current newsgroup.") + +(defvar gnus-newsgroup-scored nil + "List of scored articles in the current newsgroup.") + +(defvar gnus-newsgroup-headers nil + "List of article headers in the current newsgroup.") + +(defvar gnus-newsgroup-threads nil) + +(defvar gnus-newsgroup-prepared nil + "Whether the current group has been prepared properly.") + +(defvar gnus-newsgroup-ancient nil + "List of `gnus-fetch-old-headers' articles in the current newsgroup.") + +(defvar gnus-newsgroup-sparse nil) + +(defvar gnus-current-article nil) +(defvar gnus-article-current nil) +(defvar gnus-current-headers nil) +(defvar gnus-have-all-headers nil) +(defvar gnus-last-article nil) +(defvar gnus-newsgroup-history nil) + +(defconst gnus-summary-local-variables + '(gnus-newsgroup-name + gnus-newsgroup-begin gnus-newsgroup-end + gnus-newsgroup-last-rmail gnus-newsgroup-last-mail + gnus-newsgroup-last-folder gnus-newsgroup-last-file + gnus-newsgroup-auto-expire gnus-newsgroup-unreads + gnus-newsgroup-unselected gnus-newsgroup-marked + gnus-newsgroup-reads gnus-newsgroup-saved + gnus-newsgroup-replied gnus-newsgroup-expirable + gnus-newsgroup-processable gnus-newsgroup-killed + gnus-newsgroup-downloadable gnus-newsgroup-undownloaded + gnus-newsgroup-unsendable + gnus-newsgroup-bookmarks gnus-newsgroup-dormant + gnus-newsgroup-headers gnus-newsgroup-threads + gnus-newsgroup-prepared gnus-summary-highlight-line-function + gnus-current-article gnus-current-headers gnus-have-all-headers + gnus-last-article gnus-article-internal-prepare-hook + gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay + gnus-newsgroup-scored gnus-newsgroup-kill-headers + gnus-thread-expunge-below + gnus-score-alist gnus-current-score-file gnus-summary-expunge-below + (gnus-summary-mark-below . global) + gnus-newsgroup-active gnus-scores-exclude-files + gnus-newsgroup-history gnus-newsgroup-ancient + gnus-newsgroup-sparse gnus-newsgroup-process-stack + (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring) + gnus-newsgroup-adaptive-score-file (gnus-reffed-article-number . -1) + (gnus-newsgroup-expunged-tally . 0) + gnus-cache-removable-articles gnus-newsgroup-cached + gnus-newsgroup-data gnus-newsgroup-data-reverse + gnus-newsgroup-limit gnus-newsgroup-limits) + "Variables that are buffer-local to the summary buffers.") + +;; Byte-compiler warning. +(defvar gnus-article-mode-map) + +;; Subject simplification. + +(defun gnus-simplify-whitespace (str) + "Remove excessive whitespace." + (let ((mystr str)) + ;; Multiple spaces. + (while (string-match "[ \t][ \t]+" mystr) + (setq mystr (concat (substring mystr 0 (match-beginning 0)) + " " + (substring mystr (match-end 0))))) + ;; Leading spaces. + (when (string-match "^[ \t]+" mystr) + (setq mystr (substring mystr (match-end 0)))) + ;; Trailing spaces. + (when (string-match "[ \t]+$" mystr) + (setq mystr (substring mystr 0 (match-beginning 0)))) + mystr)) + +(defsubst gnus-simplify-subject-re (subject) + "Remove \"Re:\" from subject lines." + (if (string-match "^[Rr][Ee]: *" subject) + (substring subject (match-end 0)) + subject)) + +(defun gnus-simplify-subject (subject &optional re-only) + "Remove `Re:' and words in parentheses. +If RE-ONLY is non-nil, strip leading `Re:'s only." + (let ((case-fold-search t)) ;Ignore case. + ;; Remove `Re:', `Re^N:', `Re(n)', and `Re[n]:'. + (when (string-match "\\`\\(re\\([[(^][0-9]+[])]?\\)?:[ \t]*\\)+" subject) + (setq subject (substring subject (match-end 0)))) + ;; Remove uninteresting prefixes. + (when (and (not re-only) + gnus-simplify-ignored-prefixes + (string-match gnus-simplify-ignored-prefixes subject)) + (setq subject (substring subject (match-end 0)))) + ;; Remove words in parentheses from end. + (unless re-only + (while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject) + (setq subject (substring subject 0 (match-beginning 0))))) + ;; Return subject string. + subject)) + +;; Remove any leading "re:"s, any trailing paren phrases, and simplify +;; all whitespace. +(defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match (or newtext "")))) + +(defun gnus-simplify-buffer-fuzzy () + "Simplify string in the buffer fuzzily. +The string in the accessible portion of the current buffer is simplified. +It is assumed to be a single-line subject. +Whitespace is generally cleaned up, and miscellaneous leading/trailing +matter is removed. Additional things can be deleted by setting +gnus-simplify-subject-fuzzy-regexp." + (let ((case-fold-search t) + (modified-tick)) + (gnus-simplify-buffer-fuzzy-step "\t" " ") + + (while (not (eq modified-tick (buffer-modified-tick))) + (setq modified-tick (buffer-modified-tick)) + (cond + ((listp gnus-simplify-subject-fuzzy-regexp) + (mapcar 'gnus-simplify-buffer-fuzzy-step + gnus-simplify-subject-fuzzy-regexp)) + (gnus-simplify-subject-fuzzy-regexp + (gnus-simplify-buffer-fuzzy-step gnus-simplify-subject-fuzzy-regexp))) + (gnus-simplify-buffer-fuzzy-step "^ *\\[[-+?*!][-+?*!]\\] *") + (gnus-simplify-buffer-fuzzy-step + "^ *\\(re\\|fw\\|fwd\\)[[{(^0-9]*[])}]?[:;] *") + (gnus-simplify-buffer-fuzzy-step "^[[].*:\\( .*\\)[]]$" "\\1")) + + (gnus-simplify-buffer-fuzzy-step " *[[{(][^()\n]*[]})] *$") + (gnus-simplify-buffer-fuzzy-step " +" " ") + (gnus-simplify-buffer-fuzzy-step " $") + (gnus-simplify-buffer-fuzzy-step "^ +"))) + +(defun gnus-simplify-subject-fuzzy (subject) + "Simplify a subject string fuzzily. +See `gnus-simplify-buffer-fuzzy' for details." + (save-excursion + (gnus-set-work-buffer) + (let ((case-fold-search t)) + (insert subject) + (inline (gnus-simplify-buffer-fuzzy)) + (buffer-string)))) + +(defsubst gnus-simplify-subject-fully (subject) + "Simplify a subject string according to gnus-summary-gather-subject-limit." + (cond + (gnus-simplify-subject-functions + (gnus-map-function gnus-simplify-subject-functions subject)) + ((null gnus-summary-gather-subject-limit) + (gnus-simplify-subject-re subject)) + ((eq gnus-summary-gather-subject-limit 'fuzzy) + (gnus-simplify-subject-fuzzy subject)) + ((numberp gnus-summary-gather-subject-limit) + (gnus-limit-string (gnus-simplify-subject-re subject) + gnus-summary-gather-subject-limit)) + (t + subject))) + +(defsubst gnus-subject-equal (s1 s2 &optional simple-first) + "Check whether two subjects are equal. +If optional argument simple-first is t, first argument is already +simplified." + (cond + ((null simple-first) + (equal (gnus-simplify-subject-fully s1) + (gnus-simplify-subject-fully s2))) + (t + (equal s1 + (gnus-simplify-subject-fully s2))))) + +(defun gnus-summary-bubble-group () + "Increase the score of the current group. +This is a handy function to add to `gnus-summary-exit-hook' to +increase the score of each group you read." + (gnus-group-add-score gnus-newsgroup-name)) + + +;;; +;;; Gnus summary mode +;;; + +(put 'gnus-summary-mode 'mode-class 'special) + +(when t + ;; Non-orthogonal keys + + (gnus-define-keys gnus-summary-mode-map + " " gnus-summary-next-page + "\177" gnus-summary-prev-page + [delete] gnus-summary-prev-page + "\r" gnus-summary-scroll-up + "n" gnus-summary-next-unread-article + "p" gnus-summary-prev-unread-article + "N" gnus-summary-next-article + "P" gnus-summary-prev-article + "\M-\C-n" gnus-summary-next-same-subject + "\M-\C-p" gnus-summary-prev-same-subject + "\M-n" gnus-summary-next-unread-subject + "\M-p" gnus-summary-prev-unread-subject + "." gnus-summary-first-unread-article + "," gnus-summary-best-unread-article + "\M-s" gnus-summary-search-article-forward + "\M-r" gnus-summary-search-article-backward + "<" gnus-summary-beginning-of-article + ">" gnus-summary-end-of-article + "j" gnus-summary-goto-article + "^" gnus-summary-refer-parent-article + "\M-^" gnus-summary-refer-article + "u" gnus-summary-tick-article-forward + "!" gnus-summary-tick-article-forward + "U" gnus-summary-tick-article-backward + "d" gnus-summary-mark-as-read-forward + "D" gnus-summary-mark-as-read-backward + "E" gnus-summary-mark-as-expirable + "\M-u" gnus-summary-clear-mark-forward + "\M-U" gnus-summary-clear-mark-backward + "k" gnus-summary-kill-same-subject-and-select + "\C-k" gnus-summary-kill-same-subject + "\M-\C-k" gnus-summary-kill-thread + "\M-\C-l" gnus-summary-lower-thread + "e" gnus-summary-edit-article + "#" gnus-summary-mark-as-processable + "\M-#" gnus-summary-unmark-as-processable + "\M-\C-t" gnus-summary-toggle-threads + "\M-\C-s" gnus-summary-show-thread + "\M-\C-h" gnus-summary-hide-thread + "\M-\C-f" gnus-summary-next-thread + "\M-\C-b" gnus-summary-prev-thread + "\M-\C-u" gnus-summary-up-thread + "\M-\C-d" gnus-summary-down-thread + "&" gnus-summary-execute-command + "c" gnus-summary-catchup-and-exit + "\C-w" gnus-summary-mark-region-as-read + "\C-t" gnus-summary-toggle-truncation + "?" gnus-summary-mark-as-dormant + "\C-c\M-\C-s" gnus-summary-limit-include-expunged + "\C-c\C-s\C-n" gnus-summary-sort-by-number + "\C-c\C-s\C-l" gnus-summary-sort-by-lines + "\C-c\C-s\C-a" gnus-summary-sort-by-author + "\C-c\C-s\C-s" gnus-summary-sort-by-subject + "\C-c\C-s\C-d" gnus-summary-sort-by-date + "\C-c\C-s\C-i" gnus-summary-sort-by-score + "=" gnus-summary-expand-window + "\C-x\C-s" gnus-summary-reselect-current-group + "\M-g" gnus-summary-rescan-group + "w" gnus-summary-stop-page-breaking + "\C-c\C-r" gnus-summary-caesar-message + "\M-t" gnus-summary-toggle-mime + "f" gnus-summary-followup + "F" gnus-summary-followup-with-original + "C" gnus-summary-cancel-article + "r" gnus-summary-reply + "R" gnus-summary-reply-with-original + "\C-c\C-f" gnus-summary-mail-forward + "o" gnus-summary-save-article + "\C-o" gnus-summary-save-article-mail + "|" gnus-summary-pipe-output + "\M-k" gnus-summary-edit-local-kill + "\M-K" gnus-summary-edit-global-kill + ;; "V" gnus-version + "\C-c\C-d" gnus-summary-describe-group + "q" gnus-summary-exit + "Q" gnus-summary-exit-no-update + "\C-c\C-i" gnus-info-find-node + gnus-mouse-2 gnus-mouse-pick-article + "m" gnus-summary-mail-other-window + "a" gnus-summary-post-news + "x" gnus-summary-limit-to-unread + "s" gnus-summary-isearch-article + "t" gnus-article-hide-headers + "g" gnus-summary-show-article + "l" gnus-summary-goto-last-article + "\C-c\C-v\C-v" gnus-uu-decode-uu-view + "\C-d" gnus-summary-enter-digest-group + "\M-\C-d" gnus-summary-read-document + "\C-c\C-b" gnus-bug + "*" gnus-cache-enter-article + "\M-*" gnus-cache-remove-article + "\M-&" gnus-summary-universal-argument + "\C-l" gnus-recenter + "I" gnus-summary-increase-score + "L" gnus-summary-lower-score + "\M-i" gnus-symbolic-argument + + "V" gnus-summary-score-map + "X" gnus-uu-extract-map + "S" gnus-summary-send-map) + + ;; Sort of orthogonal keymap + (gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) + "t" gnus-summary-tick-article-forward + "!" gnus-summary-tick-article-forward + "d" gnus-summary-mark-as-read-forward + "r" gnus-summary-mark-as-read-forward + "c" gnus-summary-clear-mark-forward + " " gnus-summary-clear-mark-forward + "e" gnus-summary-mark-as-expirable + "x" gnus-summary-mark-as-expirable + "?" gnus-summary-mark-as-dormant + "b" gnus-summary-set-bookmark + "B" gnus-summary-remove-bookmark + "#" gnus-summary-mark-as-processable + "\M-#" gnus-summary-unmark-as-processable + "S" gnus-summary-limit-include-expunged + "C" gnus-summary-catchup + "H" gnus-summary-catchup-to-here + "\C-c" gnus-summary-catchup-all + "k" gnus-summary-kill-same-subject-and-select + "K" gnus-summary-kill-same-subject + "P" gnus-uu-mark-map) + + (gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map) + "c" gnus-summary-clear-above + "u" gnus-summary-tick-above + "m" gnus-summary-mark-above + "k" gnus-summary-kill-below) + + (gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) + "/" gnus-summary-limit-to-subject + "n" gnus-summary-limit-to-articles + "w" gnus-summary-pop-limit + "s" gnus-summary-limit-to-subject + "a" gnus-summary-limit-to-author + "u" gnus-summary-limit-to-unread + "m" gnus-summary-limit-to-marks + "v" gnus-summary-limit-to-score + "D" gnus-summary-limit-include-dormant + "T" gnus-summary-limit-include-thread + "d" gnus-summary-limit-exclude-dormant + "t" gnus-summary-limit-to-age + "E" gnus-summary-limit-include-expunged + "c" gnus-summary-limit-exclude-childless-dormant + "C" gnus-summary-limit-mark-excluded-as-read) + + (gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) + "n" gnus-summary-next-unread-article + "p" gnus-summary-prev-unread-article + "N" gnus-summary-next-article + "P" gnus-summary-prev-article + "\C-n" gnus-summary-next-same-subject + "\C-p" gnus-summary-prev-same-subject + "\M-n" gnus-summary-next-unread-subject + "\M-p" gnus-summary-prev-unread-subject + "f" gnus-summary-first-unread-article + "b" gnus-summary-best-unread-article + "j" gnus-summary-goto-article + "g" gnus-summary-goto-subject + "l" gnus-summary-goto-last-article + "o" gnus-summary-pop-article) + + (gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) + "k" gnus-summary-kill-thread + "l" gnus-summary-lower-thread + "i" gnus-summary-raise-thread + "T" gnus-summary-toggle-threads + "t" gnus-summary-rethread-current + "^" gnus-summary-reparent-thread + "s" gnus-summary-show-thread + "S" gnus-summary-show-all-threads + "h" gnus-summary-hide-thread + "H" gnus-summary-hide-all-threads + "n" gnus-summary-next-thread + "p" gnus-summary-prev-thread + "u" gnus-summary-up-thread + "o" gnus-summary-top-thread + "d" gnus-summary-down-thread + "#" gnus-uu-mark-thread + "\M-#" gnus-uu-unmark-thread) + + (gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) + "g" gnus-summary-prepare + "c" gnus-summary-insert-cached-articles) + + (gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) + "c" gnus-summary-catchup-and-exit + "C" gnus-summary-catchup-all-and-exit + "E" gnus-summary-exit-no-update + "Q" gnus-summary-exit + "Z" gnus-summary-exit + "n" gnus-summary-catchup-and-goto-next-group + "R" gnus-summary-reselect-current-group + "G" gnus-summary-rescan-group + "N" gnus-summary-next-group + "s" gnus-summary-save-newsrc + "P" gnus-summary-prev-group) + + (gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) + " " gnus-summary-next-page + "n" gnus-summary-next-page + "\177" gnus-summary-prev-page + [delete] gnus-summary-prev-page + "p" gnus-summary-prev-page + "\r" gnus-summary-scroll-up + "<" gnus-summary-beginning-of-article + ">" gnus-summary-end-of-article + "b" gnus-summary-beginning-of-article + "e" gnus-summary-end-of-article + "^" gnus-summary-refer-parent-article + "r" gnus-summary-refer-parent-article + "R" gnus-summary-refer-references + "T" gnus-summary-refer-thread + "g" gnus-summary-show-article + "s" gnus-summary-isearch-article + "P" gnus-summary-print-article) + + (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) + "b" gnus-article-add-buttons + "B" gnus-article-add-buttons-to-head + "o" gnus-article-treat-overstrike + "e" gnus-article-emphasize + "w" gnus-article-fill-cited-article + "c" gnus-article-remove-cr + "q" gnus-article-de-quoted-unreadable + "f" gnus-article-display-x-face + "l" gnus-summary-stop-page-breaking + "r" gnus-summary-caesar-message + "t" gnus-article-hide-headers + "v" gnus-summary-verbose-headers + "m" gnus-summary-toggle-mime + "h" gnus-article-treat-html) + + (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) + "a" gnus-article-hide + "h" gnus-article-hide-headers + "b" gnus-article-hide-boring-headers + "s" gnus-article-hide-signature + "c" gnus-article-hide-citation + "p" gnus-article-hide-pgp + "P" gnus-article-hide-pem + "\C-c" gnus-article-hide-citation-maybe) + + (gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) + "a" gnus-article-highlight + "h" gnus-article-highlight-headers + "c" gnus-article-highlight-citation + "s" gnus-article-highlight-signature) + + (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) + "z" gnus-article-date-ut + "u" gnus-article-date-ut + "l" gnus-article-date-local + "e" gnus-article-date-lapsed + "o" gnus-article-date-original + "s" gnus-article-date-user) + + (gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) + "t" gnus-article-remove-trailing-blank-lines + "l" gnus-article-strip-leading-blank-lines + "m" gnus-article-strip-multiple-blank-lines + "a" gnus-article-strip-blank-lines + "s" gnus-article-strip-leading-space) + + (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) + "v" gnus-version + "f" gnus-summary-fetch-faq + "d" gnus-summary-describe-group + "h" gnus-summary-describe-briefly + "i" gnus-info-find-node) + + (gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) + "e" gnus-summary-expire-articles + "\M-\C-e" gnus-summary-expire-articles-now + "\177" gnus-summary-delete-article + [delete] gnus-summary-delete-article + "m" gnus-summary-move-article + "r" gnus-summary-respool-article + "w" gnus-summary-edit-article + "c" gnus-summary-copy-article + "B" gnus-summary-crosspost-article + "q" gnus-summary-respool-query + "i" gnus-summary-import-article + "p" gnus-summary-article-posted-p) + + (gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) + "o" gnus-summary-save-article + "m" gnus-summary-save-article-mail + "F" gnus-summary-write-article-file + "r" gnus-summary-save-article-rmail + "f" gnus-summary-save-article-file + "b" gnus-summary-save-article-body-file + "h" gnus-summary-save-article-folder + "v" gnus-summary-save-article-vm + "p" gnus-summary-pipe-output + "s" gnus-soup-add-article)) + +(defun gnus-summary-make-menu-bar () + (gnus-turn-off-edit-menu 'summary) + + (unless (boundp 'gnus-summary-misc-menu) + + (easy-menu-define + gnus-summary-kill-menu gnus-summary-mode-map "" + (cons + "Score" + (nconc + (list + ["Enter score..." gnus-summary-score-entry t] + ["Customize" gnus-score-customize t]) + (gnus-make-score-map 'increase) + (gnus-make-score-map 'lower) + '(("Mark" + ["Kill below" gnus-summary-kill-below t] + ["Mark above" gnus-summary-mark-above t] + ["Tick above" gnus-summary-tick-above t] + ["Clear above" gnus-summary-clear-above t]) + ["Current score" gnus-summary-current-score t] + ["Set score" gnus-summary-set-score t] + ["Switch current score file..." gnus-score-change-score-file t] + ["Set mark below..." gnus-score-set-mark-below t] + ["Set expunge below..." gnus-score-set-expunge-below t] + ["Edit current score file" gnus-score-edit-current-scores t] + ["Edit score file" gnus-score-edit-file t] + ["Trace score" gnus-score-find-trace t] + ["Find words" gnus-score-find-favourite-words t] + ["Rescore buffer" gnus-summary-rescore t] + ["Increase score..." gnus-summary-increase-score t] + ["Lower score..." gnus-summary-lower-score t])))) + + '(("Default header" + ["Ask" (gnus-score-set-default 'gnus-score-default-header nil) + :style radio + :selected (null gnus-score-default-header)] + ["From" (gnus-score-set-default 'gnus-score-default-header 'a) + :style radio + :selected (eq gnus-score-default-header 'a)] + ["Subject" (gnus-score-set-default 'gnus-score-default-header 's) + :style radio + :selected (eq gnus-score-default-header 's)] + ["Article body" + (gnus-score-set-default 'gnus-score-default-header 'b) + :style radio + :selected (eq gnus-score-default-header 'b )] + ["All headers" + (gnus-score-set-default 'gnus-score-default-header 'h) + :style radio + :selected (eq gnus-score-default-header 'h )] + ["Message-ID" (gnus-score-set-default 'gnus-score-default-header 'i) + :style radio + :selected (eq gnus-score-default-header 'i )] + ["Thread" (gnus-score-set-default 'gnus-score-default-header 't) + :style radio + :selected (eq gnus-score-default-header 't )] + ["Crossposting" + (gnus-score-set-default 'gnus-score-default-header 'x) + :style radio + :selected (eq gnus-score-default-header 'x )] + ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l) + :style radio + :selected (eq gnus-score-default-header 'l )] + ["Date" (gnus-score-set-default 'gnus-score-default-header 'd) + :style radio + :selected (eq gnus-score-default-header 'd )] + ["Followups to author" + (gnus-score-set-default 'gnus-score-default-header 'f) + :style radio + :selected (eq gnus-score-default-header 'f )]) + ("Default type" + ["Ask" (gnus-score-set-default 'gnus-score-default-type nil) + :style radio + :selected (null gnus-score-default-type)] + ;; The `:active' key is commented out in the following, + ;; because the GNU Emacs hack to support radio buttons use + ;; active to indicate which button is selected. + ["Substring" (gnus-score-set-default 'gnus-score-default-type 's) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 's)] + ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 'r)] + ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 'e)] + ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 'f)] + ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b) + :style radio + ;; :active (eq (gnus-score-default-header 'd)) + :selected (eq gnus-score-default-type 'b)] + ["At date" (gnus-score-set-default 'gnus-score-default-type 'n) + :style radio + ;; :active (eq (gnus-score-default-header 'd)) + :selected (eq gnus-score-default-type 'n)] + ["After date" (gnus-score-set-default 'gnus-score-default-type 'a) + :style radio + ;; :active (eq (gnus-score-default-header 'd)) + :selected (eq gnus-score-default-type 'a)] + ["Less than number" + (gnus-score-set-default 'gnus-score-default-type '<) + :style radio + ;; :active (eq (gnus-score-default-header 'l)) + :selected (eq gnus-score-default-type '<)] + ["Equal to number" + (gnus-score-set-default 'gnus-score-default-type '=) + :style radio + ;; :active (eq (gnus-score-default-header 'l)) + :selected (eq gnus-score-default-type '=)] + ["Greater than number" + (gnus-score-set-default 'gnus-score-default-type '>) + :style radio + ;; :active (eq (gnus-score-default-header 'l)) + :selected (eq gnus-score-default-type '>)]) + ["Default fold" gnus-score-default-fold-toggle + :style toggle + :selected gnus-score-default-fold] + ("Default duration" + ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil) + :style radio + :selected (null gnus-score-default-duration)] + ["Permanent" + (gnus-score-set-default 'gnus-score-default-duration 'p) + :style radio + :selected (eq gnus-score-default-duration 'p)] + ["Temporary" + (gnus-score-set-default 'gnus-score-default-duration 't) + :style radio + :selected (eq gnus-score-default-duration 't)] + ["Immediate" + (gnus-score-set-default 'gnus-score-default-duration 'i) + :style radio + :selected (eq gnus-score-default-duration 'i)])) + + (easy-menu-define + gnus-summary-article-menu gnus-summary-mode-map "" + '("Article" + ("Hide" + ["All" gnus-article-hide t] + ["Headers" gnus-article-hide-headers t] + ["Signature" gnus-article-hide-signature t] + ["Citation" gnus-article-hide-citation t] + ["PGP" gnus-article-hide-pgp t] + ["Boring headers" gnus-article-hide-boring-headers t]) + ("Highlight" + ["All" gnus-article-highlight t] + ["Headers" gnus-article-highlight-headers t] + ["Signature" gnus-article-highlight-signature t] + ["Citation" gnus-article-highlight-citation t]) + ("Date" + ["Local" gnus-article-date-local t] + ["UT" gnus-article-date-ut t] + ["Original" gnus-article-date-original t] + ["Lapsed" gnus-article-date-lapsed t] + ["User-defined" gnus-article-date-user t]) + ("Washing" + ("Remove Blanks" + ["Leading" gnus-article-strip-leading-blank-lines t] + ["Multiple" gnus-article-strip-multiple-blank-lines t] + ["Trailing" gnus-article-remove-trailing-blank-lines t] + ["All of the above" gnus-article-strip-blank-lines t] + ["Leading space" gnus-article-strip-leading-space t]) + ["Overstrike" gnus-article-treat-overstrike t] + ["Emphasis" gnus-article-emphasize t] + ["Word wrap" gnus-article-fill-cited-article t] + ["CR" gnus-article-remove-cr t] + ["Show X-Face" gnus-article-display-x-face t] + ["Quoted-Printable" gnus-article-de-quoted-unreadable t] + ["UnHTMLize" gnus-article-treat-html t] + ["Rot 13" gnus-summary-caesar-message t] + ["Unix pipe" gnus-summary-pipe-message t] + ["Add buttons" gnus-article-add-buttons t] + ["Add buttons to head" gnus-article-add-buttons-to-head t] + ["Stop page breaking" gnus-summary-stop-page-breaking t] + ["Toggle MIME" gnus-summary-toggle-mime t] + ["Verbose header" gnus-summary-verbose-headers t] + ["Toggle header" gnus-summary-toggle-header t]) + ("Output" + ["Save in default format" gnus-summary-save-article t] + ["Save in file" gnus-summary-save-article-file t] + ["Save in Unix mail format" gnus-summary-save-article-mail t] + ["Write to file" gnus-summary-write-article-mail t] + ["Save in MH folder" gnus-summary-save-article-folder t] + ["Save in VM folder" gnus-summary-save-article-vm t] + ["Save in RMAIL mbox" gnus-summary-save-article-rmail t] + ["Save body in file" gnus-summary-save-article-body-file t] + ["Pipe through a filter" gnus-summary-pipe-output t] + ["Add to SOUP packet" gnus-soup-add-article t] + ["Print" gnus-summary-print-article t]) + ("Backend" + ["Respool article..." gnus-summary-respool-article t] + ["Move article..." gnus-summary-move-article + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)] + ["Copy article..." gnus-summary-copy-article t] + ["Crosspost article..." gnus-summary-crosspost-article + (gnus-check-backend-function + 'request-replace-article gnus-newsgroup-name)] + ["Import file..." gnus-summary-import-article t] + ["Check if posted" gnus-summary-article-posted-p t] + ["Edit article" gnus-summary-edit-article + (not (gnus-group-read-only-p))] + ["Delete article" gnus-summary-delete-article + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Query respool" gnus-summary-respool-query t] + ["Delete expirable articles" gnus-summary-expire-articles-now + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)]) + ("Extract" + ["Uudecode" gnus-uu-decode-uu t] + ["Uudecode and save" gnus-uu-decode-uu-and-save t] + ["Unshar" gnus-uu-decode-unshar t] + ["Unshar and save" gnus-uu-decode-unshar-and-save t] + ["Save" gnus-uu-decode-save t] + ["Binhex" gnus-uu-decode-binhex t] + ["Postscript" gnus-uu-decode-postscript t]) + ("Cache" + ["Enter article" gnus-cache-enter-article t] + ["Remove article" gnus-cache-remove-article t]) + ["Enter digest buffer" gnus-summary-enter-digest-group t] + ["Isearch article..." gnus-summary-isearch-article t] + ["Beginning of the article" gnus-summary-beginning-of-article t] + ["End of the article" gnus-summary-end-of-article t] + ["Fetch parent of article" gnus-summary-refer-parent-article t] + ["Fetch referenced articles" gnus-summary-refer-references t] + ["Fetch current thread" gnus-summary-refer-thread t] + ["Fetch article with id..." gnus-summary-refer-article t] + ["Redisplay" gnus-summary-show-article t])) + + (easy-menu-define + gnus-summary-thread-menu gnus-summary-mode-map "" + '("Threads" + ["Toggle threading" gnus-summary-toggle-threads t] + ["Hide threads" gnus-summary-hide-all-threads t] + ["Show threads" gnus-summary-show-all-threads t] + ["Hide thread" gnus-summary-hide-thread t] + ["Show thread" gnus-summary-show-thread t] + ["Go to next thread" gnus-summary-next-thread t] + ["Go to previous thread" gnus-summary-prev-thread t] + ["Go down thread" gnus-summary-down-thread t] + ["Go up thread" gnus-summary-up-thread t] + ["Top of thread" gnus-summary-top-thread t] + ["Mark thread as read" gnus-summary-kill-thread t] + ["Lower thread score" gnus-summary-lower-thread t] + ["Raise thread score" gnus-summary-raise-thread t] + ["Rethread current" gnus-summary-rethread-current t] + )) + + (easy-menu-define + gnus-summary-post-menu gnus-summary-mode-map "" + '("Post" + ["Post an article" gnus-summary-post-news t] + ["Followup" gnus-summary-followup t] + ["Followup and yank" gnus-summary-followup-with-original t] + ["Supersede article" gnus-summary-supersede-article t] + ["Cancel article" gnus-summary-cancel-article t] + ["Reply" gnus-summary-reply t] + ["Reply and yank" gnus-summary-reply-with-original t] + ["Wide reply" gnus-summary-wide-reply t] + ["Wide reply and yank" gnus-summary-wide-reply-with-original t] + ["Mail forward" gnus-summary-mail-forward t] + ["Post forward" gnus-summary-post-forward t] + ["Digest and mail" gnus-uu-digest-mail-forward t] + ["Digest and post" gnus-uu-digest-post-forward t] + ["Resend message" gnus-summary-resend-message t] + ["Send bounced mail" gnus-summary-resend-bounced-mail t] + ["Send a mail" gnus-summary-mail-other-window t] + ["Uuencode and post" gnus-uu-post-news t] + ["Followup via news" gnus-summary-followup-to-mail t] + ["Followup via news and yank" + gnus-summary-followup-to-mail-with-original t] + ;;("Draft" + ;;["Send" gnus-summary-send-draft t] + ;;["Send bounced" gnus-resend-bounced-mail t]) + )) + + (easy-menu-define + gnus-summary-misc-menu gnus-summary-mode-map "" + '("Misc" + ("Mark Read" + ["Mark as read" gnus-summary-mark-as-read-forward t] + ["Mark same subject and select" + gnus-summary-kill-same-subject-and-select t] + ["Mark same subject" gnus-summary-kill-same-subject t] + ["Catchup" gnus-summary-catchup t] + ["Catchup all" gnus-summary-catchup-all t] + ["Catchup to here" gnus-summary-catchup-to-here t] + ["Catchup region" gnus-summary-mark-region-as-read t] + ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) + ("Mark Various" + ["Tick" gnus-summary-tick-article-forward t] + ["Mark as dormant" gnus-summary-mark-as-dormant t] + ["Remove marks" gnus-summary-clear-mark-forward t] + ["Set expirable mark" gnus-summary-mark-as-expirable t] + ["Set bookmark" gnus-summary-set-bookmark t] + ["Remove bookmark" gnus-summary-remove-bookmark t]) + ("Mark Limit" + ["Marks..." gnus-summary-limit-to-marks t] + ["Subject..." gnus-summary-limit-to-subject t] + ["Author..." gnus-summary-limit-to-author t] + ["Age..." gnus-summary-limit-to-age t] + ["Score" gnus-summary-limit-to-score t] + ["Unread" gnus-summary-limit-to-unread t] + ["Non-dormant" gnus-summary-limit-exclude-dormant t] + ["Articles" gnus-summary-limit-to-articles t] + ["Pop limit" gnus-summary-pop-limit t] + ["Show dormant" gnus-summary-limit-include-dormant t] + ["Hide childless dormant" + gnus-summary-limit-exclude-childless-dormant t] + ;;["Hide thread" gnus-summary-limit-exclude-thread t] + ["Show expunged" gnus-summary-show-all-expunged t]) + ("Process Mark" + ["Set mark" gnus-summary-mark-as-processable t] + ["Remove mark" gnus-summary-unmark-as-processable t] + ["Remove all marks" gnus-summary-unmark-all-processable t] + ["Mark above" gnus-uu-mark-over t] + ["Mark series" gnus-uu-mark-series t] + ["Mark region" gnus-uu-mark-region t] + ["Mark by regexp..." gnus-uu-mark-by-regexp t] + ["Mark all" gnus-uu-mark-all t] + ["Mark buffer" gnus-uu-mark-buffer t] + ["Mark sparse" gnus-uu-mark-sparse t] + ["Mark thread" gnus-uu-mark-thread t] + ["Unmark thread" gnus-uu-unmark-thread t] + ("Process Mark Sets" + ["Kill" gnus-summary-kill-process-mark t] + ["Yank" gnus-summary-yank-process-mark + gnus-newsgroup-process-stack] + ["Save" gnus-summary-save-process-mark t])) + ("Scroll article" + ["Page forward" gnus-summary-next-page t] + ["Page backward" gnus-summary-prev-page t] + ["Line forward" gnus-summary-scroll-up t]) + ("Move" + ["Next unread article" gnus-summary-next-unread-article t] + ["Previous unread article" gnus-summary-prev-unread-article t] + ["Next article" gnus-summary-next-article t] + ["Previous article" gnus-summary-prev-article t] + ["Next unread subject" gnus-summary-next-unread-subject t] + ["Previous unread subject" gnus-summary-prev-unread-subject t] + ["Next article same subject" gnus-summary-next-same-subject t] + ["Previous article same subject" gnus-summary-prev-same-subject t] + ["First unread article" gnus-summary-first-unread-article t] + ["Best unread article" gnus-summary-best-unread-article t] + ["Go to subject number..." gnus-summary-goto-subject t] + ["Go to article number..." gnus-summary-goto-article t] + ["Go to the last article" gnus-summary-goto-last-article t] + ["Pop article off history" gnus-summary-pop-article t]) + ("Sort" + ["Sort by number" gnus-summary-sort-by-number t] + ["Sort by author" gnus-summary-sort-by-author t] + ["Sort by subject" gnus-summary-sort-by-subject t] + ["Sort by date" gnus-summary-sort-by-date t] + ["Sort by score" gnus-summary-sort-by-score t] + ["Sort by lines" gnus-summary-sort-by-lines t]) + ("Help" + ["Fetch group FAQ" gnus-summary-fetch-faq t] + ["Describe group" gnus-summary-describe-group t] + ["Read manual" gnus-info-find-node t]) + ("Modes" + ["Pick and read" gnus-pick-mode t] + ["Binary" gnus-binary-mode t]) + ("Regeneration" + ["Regenerate" gnus-summary-prepare t] + ["Insert cached articles" gnus-summary-insert-cached-articles t] + ["Toggle threading" gnus-summary-toggle-threads t]) + ["Filter articles..." gnus-summary-execute-command t] + ["Run command on subjects..." gnus-summary-universal-argument t] + ["Search articles forward..." gnus-summary-search-article-forward t] + ["Search articles backward..." gnus-summary-search-article-backward t] + ["Toggle line truncation" gnus-summary-toggle-truncation t] + ["Expand window" gnus-summary-expand-window t] + ["Expire expirable articles" gnus-summary-expire-articles + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Edit local kill file" gnus-summary-edit-local-kill t] + ["Edit main kill file" gnus-summary-edit-global-kill t] + ("Exit" + ["Catchup and exit" gnus-summary-catchup-and-exit t] + ["Catchup all and exit" gnus-summary-catchup-and-exit t] + ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] + ["Exit group" gnus-summary-exit t] + ["Exit group without updating" gnus-summary-exit-no-update t] + ["Exit and goto next group" gnus-summary-next-group t] + ["Exit and goto prev group" gnus-summary-prev-group t] + ["Reselect group" gnus-summary-reselect-current-group t] + ["Rescan group" gnus-summary-rescan-group t] + ["Update dribble" gnus-summary-save-newsrc t]))) + + (run-hooks 'gnus-summary-menu-hook))) + +(defun gnus-score-set-default (var value) + "A version of set that updates the GNU Emacs menu-bar." + (set var value) + ;; It is the message that forces the active status to be updated. + (message "")) + +(defun gnus-make-score-map (type) + "Make a summary score map of type TYPE." + (if t + nil + (let ((headers '(("author" "from" string) + ("subject" "subject" string) + ("article body" "body" string) + ("article head" "head" string) + ("xref" "xref" string) + ("lines" "lines" number) + ("followups to author" "followup" string))) + (types '((number ("less than" <) + ("greater than" >) + ("equal" =)) + (string ("substring" s) + ("exact string" e) + ("fuzzy string" f) + ("regexp" r)))) + (perms '(("temporary" (current-time-string)) + ("permanent" nil) + ("immediate" now))) + header) + (list + (apply + 'nconc + (list + (if (eq type 'lower) + "Lower score" + "Increase score")) + (let (outh) + (while headers + (setq header (car headers)) + (setq outh + (cons + (apply + 'nconc + (list (car header)) + (let ((ts (cdr (assoc (nth 2 header) types))) + outt) + (while ts + (setq outt + (cons + (apply + 'nconc + (list (caar ts)) + (let ((ps perms) + outp) + (while ps + (setq outp + (cons + (vector + (caar ps) + (list + 'gnus-summary-score-entry + (nth 1 header) + (if (or (string= (nth 1 header) + "head") + (string= (nth 1 header) + "body")) + "" + (list 'gnus-summary-header + (nth 1 header))) + (list 'quote (nth 1 (car ts))) + (list 'gnus-score-default nil) + (nth 1 (car ps)) + t) + t) + outp)) + (setq ps (cdr ps))) + (list (nreverse outp)))) + outt)) + (setq ts (cdr ts))) + (list (nreverse outt)))) + outh)) + (setq headers (cdr headers))) + (list (nreverse outh)))))))) + + + +(defun gnus-summary-mode (&optional group) + "Major mode for reading articles. + +All normal editing commands are switched off. +\\ +Each line in this buffer represents one article. To read an +article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards +and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]', +respectively. + +You can also post articles and send mail from this buffer. To +follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author +of an article, type `\\[gnus-summary-reply]'. + +There are approx. one gazillion commands you can execute in this +buffer; read the info pages for more information (`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-summary-mode-map}" + (interactive) + (when (gnus-visual-p 'summary-menu 'menu) + (gnus-summary-make-menu-bar)) + (kill-all-local-variables) + (gnus-summary-make-local-variables) + (gnus-make-thread-indent-array) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-summary-mode) + (setq mode-name "Summary") + (make-local-variable 'minor-mode-alist) + (use-local-map gnus-summary-mode-map) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) ;Disable modification + (setq truncate-lines t) + (setq selective-display t) + (setq selective-display-ellipses t) ;Display `...' + (gnus-summary-set-display-table) + (gnus-set-default-directory) + (setq gnus-newsgroup-name group) + (make-local-variable 'gnus-summary-line-format) + (make-local-variable 'gnus-summary-line-format-spec) + (make-local-variable 'gnus-summary-mark-positions) + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) + (run-hooks 'gnus-summary-mode-hook) + (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) + (gnus-update-summary-mark-positions)) + +(defun gnus-summary-make-local-variables () + "Make all the local summary buffer variables." + (let ((locals gnus-summary-local-variables) + global local) + (while (setq local (pop locals)) + (if (consp local) + (progn + (if (eq (cdr local) 'global) + ;; Copy the global value of the variable. + (setq global (symbol-value (car local))) + ;; Use the value from the list. + (setq global (eval (cdr local)))) + (make-local-variable (car local)) + (set (car local) global)) + ;; Simple nil-valued local variable. + (make-local-variable local) + (set local nil))))) + +(defun gnus-summary-clear-local-variables () + (let ((locals gnus-summary-local-variables)) + (while locals + (if (consp (car locals)) + (and (vectorp (caar locals)) + (set (caar locals) nil)) + (and (vectorp (car locals)) + (set (car locals) nil))) + (setq locals (cdr locals))))) + +;; Summary data functions. + +(defmacro gnus-data-number (data) + `(car ,data)) + +(defmacro gnus-data-set-number (data number) + `(setcar ,data ,number)) + +(defmacro gnus-data-mark (data) + `(nth 1 ,data)) + +(defmacro gnus-data-set-mark (data mark) + `(setcar (nthcdr 1 ,data) ,mark)) + +(defmacro gnus-data-pos (data) + `(nth 2 ,data)) + +(defmacro gnus-data-set-pos (data pos) + `(setcar (nthcdr 2 ,data) ,pos)) + +(defmacro gnus-data-header (data) + `(nth 3 ,data)) + +(defmacro gnus-data-set-header (data header) + `(setf (nth 3 ,data) ,header)) + +(defmacro gnus-data-level (data) + `(nth 4 ,data)) + +(defmacro gnus-data-unread-p (data) + `(= (nth 1 ,data) gnus-unread-mark)) + +(defmacro gnus-data-read-p (data) + `(/= (nth 1 ,data) gnus-unread-mark)) + +(defmacro gnus-data-pseudo-p (data) + `(consp (nth 3 ,data))) + +(defmacro gnus-data-find (number) + `(assq ,number gnus-newsgroup-data)) + +(defmacro gnus-data-find-list (number &optional data) + `(let ((bdata ,(or data 'gnus-newsgroup-data))) + (memq (assq ,number bdata) + bdata))) + +(defmacro gnus-data-make (number mark pos header level) + `(list ,number ,mark ,pos ,header ,level)) + +(defun gnus-data-enter (after-article number mark pos header level offset) + (let ((data (gnus-data-find-list after-article))) + (unless data + (error "No such article: %d" after-article)) + (setcdr data (cons (gnus-data-make number mark pos header level) + (cdr data))) + (setq gnus-newsgroup-data-reverse nil) + (gnus-data-update-list (cddr data) offset))) + +(defun gnus-data-enter-list (after-article list &optional offset) + (when list + (let ((data (and after-article (gnus-data-find-list after-article))) + (ilist list)) + (or data (not after-article) (error "No such article: %d" after-article)) + ;; Find the last element in the list to be spliced into the main + ;; list. + (while (cdr list) + (setq list (cdr list))) + (if (not data) + (progn + (setcdr list gnus-newsgroup-data) + (setq gnus-newsgroup-data ilist) + (when offset + (gnus-data-update-list (cdr list) offset))) + (setcdr list (cdr data)) + (setcdr data ilist) + (when offset + (gnus-data-update-list (cdr list) offset))) + (setq gnus-newsgroup-data-reverse nil)))) + +(defun gnus-data-remove (article &optional offset) + (let ((data gnus-newsgroup-data)) + (if (= (gnus-data-number (car data)) article) + (progn + (setq gnus-newsgroup-data (cdr gnus-newsgroup-data) + gnus-newsgroup-data-reverse nil) + (when offset + (gnus-data-update-list gnus-newsgroup-data offset))) + (while (cdr data) + (when (= (gnus-data-number (cadr data)) article) + (setcdr data (cddr data)) + (when offset + (gnus-data-update-list (cdr data) offset)) + (setq data nil + gnus-newsgroup-data-reverse nil)) + (setq data (cdr data)))))) + +(defmacro gnus-data-list (backward) + `(if ,backward + (or gnus-newsgroup-data-reverse + (setq gnus-newsgroup-data-reverse + (reverse gnus-newsgroup-data))) + gnus-newsgroup-data)) + +(defun gnus-data-update-list (data offset) + "Add OFFSET to the POS of all data entries in DATA." + (while data + (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data)))) + (setq data (cdr data)))) + +(defun gnus-data-compute-positions () + "Compute the positions of all articles." + (let ((data gnus-newsgroup-data) + pos) + (while data + (when (setq pos (text-property-any + (point-min) (point-max) + 'gnus-number (gnus-data-number (car data)))) + (gnus-data-set-pos (car data) (+ pos 3))) + (setq data (cdr data))))) + +(defun gnus-summary-article-pseudo-p (article) + "Say whether this article is a pseudo article or not." + (not (vectorp (gnus-data-header (gnus-data-find article))))) + +(defmacro gnus-summary-article-sparse-p (article) + "Say whether this article is a sparse article or not." + `(memq ,article gnus-newsgroup-sparse)) + +(defmacro gnus-summary-article-ancient-p (article) + "Say whether this article is a sparse article or not." + `(memq ,article gnus-newsgroup-ancient)) + +(defun gnus-article-parent-p (number) + "Say whether this article is a parent or not." + (let ((data (gnus-data-find-list number))) + (and (cdr data) ; There has to be an article after... + (< (gnus-data-level (car data)) ; And it has to have a higher level. + (gnus-data-level (nth 1 data)))))) + +(defun gnus-article-children (number) + "Return a list of all children to NUMBER." + (let* ((data (gnus-data-find-list number)) + (level (gnus-data-level (car data))) + children) + (setq data (cdr data)) + (while (and data + (= (gnus-data-level (car data)) (1+ level))) + (push (gnus-data-number (car data)) children) + (setq data (cdr data))) + children)) + +(defmacro gnus-summary-skip-intangible () + "If the current article is intangible, then jump to a different article." + '(let ((to (get-text-property (point) 'gnus-intangible))) + (and to (gnus-summary-goto-subject to)))) + +(defmacro gnus-summary-article-intangible-p () + "Say whether this article is intangible or not." + '(get-text-property (point) 'gnus-intangible)) + +(defun gnus-article-read-p (article) + "Say whether ARTICLE is read or not." + (not (or (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-unreads) + (memq article gnus-newsgroup-unselected) + (memq article gnus-newsgroup-dormant)))) + +;; Some summary mode macros. + +(defmacro gnus-summary-article-number () + "The article number of the article on the current line. +If there isn's an article number here, then we return the current +article number." + '(progn + (gnus-summary-skip-intangible) + (or (get-text-property (point) 'gnus-number) + (gnus-summary-last-subject)))) + +(defmacro gnus-summary-article-header (&optional number) + `(gnus-data-header (gnus-data-find + ,(or number '(gnus-summary-article-number))))) + +(defmacro gnus-summary-thread-level (&optional number) + `(if (and (eq gnus-summary-make-false-root 'dummy) + (get-text-property (point) 'gnus-intangible)) + 0 + (gnus-data-level (gnus-data-find + ,(or number '(gnus-summary-article-number)))))) + +(defmacro gnus-summary-article-mark (&optional number) + `(gnus-data-mark (gnus-data-find + ,(or number '(gnus-summary-article-number))))) + +(defmacro gnus-summary-article-pos (&optional number) + `(gnus-data-pos (gnus-data-find + ,(or number '(gnus-summary-article-number))))) + +(defalias 'gnus-summary-subject-string 'gnus-summary-article-subject) +(defmacro gnus-summary-article-subject (&optional number) + "Return current subject string or nil if nothing." + `(let ((headers + ,(if number + `(gnus-data-header (assq ,number gnus-newsgroup-data)) + '(gnus-data-header (assq (gnus-summary-article-number) + gnus-newsgroup-data))))) + (and headers + (vectorp headers) + (mail-header-subject headers)))) + +(defmacro gnus-summary-article-score (&optional number) + "Return current article score." + `(or (cdr (assq ,(or number '(gnus-summary-article-number)) + gnus-newsgroup-scored)) + gnus-summary-default-score 0)) + +(defun gnus-summary-article-children (&optional number) + (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)))) + (level (gnus-data-level (car data))) + l children) + (while (and (setq data (cdr data)) + (> (setq l (gnus-data-level (car data))) level)) + (and (= (1+ level) l) + (push (gnus-data-number (car data)) + children))) + (nreverse children))) + +(defun gnus-summary-article-parent (&optional number) + (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)) + (gnus-data-list t))) + (level (gnus-data-level (car data)))) + (if (zerop level) + () ; This is a root. + ;; We search until we find an article with a level less than + ;; this one. That function has to be the parent. + (while (and (setq data (cdr data)) + (not (< (gnus-data-level (car data)) level)))) + (and data (gnus-data-number (car data)))))) + +(defun gnus-unread-mark-p (mark) + "Say whether MARK is the unread mark." + (= mark gnus-unread-mark)) + +(defun gnus-read-mark-p (mark) + "Say whether MARK is one of the marks that mark as read. +This is all marks except unread, ticked, dormant, and expirable." + (not (or (= mark gnus-unread-mark) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) + (= mark gnus-expirable-mark)))) + +(defmacro gnus-article-mark (number) + `(cond + ((memq ,number gnus-newsgroup-unsendable) gnus-unsendable-mark) + ((memq ,number gnus-newsgroup-undownloaded) gnus-undownloaded-mark) + ((memq ,number gnus-newsgroup-downloadable) gnus-downloadable-mark) + ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark) + ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark) + ((memq ,number gnus-newsgroup-dormant) gnus-dormant-mark) + ((memq ,number gnus-newsgroup-expirable) gnus-expirable-mark) + (t (or (cdr (assq ,number gnus-newsgroup-reads)) + gnus-ancient-mark)))) + +;; Saving hidden threads. + +(put 'gnus-save-hidden-threads 'lisp-indent-function 0) +(put 'gnus-save-hidden-threads 'edebug-form-spec '(body)) + +(defmacro gnus-save-hidden-threads (&rest forms) + "Save hidden threads, eval FORMS, and restore the hidden threads." + (let ((config (make-symbol "config"))) + `(let ((,config (gnus-hidden-threads-configuration))) + (unwind-protect + (save-excursion + ,@forms) + (gnus-restore-hidden-threads-configuration ,config))))) + +(defun gnus-hidden-threads-configuration () + "Return the current hidden threads configuration." + (save-excursion + (let (config) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (push (1- (point)) config)) + config))) + +(defun gnus-restore-hidden-threads-configuration (config) + "Restore hidden threads configuration from CONFIG." + (let (point buffer-read-only) + (while (setq point (pop config)) + (when (and (< point (point-max)) + (goto-char point) + (= (following-char) ?\n)) + (subst-char-in-region point (1+ point) ?\n ?\r))))) + +;; Various summary mode internalish functions. + +(defun gnus-mouse-pick-article (e) + (interactive "e") + (mouse-set-point e) + (gnus-summary-next-page nil t)) + +(defun gnus-summary-set-display-table () + ;; Change the display table. Odd characters have a tendency to mess + ;; up nicely formatted displays - we make all possible glyphs + ;; display only a single character. + + ;; We start from the standard display table, if any. + (let ((table (or (copy-sequence standard-display-table) + (make-display-table))) + (i 32)) + ;; Nix out all the control chars... + (while (>= (setq i (1- i)) 0) + (aset table i [??])) + ;; ... but not newline and cr, of course. (cr is necessary for the + ;; selective display). + (aset table ?\n nil) + (aset table ?\r nil) + ;; We nix out any glyphs over 126 that are not set already. + (let ((i 256)) + (while (>= (setq i (1- i)) 127) + ;; Only modify if the entry is nil. + (unless (aref table i) + (aset table i [??])))) + (setq buffer-display-table table))) + +(defun gnus-summary-setup-buffer (group) + "Initialize summary buffer." + (let ((buffer (concat "*Summary " group "*"))) + (if (get-buffer buffer) + (progn + (set-buffer buffer) + (setq gnus-summary-buffer (current-buffer)) + (not gnus-newsgroup-prepared)) + ;; Fix by Sudish Joseph + (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer))) + (gnus-add-current-to-buffer-list) + (gnus-summary-mode group) + (when gnus-carpal + (gnus-carpal-setup-buffer 'summary)) + (unless gnus-single-article-buffer + (make-local-variable 'gnus-article-buffer) + (make-local-variable 'gnus-article-current) + (make-local-variable 'gnus-original-article-buffer)) + (setq gnus-newsgroup-name group) + t))) + +(defun gnus-set-global-variables () + ;; Set the global equivalents of the summary buffer-local variables + ;; to the latest values they had. These reflect the summary buffer + ;; that was in action when the last article was fetched. + (when (eq major-mode 'gnus-summary-mode) + (setq gnus-summary-buffer (current-buffer)) + (let ((name gnus-newsgroup-name) + (marked gnus-newsgroup-marked) + (unread gnus-newsgroup-unreads) + (headers gnus-current-headers) + (data gnus-newsgroup-data) + (summary gnus-summary-buffer) + (article-buffer gnus-article-buffer) + (original gnus-original-article-buffer) + (gac gnus-article-current) + (reffed gnus-reffed-article-number) + (score-file gnus-current-score-file)) + (save-excursion + (set-buffer gnus-group-buffer) + (setq gnus-newsgroup-name name) + (setq gnus-newsgroup-marked marked) + (setq gnus-newsgroup-unreads unread) + (setq gnus-current-headers headers) + (setq gnus-newsgroup-data data) + (setq gnus-article-current gac) + (setq gnus-summary-buffer summary) + (setq gnus-article-buffer article-buffer) + (setq gnus-original-article-buffer original) + (setq gnus-reffed-article-number reffed) + (setq gnus-current-score-file score-file) + ;; The article buffer also has local variables. + (when (gnus-buffer-live-p gnus-article-buffer) + (set-buffer gnus-article-buffer) + (setq gnus-summary-buffer summary)))))) + +(defun gnus-summary-article-unread-p (article) + "Say whether ARTICLE is unread or not." + (memq article gnus-newsgroup-unreads)) + +(defun gnus-summary-first-article-p (&optional article) + "Return whether ARTICLE is the first article in the buffer." + (if (not (setq article (or article (gnus-summary-article-number)))) + nil + (eq article (caar gnus-newsgroup-data)))) + +(defun gnus-summary-last-article-p (&optional article) + "Return whether ARTICLE is the last article in the buffer." + (if (not (setq article (or article (gnus-summary-article-number)))) + t ; All non-existent numbers are the last article. :-) + (not (cdr (gnus-data-find-list article))))) + +(defun gnus-make-thread-indent-array () + (let ((n 200)) + (unless (and gnus-thread-indent-array + (= gnus-thread-indent-level gnus-thread-indent-array-level)) + (setq gnus-thread-indent-array (make-vector 201 "") + gnus-thread-indent-array-level gnus-thread-indent-level) + (while (>= n 0) + (aset gnus-thread-indent-array n + (make-string (* n gnus-thread-indent-level) ? )) + (setq n (1- n)))))) + +(defun gnus-update-summary-mark-positions () + "Compute where the summary marks are to go." + (save-excursion + (when (and gnus-summary-buffer + (get-buffer gnus-summary-buffer) + (buffer-name (get-buffer gnus-summary-buffer))) + (set-buffer gnus-summary-buffer)) + (let ((gnus-replied-mark 129) + (gnus-score-below-mark 130) + (gnus-score-over-mark 130) + (gnus-download-mark 131) + (spec gnus-summary-line-format-spec) + thread gnus-visual pos) + (save-excursion + (gnus-set-work-buffer) + (let ((gnus-summary-line-format-spec spec) + (gnus-newsgroup-downloadable '((0 . t)))) + (gnus-summary-insert-line + [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) + (goto-char (point-min)) + (setq pos (list (cons 'unread (and (search-forward "\200" nil t) + (- (point) 2))))) + (goto-char (point-min)) + (push (cons 'replied (and (search-forward "\201" nil t) + (- (point) 2))) + pos) + (goto-char (point-min)) + (push (cons 'score (and (search-forward "\202" nil t) (- (point) 2))) + pos) + (goto-char (point-min)) + (push (cons 'download + (and (search-forward "\203" nil t) (- (point) 2))) + pos))) + (setq gnus-summary-mark-positions pos)))) + +(defun gnus-summary-insert-dummy-line (gnus-tmp-subject gnus-tmp-number) + "Insert a dummy root in the summary buffer." + (beginning-of-line) + (gnus-add-text-properties + (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) + (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) + +(defun gnus-summary-insert-line (gnus-tmp-header + gnus-tmp-level gnus-tmp-current + gnus-tmp-unread gnus-tmp-replied + gnus-tmp-expirable gnus-tmp-subject-or-nil + &optional gnus-tmp-dummy gnus-tmp-score + gnus-tmp-process) + (let* ((gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level)) + (gnus-tmp-lines (mail-header-lines gnus-tmp-header)) + (gnus-tmp-score (or gnus-tmp-score gnus-summary-default-score 0)) + (gnus-tmp-score-char + (if (or (null gnus-summary-default-score) + (<= (abs (- gnus-tmp-score gnus-summary-default-score)) + gnus-summary-zcore-fuzz)) + ? + (if (< gnus-tmp-score gnus-summary-default-score) + gnus-score-below-mark gnus-score-over-mark))) + (gnus-tmp-replied + (cond (gnus-tmp-process gnus-process-mark) + ((memq gnus-tmp-current gnus-newsgroup-cached) + gnus-cached-mark) + (gnus-tmp-replied gnus-replied-mark) + ((memq gnus-tmp-current gnus-newsgroup-saved) + gnus-saved-mark) + (t gnus-unread-mark))) + (gnus-tmp-from (mail-header-from gnus-tmp-header)) + (gnus-tmp-name + (cond + ((string-match "<[^>]+> *$" gnus-tmp-from) + (let ((beg (match-beginning 0))) + (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) + (substring gnus-tmp-from (1+ (match-beginning 0)) + (1- (match-end 0)))) + (substring gnus-tmp-from 0 beg)))) + ((string-match "(.+)" gnus-tmp-from) + (substring gnus-tmp-from + (1+ (match-beginning 0)) (1- (match-end 0)))) + (t gnus-tmp-from))) + (gnus-tmp-subject (mail-header-subject gnus-tmp-header)) + (gnus-tmp-number (mail-header-number gnus-tmp-header)) + (gnus-tmp-opening-bracket (if gnus-tmp-dummy ?\< ?\[)) + (gnus-tmp-closing-bracket (if gnus-tmp-dummy ?\> ?\])) + (buffer-read-only nil)) + (when (string= gnus-tmp-name "") + (setq gnus-tmp-name gnus-tmp-from)) + (unless (numberp gnus-tmp-lines) + (setq gnus-tmp-lines 0)) + (gnus-put-text-property + (point) + (progn (eval gnus-summary-line-format-spec) (point)) + 'gnus-number gnus-tmp-number) + (when (gnus-visual-p 'summary-highlight 'highlight) + (forward-line -1) + (run-hooks 'gnus-summary-update-hook) + (forward-line 1)))) + +(defun gnus-summary-update-line (&optional dont-update) + ;; Update summary line after change. + (when (and gnus-summary-default-score + (not gnus-summary-inhibit-highlight)) + (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion. + (article (gnus-summary-article-number)) + (score (gnus-summary-article-score article))) + (unless dont-update + (if (and gnus-summary-mark-below + (< (gnus-summary-article-score) + gnus-summary-mark-below)) + ;; This article has a low score, so we mark it as read. + (when (memq article gnus-newsgroup-unreads) + (gnus-summary-mark-article-as-read gnus-low-score-mark)) + (when (eq (gnus-summary-article-mark) gnus-low-score-mark) + ;; This article was previously marked as read on account + ;; of a low score, but now it has risen, so we mark it as + ;; unread. + (gnus-summary-mark-article-as-unread gnus-unread-mark))) + (gnus-summary-update-mark + (if (or (null gnus-summary-default-score) + (<= (abs (- score gnus-summary-default-score)) + gnus-summary-zcore-fuzz)) + ? + (if (< score gnus-summary-default-score) + gnus-score-below-mark gnus-score-over-mark)) + 'score)) + ;; Do visual highlighting. + (when (gnus-visual-p 'summary-highlight 'highlight) + (run-hooks 'gnus-summary-update-hook))))) + +(defvar gnus-tmp-new-adopts nil) + +(defun gnus-summary-number-of-articles-in-thread (thread &optional level char) + "Return the number of articles in THREAD. +This may be 0 in some cases -- if none of the articles in +the thread are to be displayed." + (let* ((number + ;; Fix by Luc Van Eycken . + (cond + ((not (listp thread)) + 1) + ((and (consp thread) (cdr thread)) + (apply + '+ 1 (mapcar + 'gnus-summary-number-of-articles-in-thread (cdr thread)))) + ((null thread) + 1) + ((memq (mail-header-number (car thread)) gnus-newsgroup-limit) + 1) + (t 0)))) + (when (and level (zerop level) gnus-tmp-new-adopts) + (incf number + (apply '+ (mapcar + 'gnus-summary-number-of-articles-in-thread + gnus-tmp-new-adopts)))) + (if char + (if (> number 1) gnus-not-empty-thread-mark + gnus-empty-thread-mark) + number))) + +(defun gnus-summary-set-local-parameters (group) + "Go through the local params of GROUP and set all variable specs in that list." + (let ((params (gnus-group-find-parameter group)) + elem) + (while params + (setq elem (car params) + params (cdr params)) + (and (consp elem) ; Has to be a cons. + (consp (cdr elem)) ; The cdr has to be a list. + (symbolp (car elem)) ; Has to be a symbol in there. + (not (memq (car elem) + '(quit-config to-address to-list to-group))) + (ignore-errors ; So we set it. + (make-local-variable (car elem)) + (set (car elem) (eval (nth 1 elem)))))))) + +(defun gnus-summary-read-group (group &optional show-all no-article + kill-buffer no-display) + "Start reading news in newsgroup GROUP. +If SHOW-ALL is non-nil, already read articles are also listed. +If NO-ARTICLE is non-nil, no article is selected initially. +If NO-DISPLAY, don't generate a summary buffer." + (let (result) + (while (and group + (null (setq result + (let ((gnus-auto-select-next nil)) + (or (gnus-summary-read-group-1 + group show-all no-article + kill-buffer no-display) + (setq show-all nil))))) + (eq gnus-auto-select-next 'quietly)) + (set-buffer gnus-group-buffer) + (if (not (equal group (gnus-group-group-name))) + (setq group (gnus-group-group-name)) + (setq group nil))) + result)) + +(defun gnus-summary-read-group-1 (group show-all no-article + kill-buffer no-display) + ;; Killed foreign groups can't be entered. + (when (and (not (gnus-group-native-p group)) + (not (gnus-gethash group gnus-newsrc-hashtb))) + (error "Dead non-native groups can't be entered")) + (gnus-message 5 "Retrieving newsgroup: %s..." group) + (let* ((new-group (gnus-summary-setup-buffer group)) + (quit-config (gnus-group-quit-config group)) + (did-select (and new-group (gnus-select-newsgroup group show-all)))) + (cond + ;; This summary buffer exists already, so we just select it. + ((not new-group) + (gnus-set-global-variables) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + (gnus-configure-windows 'summary 'force) + (gnus-set-mode-line 'summary) + (gnus-summary-position-point) + (message "") + t) + ;; We couldn't select this group. + ((null did-select) + (when (and (eq major-mode 'gnus-summary-mode) + (not (equal (current-buffer) kill-buffer))) + (kill-buffer (current-buffer)) + (if (not quit-config) + (progn + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group group) + (gnus-group-next-unread-group 1)) + (gnus-handle-ephemeral-exit quit-config))) + (gnus-message 3 "Can't select group") + nil) + ;; The user did a `C-g' while prompting for number of articles, + ;; so we exit this group. + ((eq did-select 'quit) + (and (eq major-mode 'gnus-summary-mode) + (not (equal (current-buffer) kill-buffer)) + (kill-buffer (current-buffer))) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + (if (not quit-config) + (progn + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group group) + (gnus-group-next-unread-group 1) + (gnus-configure-windows 'group 'force)) + (gnus-handle-ephemeral-exit quit-config)) + ;; Finally signal the quit. + (signal 'quit nil)) + ;; The group was successfully selected. + (t + (gnus-set-global-variables) + ;; Save the active value in effect when the group was entered. + (setq gnus-newsgroup-active + (gnus-copy-sequence + (gnus-active gnus-newsgroup-name))) + ;; You can change the summary buffer in some way with this hook. + (run-hooks 'gnus-select-group-hook) + ;; Set any local variables in the group parameters. + (gnus-summary-set-local-parameters gnus-newsgroup-name) + (gnus-update-format-specifications + nil 'summary 'summary-mode 'summary-dummy) + ;; Do score processing. + (when gnus-use-scoring + (gnus-possibly-score-headers)) + ;; Check whether to fill in the gaps in the threads. + (when gnus-build-sparse-threads + (gnus-build-sparse-threads)) + ;; Find the initial limit. + (if gnus-show-threads + (if show-all + (let ((gnus-newsgroup-dormant nil)) + (gnus-summary-initial-limit show-all)) + (gnus-summary-initial-limit show-all)) + (setq gnus-newsgroup-limit + (mapcar + (lambda (header) (mail-header-number header)) + gnus-newsgroup-headers))) + ;; Generate the summary buffer. + (unless no-display + (gnus-summary-prepare)) + (when gnus-use-trees + (gnus-tree-open group) + (setq gnus-summary-highlight-line-function + 'gnus-tree-highlight-article)) + ;; If the summary buffer is empty, but there are some low-scored + ;; articles or some excluded dormants, we include these in the + ;; buffer. + (when (and (zerop (buffer-size)) + (not no-display)) + (cond (gnus-newsgroup-dormant + (gnus-summary-limit-include-dormant)) + ((and gnus-newsgroup-scored show-all) + (gnus-summary-limit-include-expunged t)))) + ;; Function `gnus-apply-kill-file' must be called in this hook. + (run-hooks 'gnus-apply-kill-hook) + (if (and (zerop (buffer-size)) + (not no-display)) + (progn + ;; This newsgroup is empty. + (gnus-summary-catchup-and-exit nil t) + (gnus-message 6 "No unread news") + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + ;; Return nil from this function. + nil) + ;; Hide conversation thread subtrees. We cannot do this in + ;; gnus-summary-prepare-hook since kill processing may not + ;; work with hidden articles. + (and gnus-show-threads + gnus-thread-hide-subtree + (gnus-summary-hide-all-threads)) + ;; Show first unread article if requested. + (if (and (not no-article) + (not no-display) + gnus-newsgroup-unreads + gnus-auto-select-first) + (unless (if (eq gnus-auto-select-first 'best) + (gnus-summary-best-unread-article) + (gnus-summary-first-unread-article)) + (gnus-configure-windows 'summary)) + ;; Don't select any articles, just move point to the first + ;; article in the group. + (goto-char (point-min)) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + (gnus-configure-windows 'summary 'force)) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + (when (get-buffer-window gnus-group-buffer t) + ;; Gotta use windows, because recenter does weird stuff if + ;; the current buffer ain't the displayed window. + (let ((owin (selected-window))) + (select-window (get-buffer-window gnus-group-buffer t)) + (when (gnus-group-goto-group group) + (recenter)) + (select-window owin))) + ;; Mark this buffer as "prepared". + (setq gnus-newsgroup-prepared t) + t))))) + +(defun gnus-summary-prepare () + "Generate the summary buffer." + (interactive) + (let ((buffer-read-only nil)) + (erase-buffer) + (setq gnus-newsgroup-data nil + gnus-newsgroup-data-reverse nil) + (run-hooks 'gnus-summary-generate-hook) + ;; Generate the buffer, either with threads or without. + (when gnus-newsgroup-headers + (gnus-summary-prepare-threads + (if gnus-show-threads + (gnus-sort-gathered-threads + (funcall gnus-summary-thread-gathering-function + (gnus-sort-threads + (gnus-cut-threads (gnus-make-threads))))) + ;; Unthreaded display. + (gnus-sort-articles gnus-newsgroup-headers)))) + (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data)) + ;; Call hooks for modifying summary buffer. + (goto-char (point-min)) + (run-hooks 'gnus-summary-prepare-hook))) + +(defsubst gnus-general-simplify-subject (subject) + "Simply subject by the same rules as gnus-gather-threads-by-subject." + (setq subject + (cond + ;; Truncate the subject. + (gnus-simplify-subject-functions + (gnus-map-function gnus-simplify-subject-functions subject)) + ((numberp gnus-summary-gather-subject-limit) + (setq subject (gnus-simplify-subject-re subject)) + (if (> (length subject) gnus-summary-gather-subject-limit) + (substring subject 0 gnus-summary-gather-subject-limit) + subject)) + ;; Fuzzily simplify it. + ((eq 'fuzzy gnus-summary-gather-subject-limit) + (gnus-simplify-subject-fuzzy subject)) + ;; Just remove the leading "Re:". + (t + (gnus-simplify-subject-re subject)))) + + (if (and gnus-summary-gather-exclude-subject + (string-match gnus-summary-gather-exclude-subject subject)) + nil ; This article shouldn't be gathered + subject)) + +(defun gnus-summary-simplify-subject-query () + "Query where the respool algorithm would put this article." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (message (gnus-general-simplify-subject (gnus-summary-article-subject)))) + +(defun gnus-gather-threads-by-subject (threads) + "Gather threads by looking at Subject headers." + (if (not gnus-summary-make-false-root) + threads + (let ((hashtb (gnus-make-hashtable 1024)) + (prev threads) + (result threads) + subject hthread whole-subject) + (while threads + (setq subject (gnus-general-simplify-subject + (setq whole-subject (mail-header-subject + (caar threads))))) + (when subject + (if (setq hthread (gnus-gethash subject hashtb)) + (progn + ;; We enter a dummy root into the thread, if we + ;; haven't done that already. + (unless (stringp (caar hthread)) + (setcar hthread (list whole-subject (car hthread)))) + ;; We add this new gathered thread to this gathered + ;; thread. + (setcdr (car hthread) + (nconc (cdar hthread) (list (car threads)))) + ;; Remove it from the list of threads. + (setcdr prev (cdr threads)) + (setq threads prev)) + ;; Enter this thread into the hash table. + (gnus-sethash subject threads hashtb))) + (setq prev threads) + (setq threads (cdr threads))) + result))) + +(defun gnus-gather-threads-by-references (threads) + "Gather threads by looking at References headers." + (let ((idhashtb (gnus-make-hashtable 1024)) + (thhashtb (gnus-make-hashtable 1024)) + (prev threads) + (result threads) + ids references id gthread gid entered ref) + (while threads + (when (setq references (mail-header-references (caar threads))) + (setq id (mail-header-id (caar threads)) + ids (gnus-split-references references) + entered nil) + (while (setq ref (pop ids)) + (setq ids (delete ref ids)) + (if (not (setq gid (gnus-gethash ref idhashtb))) + (progn + (gnus-sethash ref id idhashtb) + (gnus-sethash id threads thhashtb)) + (setq gthread (gnus-gethash gid thhashtb)) + (unless entered + ;; We enter a dummy root into the thread, if we + ;; haven't done that already. + (unless (stringp (caar gthread)) + (setcar gthread (list (mail-header-subject (caar gthread)) + (car gthread)))) + ;; We add this new gathered thread to this gathered + ;; thread. + (setcdr (car gthread) + (nconc (cdar gthread) (list (car threads))))) + ;; Add it into the thread hash table. + (gnus-sethash id gthread thhashtb) + (setq entered t) + ;; Remove it from the list of threads. + (setcdr prev (cdr threads)) + (setq threads prev)))) + (setq prev threads) + (setq threads (cdr threads))) + result)) + +(defun gnus-sort-gathered-threads (threads) + "Sort subtreads inside each gathered thread by article number." + (let ((result threads)) + (while threads + (when (stringp (caar threads)) + (setcdr (car threads) + (sort (cdar threads) 'gnus-thread-sort-by-number))) + (setq threads (cdr threads))) + result)) + +(defun gnus-thread-loop-p (root thread) + "Say whether ROOT is in THREAD." + (let ((stack (list thread)) + (infloop 0) + th) + (while (setq thread (pop stack)) + (setq th (cdr thread)) + (while (and th + (not (eq (caar th) root))) + (pop th)) + (if th + ;; We have found a loop. + (let (ref-dep) + (setcdr thread (delq (car th) (cdr thread))) + (if (boundp (setq ref-dep (intern "none" + gnus-newsgroup-dependencies))) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (car th)))) + (set ref-dep (list nil (car th)))) + (setq infloop 1 + stack nil)) + ;; Push all the subthreads onto the stack. + (push (cdr thread) stack))) + infloop)) + +(defun gnus-make-threads () + "Go through the dependency hashtb and find the roots. Return all threads." + (let (threads) + (while (catch 'infloop + (mapatoms + (lambda (refs) + ;; Deal with self-referencing References loops. + (when (and (car (symbol-value refs)) + (not (zerop + (apply + '+ + (mapcar + (lambda (thread) + (gnus-thread-loop-p + (car (symbol-value refs)) thread)) + (cdr (symbol-value refs))))))) + (setq threads nil) + (throw 'infloop t)) + (unless (car (symbol-value refs)) + ;; These threads do not refer back to any other articles, + ;; so they're roots. + (setq threads (append (cdr (symbol-value refs)) threads)))) + gnus-newsgroup-dependencies))) + threads)) + +(defun gnus-build-sparse-threads () + (let ((headers gnus-newsgroup-headers) + (deps gnus-newsgroup-dependencies) + header references generation relations + cthread subject child end pthread relation new-child) + ;; First we create an alist of generations/relations, where + ;; generations is how much we trust the relation, and the relation + ;; is parent/child. + (gnus-message 7 "Making sparse threads...") + (save-excursion + (nnheader-set-temp-buffer " *gnus sparse threads*") + (while (setq header (pop headers)) + (when (and (setq references (mail-header-references header)) + (not (string= references ""))) + (insert references) + (setq child (mail-header-id header) + subject (mail-header-subject header)) + (setq generation 0) + (while (search-backward ">" nil t) + (setq end (1+ (point))) + (when (search-backward "<" nil t) + (unless (string= (setq new-child (buffer-substring (point) end)) + child) + (push (list (incf generation) + child (setq child new-child) + subject) + relations)))) + (push (list (1+ generation) child nil subject) relations) + (erase-buffer))) + (kill-buffer (current-buffer))) + ;; Sort over trustworthiness. + (setq relations (sort relations 'car-less-than-car)) + (while (setq relation (pop relations)) + (when (if (boundp (setq cthread (intern (cadr relation) deps))) + (unless (car (symbol-value cthread)) + ;; Make this article the parent of these threads. + (setcar (symbol-value cthread) + (vector gnus-reffed-article-number + (cadddr relation) + "" "" + (cadr relation) + (or (caddr relation) "") 0 0 ""))) + (set cthread (list (vector gnus-reffed-article-number + (cadddr relation) + "" "" (cadr relation) + (or (caddr relation) "") 0 0 "")))) + (push gnus-reffed-article-number gnus-newsgroup-limit) + (push gnus-reffed-article-number gnus-newsgroup-sparse) + (push (cons gnus-reffed-article-number gnus-sparse-mark) + gnus-newsgroup-reads) + (decf gnus-reffed-article-number) + ;; Make this new thread the child of its parent. + (if (boundp (setq pthread (intern (or (caddr relation) "none") deps))) + (setcdr (symbol-value pthread) + (nconc (cdr (symbol-value pthread)) + (list (symbol-value cthread)))) + (set pthread (list nil (symbol-value cthread)))))) + (gnus-message 7 "Making sparse threads...done"))) + +(defun gnus-build-old-threads () + ;; Look at all the articles that refer back to old articles, and + ;; fetch the headers for the articles that aren't there. This will + ;; build complete threads - if the roots haven't been expired by the + ;; server, that is. + (let (id heads) + (mapatoms + (lambda (refs) + (when (not (car (symbol-value refs))) + (setq heads (cdr (symbol-value refs))) + (while heads + (if (memq (mail-header-number (caar heads)) + gnus-newsgroup-dormant) + (setq heads (cdr heads)) + (setq id (symbol-name refs)) + (while (and (setq id (gnus-build-get-header id)) + (not (car (gnus-gethash + id gnus-newsgroup-dependencies))))) + (setq heads nil))))) + gnus-newsgroup-dependencies))) + +(defun gnus-build-get-header (id) + ;; Look through the buffer of NOV lines and find the header to + ;; ID. Enter this line into the dependencies hash table, and return + ;; the id of the parent article (if any). + (let ((deps gnus-newsgroup-dependencies) + found header) + (prog1 + (save-excursion + (set-buffer nntp-server-buffer) + (let ((case-fold-search nil)) + (goto-char (point-min)) + (while (and (not found) + (search-forward id nil t)) + (beginning-of-line) + (setq found (looking-at + (format "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t%s" + (regexp-quote id)))) + (or found (beginning-of-line 2))) + (when found + (beginning-of-line) + (and + (setq header (gnus-nov-parse-line + (read (current-buffer)) deps)) + (gnus-parent-id (mail-header-references header)))))) + (when header + (let ((number (mail-header-number header))) + (push number gnus-newsgroup-limit) + (push header gnus-newsgroup-headers) + (if (memq number gnus-newsgroup-unselected) + (progn + (push number gnus-newsgroup-unreads) + (setq gnus-newsgroup-unselected + (delq number gnus-newsgroup-unselected))) + (push number gnus-newsgroup-ancient))))))) + +(defun gnus-build-all-threads () + "Read all the headers." + (let ((deps gnus-newsgroup-dependencies) + (gnus-summary-ignore-duplicates t) + found header article) + (save-excursion + (set-buffer nntp-server-buffer) + (let ((case-fold-search nil)) + (goto-char (point-min)) + (while (not (eobp)) + (ignore-errors + (setq article (read (current-buffer))) + (setq header (gnus-nov-parse-line article deps))) + (when header + (push header gnus-newsgroup-headers) + (if (memq (setq article (mail-header-number header)) + gnus-newsgroup-unselected) + (progn + (push article gnus-newsgroup-unreads) + (setq gnus-newsgroup-unselected + (delq article gnus-newsgroup-unselected))) + (push article gnus-newsgroup-ancient)) + (forward-line 1))))))) + +(defun gnus-summary-update-article-line (article header) + "Update the line for ARTICLE using HEADERS." + (let* ((id (mail-header-id header)) + (thread (gnus-id-to-thread id))) + (unless thread + (error "Article in no thread")) + ;; Update the thread. + (setcar thread header) + (gnus-summary-goto-subject article) + (let* ((datal (gnus-data-find-list article)) + (data (car datal)) + (length (when (cdr datal) + (- (gnus-data-pos data) + (gnus-data-pos (cadr datal))))) + (buffer-read-only nil) + (level (gnus-summary-thread-level))) + (gnus-delete-line) + (gnus-summary-insert-line + header level nil (gnus-article-mark article) + (memq article gnus-newsgroup-replied) + (memq article gnus-newsgroup-expirable) + ;; Only insert the Subject string when it's different + ;; from the previous Subject string. + (if (gnus-subject-equal + (condition-case () + (mail-header-subject + (gnus-data-header + (cadr + (gnus-data-find-list + article + (gnus-data-list t))))) + ;; Error on the side of excessive subjects. + (error "")) + (mail-header-subject header)) + "" + (mail-header-subject header)) + nil (cdr (assq article gnus-newsgroup-scored)) + (memq article gnus-newsgroup-processable)) + (when length + (gnus-data-update-list + (cdr datal) (- length (- (gnus-data-pos data) (point)))))))) + +(defun gnus-summary-update-article (article &optional iheader) + "Update ARTICLE in the summary buffer." + (set-buffer gnus-summary-buffer) + (let* ((header (or iheader (gnus-summary-article-header article))) + (id (mail-header-id header)) + (data (gnus-data-find article)) + (thread (gnus-id-to-thread id)) + (references (mail-header-references header)) + (parent + (gnus-id-to-thread + (or (gnus-parent-id + (when (and references + (not (equal "" references))) + references)) + "none"))) + (buffer-read-only nil) + (old (car thread)) + (number (mail-header-number header)) + pos) + (when thread + ;; !!! Should this be in or not? + (unless iheader + (setcar thread nil)) + (when parent + (delq thread parent)) + (if (gnus-summary-insert-subject id header iheader) + ;; Set the (possibly) new article number in the data structure. + (gnus-data-set-number data (gnus-id-to-article id)) + (setcar thread old) + nil)))) + +(defun gnus-rebuild-thread (id) + "Rebuild the thread containing ID." + (let ((buffer-read-only nil) + old-pos current thread data) + (if (not gnus-show-threads) + (setq thread (list (car (gnus-id-to-thread id)))) + ;; Get the thread this article is part of. + (setq thread (gnus-remove-thread id))) + (setq old-pos (gnus-point-at-bol)) + (setq current (save-excursion + (and (zerop (forward-line -1)) + (gnus-summary-article-number)))) + ;; If this is a gathered thread, we have to go some re-gathering. + (when (stringp (car thread)) + (let ((subject (car thread)) + roots thr) + (setq thread (cdr thread)) + (while thread + (unless (memq (setq thr (gnus-id-to-thread + (gnus-root-id + (mail-header-id (caar thread))))) + roots) + (push thr roots)) + (setq thread (cdr thread))) + ;; We now have all (unique) roots. + (if (= (length roots) 1) + ;; All the loose roots are now one solid root. + (setq thread (car roots)) + (setq thread (cons subject (gnus-sort-threads roots)))))) + (let (threads) + ;; We then insert this thread into the summary buffer. + (let (gnus-newsgroup-data gnus-newsgroup-threads) + (if gnus-show-threads + (gnus-summary-prepare-threads (gnus-cut-threads (list thread))) + (gnus-summary-prepare-unthreaded thread)) + (setq data (nreverse gnus-newsgroup-data)) + (setq threads gnus-newsgroup-threads)) + ;; We splice the new data into the data structure. + (gnus-data-enter-list current data (- (point) old-pos)) + (setq gnus-newsgroup-threads (nconc threads gnus-newsgroup-threads))))) + +(defun gnus-number-to-header (number) + "Return the header for article NUMBER." + (let ((headers gnus-newsgroup-headers)) + (while (and headers + (not (= number (mail-header-number (car headers))))) + (pop headers)) + (when headers + (car headers)))) + +(defun gnus-parent-headers (headers &optional generation) + "Return the headers of the GENERATIONeth parent of HEADERS." + (unless generation + (setq generation 1)) + (let ((parent t) + references) + (while (and parent headers (not (zerop generation))) + (setq references (mail-header-references headers)) + (when (and references + (setq parent (gnus-parent-id references)) + (setq headers (car (gnus-id-to-thread parent)))) + (decf generation))) + headers)) + +(defun gnus-id-to-thread (id) + "Return the (sub-)thread where ID appears." + (gnus-gethash id gnus-newsgroup-dependencies)) + +(defun gnus-id-to-article (id) + "Return the article number of ID." + (let ((thread (gnus-id-to-thread id))) + (when (and thread + (car thread)) + (mail-header-number (car thread))))) + +(defun gnus-id-to-header (id) + "Return the article headers of ID." + (car (gnus-id-to-thread id))) + +(defun gnus-article-displayed-root-p (article) + "Say whether ARTICLE is a root(ish) article." + (let ((level (gnus-summary-thread-level article)) + (refs (mail-header-references (gnus-summary-article-header article))) + particle) + (cond + ((null level) nil) + ((zerop level) t) + ((null refs) t) + ((null (gnus-parent-id refs)) t) + ((and (= 1 level) + (null (setq particle (gnus-id-to-article + (gnus-parent-id refs)))) + (null (gnus-summary-thread-level particle))))))) + +(defun gnus-root-id (id) + "Return the id of the root of the thread where ID appears." + (let (last-id prev) + (while (and id (setq prev (car (gnus-gethash + id gnus-newsgroup-dependencies)))) + (setq last-id id + id (gnus-parent-id (mail-header-references prev)))) + last-id)) + +(defun gnus-articles-in-thread (thread) + "Return the list of articles in THREAD." + (cons (mail-header-number (car thread)) + (apply 'nconc (mapcar 'gnus-articles-in-thread (cdr thread))))) + +(defun gnus-remove-thread (id &optional dont-remove) + "Remove the thread that has ID in it." + (let ((dep gnus-newsgroup-dependencies) + headers thread last-id) + ;; First go up in this thread until we find the root. + (setq last-id (gnus-root-id id)) + (setq headers (list (car (gnus-id-to-thread last-id)) + (caadr (gnus-id-to-thread last-id)))) + ;; We have now found the real root of this thread. It might have + ;; been gathered into some loose thread, so we have to search + ;; through the threads to find the thread we wanted. + (let ((threads gnus-newsgroup-threads) + sub) + (while threads + (setq sub (car threads)) + (if (stringp (car sub)) + ;; This is a gathered thread, so we look at the roots + ;; below it to find whether this article is in this + ;; gathered root. + (progn + (setq sub (cdr sub)) + (while sub + (when (member (caar sub) headers) + (setq thread (car threads) + threads nil + sub nil)) + (setq sub (cdr sub)))) + ;; It's an ordinary thread, so we check it. + (when (eq (car sub) (car headers)) + (setq thread sub + threads nil))) + (setq threads (cdr threads))) + ;; If this article is in no thread, then it's a root. + (if thread + (unless dont-remove + (setq gnus-newsgroup-threads (delq thread gnus-newsgroup-threads))) + (setq thread (gnus-gethash last-id dep))) + (when thread + (prog1 + thread ; We return this thread. + (unless dont-remove + (if (stringp (car thread)) + (progn + ;; If we use dummy roots, then we have to remove the + ;; dummy root as well. + (when (eq gnus-summary-make-false-root 'dummy) + (gnus-delete-line) + (gnus-data-compute-positions)) + (setq thread (cdr thread)) + (while thread + (gnus-remove-thread-1 (car thread)) + (setq thread (cdr thread)))) + (gnus-remove-thread-1 thread)))))))) + +(defun gnus-remove-thread-1 (thread) + "Remove the thread THREAD recursively." + (let ((number (mail-header-number (pop thread))) + d) + (setq thread (reverse thread)) + (while thread + (gnus-remove-thread-1 (pop thread))) + (when (setq d (gnus-data-find number)) + (goto-char (gnus-data-pos d)) + (gnus-data-remove + number + (- (gnus-point-at-bol) + (prog1 + (1+ (gnus-point-at-eol)) + (gnus-delete-line))))))) + +(defun gnus-sort-threads (threads) + "Sort THREADS." + (if (not gnus-thread-sort-functions) + threads + (gnus-message 7 "Sorting threads...") + (prog1 + (sort threads (gnus-make-sort-function gnus-thread-sort-functions)) + (gnus-message 7 "Sorting threads...done")))) + +(defun gnus-sort-articles (articles) + "Sort ARTICLES." + (when gnus-article-sort-functions + (gnus-message 7 "Sorting articles...") + (prog1 + (setq gnus-newsgroup-headers + (sort articles (gnus-make-sort-function + gnus-article-sort-functions))) + (gnus-message 7 "Sorting articles...done")))) + +;; Written by Hallvard B Furuseth . +(defmacro gnus-thread-header (thread) + ;; Return header of first article in THREAD. + ;; Note that THREAD must never, ever be anything else than a variable - + ;; using some other form will lead to serious barfage. + (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) + ;; (8% speedup to gnus-summary-prepare, just for fun :-) + (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ; + (vector thread) 2)) + +(defsubst gnus-article-sort-by-number (h1 h2) + "Sort articles by article number." + (< (mail-header-number h1) + (mail-header-number h2))) + +(defun gnus-thread-sort-by-number (h1 h2) + "Sort threads by root article number." + (gnus-article-sort-by-number + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-lines (h1 h2) + "Sort articles by article Lines header." + (< (mail-header-lines h1) + (mail-header-lines h2))) + +(defun gnus-thread-sort-by-lines (h1 h2) + "Sort threads by root article Lines header." + (gnus-article-sort-by-lines + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-author (h1 h2) + "Sort articles by root author." + (string-lessp + (let ((extract (funcall + gnus-extract-address-components + (mail-header-from h1)))) + (or (car extract) (cadr extract) "")) + (let ((extract (funcall + gnus-extract-address-components + (mail-header-from h2)))) + (or (car extract) (cadr extract) "")))) + +(defun gnus-thread-sort-by-author (h1 h2) + "Sort threads by root author." + (gnus-article-sort-by-author + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-subject (h1 h2) + "Sort articles by root subject." + (string-lessp + (downcase (gnus-simplify-subject-re (mail-header-subject h1))) + (downcase (gnus-simplify-subject-re (mail-header-subject h2))))) + +(defun gnus-thread-sort-by-subject (h1 h2) + "Sort threads by root subject." + (gnus-article-sort-by-subject + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-date (h1 h2) + "Sort articles by root article date." + (gnus-time-less + (gnus-date-get-time (mail-header-date h1)) + (gnus-date-get-time (mail-header-date h2)))) + +(defun gnus-thread-sort-by-date (h1 h2) + "Sort threads by root article date." + (gnus-article-sort-by-date + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-score (h1 h2) + "Sort articles by root article score. +Unscored articles will be counted as having a score of zero." + (> (or (cdr (assq (mail-header-number h1) + gnus-newsgroup-scored)) + gnus-summary-default-score 0) + (or (cdr (assq (mail-header-number h2) + gnus-newsgroup-scored)) + gnus-summary-default-score 0))) + +(defun gnus-thread-sort-by-score (h1 h2) + "Sort threads by root article score." + (gnus-article-sort-by-score + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defun gnus-thread-sort-by-total-score (h1 h2) + "Sort threads by the sum of all scores in the thread. +Unscored articles will be counted as having a score of zero." + (> (gnus-thread-total-score h1) (gnus-thread-total-score h2))) + +(defun gnus-thread-total-score (thread) + ;; This function find the total score of THREAD. + (cond ((null thread) + 0) + ((consp thread) + (if (stringp (car thread)) + (apply gnus-thread-score-function 0 + (mapcar 'gnus-thread-total-score-1 (cdr thread))) + (gnus-thread-total-score-1 thread))) + (t + (gnus-thread-total-score-1 (list thread))))) + +(defun gnus-thread-total-score-1 (root) + ;; This function find the total score of the thread below ROOT. + (setq root (car root)) + (apply gnus-thread-score-function + (or (append + (mapcar 'gnus-thread-total-score + (cdr (gnus-gethash (mail-header-id root) + gnus-newsgroup-dependencies))) + (when (> (mail-header-number root) 0) + (list (or (cdr (assq (mail-header-number root) + gnus-newsgroup-scored)) + gnus-summary-default-score 0)))) + (list gnus-summary-default-score) + '(0)))) + +;; Added by Per Abrahamsen . +(defvar gnus-tmp-prev-subject nil) +(defvar gnus-tmp-false-parent nil) +(defvar gnus-tmp-root-expunged nil) +(defvar gnus-tmp-dummy-line nil) + +(defun gnus-summary-prepare-threads (threads) + "Prepare summary buffer from THREADS and indentation LEVEL. +THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' +or a straight list of headers." + (gnus-message 7 "Generating summary...") + + (setq gnus-newsgroup-threads threads) + (beginning-of-line) + + (let ((gnus-tmp-level 0) + (default-score (or gnus-summary-default-score 0)) + (gnus-visual-p (gnus-visual-p 'summary-highlight 'highlight)) + thread number subject stack state gnus-tmp-gathered beg-match + new-roots gnus-tmp-new-adopts thread-end + gnus-tmp-header gnus-tmp-unread + gnus-tmp-replied gnus-tmp-subject-or-nil + gnus-tmp-dummy gnus-tmp-indentation gnus-tmp-lines gnus-tmp-score + gnus-tmp-score-char gnus-tmp-from gnus-tmp-name + gnus-tmp-number gnus-tmp-opening-bracket gnus-tmp-closing-bracket) + + (setq gnus-tmp-prev-subject nil) + + (if (vectorp (car threads)) + ;; If this is a straight (sic) list of headers, then a + ;; threaded summary display isn't required, so we just create + ;; an unthreaded one. + (gnus-summary-prepare-unthreaded threads) + + ;; Do the threaded display. + + (while (or threads stack gnus-tmp-new-adopts new-roots) + + (if (and (= gnus-tmp-level 0) + (not (setq gnus-tmp-dummy-line nil)) + (or (not stack) + (= (caar stack) 0)) + (not gnus-tmp-false-parent) + (or gnus-tmp-new-adopts new-roots)) + (if gnus-tmp-new-adopts + (setq gnus-tmp-level (if gnus-tmp-root-expunged 0 1) + thread (list (car gnus-tmp-new-adopts)) + gnus-tmp-header (caar thread) + gnus-tmp-new-adopts (cdr gnus-tmp-new-adopts)) + (when new-roots + (setq thread (list (car new-roots)) + gnus-tmp-header (caar thread) + new-roots (cdr new-roots)))) + + (if threads + ;; If there are some threads, we do them before the + ;; threads on the stack. + (setq thread threads + gnus-tmp-header (caar thread)) + ;; There were no current threads, so we pop something off + ;; the stack. + (setq state (car stack) + gnus-tmp-level (car state) + thread (cdr state) + stack (cdr stack) + gnus-tmp-header (caar thread)))) + + (setq gnus-tmp-false-parent nil) + (setq gnus-tmp-root-expunged nil) + (setq thread-end nil) + + (if (stringp gnus-tmp-header) + ;; The header is a dummy root. + (cond + ((eq gnus-summary-make-false-root 'adopt) + ;; We let the first article adopt the rest. + (setq gnus-tmp-new-adopts (nconc gnus-tmp-new-adopts + (cddar thread))) + (setq gnus-tmp-gathered + (nconc (mapcar + (lambda (h) (mail-header-number (car h))) + (cddar thread)) + gnus-tmp-gathered)) + (setq thread (cons (list (caar thread) + (cadar thread)) + (cdr thread))) + (setq gnus-tmp-level -1 + gnus-tmp-false-parent t)) + ((eq gnus-summary-make-false-root 'empty) + ;; We print adopted articles with empty subject fields. + (setq gnus-tmp-gathered + (nconc (mapcar + (lambda (h) (mail-header-number (car h))) + (cddar thread)) + gnus-tmp-gathered)) + (setq gnus-tmp-level -1)) + ((eq gnus-summary-make-false-root 'dummy) + ;; We remember that we probably want to output a dummy + ;; root. + (setq gnus-tmp-dummy-line gnus-tmp-header) + (setq gnus-tmp-prev-subject gnus-tmp-header)) + (t + ;; We do not make a root for the gathered + ;; sub-threads at all. + (setq gnus-tmp-level -1))) + + (setq number (mail-header-number gnus-tmp-header) + subject (mail-header-subject gnus-tmp-header)) + + (cond + ;; If the thread has changed subject, we might want to make + ;; this subthread into a root. + ((and (null gnus-thread-ignore-subject) + (not (zerop gnus-tmp-level)) + gnus-tmp-prev-subject + (not (inline + (gnus-subject-equal gnus-tmp-prev-subject subject)))) + (setq new-roots (nconc new-roots (list (car thread))) + thread-end t + gnus-tmp-header nil)) + ;; If the article lies outside the current limit, + ;; then we do not display it. + ((not (memq number gnus-newsgroup-limit)) + (setq gnus-tmp-gathered + (nconc (mapcar + (lambda (h) (mail-header-number (car h))) + (cdar thread)) + gnus-tmp-gathered)) + (setq gnus-tmp-new-adopts (if (cdar thread) + (append gnus-tmp-new-adopts + (cdar thread)) + gnus-tmp-new-adopts) + thread-end t + gnus-tmp-header nil) + (when (zerop gnus-tmp-level) + (setq gnus-tmp-root-expunged t))) + ;; Perhaps this article is to be marked as read? + ((and gnus-summary-mark-below + (< (or (cdr (assq number gnus-newsgroup-scored)) + default-score) + gnus-summary-mark-below) + ;; Don't touch sparse articles. + (not (gnus-summary-article-sparse-p number)) + (not (gnus-summary-article-ancient-p number))) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads)))) + + (when gnus-tmp-header + ;; We may have an old dummy line to output before this + ;; article. + (when gnus-tmp-dummy-line + (gnus-summary-insert-dummy-line + gnus-tmp-dummy-line (mail-header-number gnus-tmp-header)) + (setq gnus-tmp-dummy-line nil)) + + ;; Compute the mark. + (setq gnus-tmp-unread (gnus-article-mark number)) + + (push (gnus-data-make number gnus-tmp-unread (1+ (point)) + gnus-tmp-header gnus-tmp-level) + gnus-newsgroup-data) + + ;; Actually insert the line. + (setq + gnus-tmp-subject-or-nil + (cond + ((and gnus-thread-ignore-subject + gnus-tmp-prev-subject + (not (inline (gnus-subject-equal + gnus-tmp-prev-subject subject)))) + subject) + ((zerop gnus-tmp-level) + (if (and (eq gnus-summary-make-false-root 'empty) + (memq number gnus-tmp-gathered) + gnus-tmp-prev-subject + (inline (gnus-subject-equal + gnus-tmp-prev-subject subject))) + gnus-summary-same-subject + subject)) + (t gnus-summary-same-subject))) + (if (and (eq gnus-summary-make-false-root 'adopt) + (= gnus-tmp-level 1) + (memq number gnus-tmp-gathered)) + (setq gnus-tmp-opening-bracket ?\< + gnus-tmp-closing-bracket ?\>) + (setq gnus-tmp-opening-bracket ?\[ + gnus-tmp-closing-bracket ?\])) + (setq + gnus-tmp-indentation + (aref gnus-thread-indent-array gnus-tmp-level) + gnus-tmp-lines (mail-header-lines gnus-tmp-header) + gnus-tmp-score (or (cdr (assq number gnus-newsgroup-scored)) + gnus-summary-default-score 0) + gnus-tmp-score-char + (if (or (null gnus-summary-default-score) + (<= (abs (- gnus-tmp-score gnus-summary-default-score)) + gnus-summary-zcore-fuzz)) + ? + (if (< gnus-tmp-score gnus-summary-default-score) + gnus-score-below-mark gnus-score-over-mark)) + gnus-tmp-replied + (cond ((memq number gnus-newsgroup-processable) + gnus-process-mark) + ((memq number gnus-newsgroup-cached) + gnus-cached-mark) + ((memq number gnus-newsgroup-replied) + gnus-replied-mark) + ((memq number gnus-newsgroup-saved) + gnus-saved-mark) + (t gnus-unread-mark)) + gnus-tmp-from (mail-header-from gnus-tmp-header) + gnus-tmp-name + (cond + ((string-match "<[^>]+> *$" gnus-tmp-from) + (setq beg-match (match-beginning 0)) + (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) + (substring gnus-tmp-from (1+ (match-beginning 0)) + (1- (match-end 0)))) + (substring gnus-tmp-from 0 beg-match))) + ((string-match "(.+)" gnus-tmp-from) + (substring gnus-tmp-from + (1+ (match-beginning 0)) (1- (match-end 0)))) + (t gnus-tmp-from))) + (when (string= gnus-tmp-name "") + (setq gnus-tmp-name gnus-tmp-from)) + (unless (numberp gnus-tmp-lines) + (setq gnus-tmp-lines 0)) + (gnus-put-text-property + (point) + (progn (eval gnus-summary-line-format-spec) (point)) + 'gnus-number number) + (when gnus-visual-p + (forward-line -1) + (run-hooks 'gnus-summary-update-hook) + (forward-line 1)) + + (setq gnus-tmp-prev-subject subject))) + + (when (nth 1 thread) + (push (cons (max 0 gnus-tmp-level) (nthcdr 1 thread)) stack)) + (incf gnus-tmp-level) + (setq threads (if thread-end nil (cdar thread))) + (unless threads + (setq gnus-tmp-level 0))))) + (gnus-message 7 "Generating summary...done")) + +(defun gnus-summary-prepare-unthreaded (headers) + "Generate an unthreaded summary buffer based on HEADERS." + (let (header number mark) + + (beginning-of-line) + + (while headers + ;; We may have to root out some bad articles... + (when (memq (setq number (mail-header-number + (setq header (pop headers)))) + gnus-newsgroup-limit) + ;; Mark article as read when it has a low score. + (when (and gnus-summary-mark-below + (< (or (cdr (assq number gnus-newsgroup-scored)) + gnus-summary-default-score 0) + gnus-summary-mark-below) + (not (gnus-summary-article-ancient-p number))) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads))) + + (setq mark (gnus-article-mark number)) + (push (gnus-data-make number mark (1+ (point)) header 0) + gnus-newsgroup-data) + (gnus-summary-insert-line + header 0 number + mark (memq number gnus-newsgroup-replied) + (memq number gnus-newsgroup-expirable) + (mail-header-subject header) nil + (cdr (assq number gnus-newsgroup-scored)) + (memq number gnus-newsgroup-processable)))))) + +(defun gnus-select-newsgroup (group &optional read-all) + "Select newsgroup GROUP. +If READ-ALL is non-nil, all articles in the group are selected." + (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + ;;!!! Dirty hack; should be removed. + (gnus-summary-ignore-duplicates + (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) + t + gnus-summary-ignore-duplicates)) + (info (nth 2 entry)) + articles fetched-articles cached) + + (unless (gnus-check-server + (setq gnus-current-select-method + (gnus-find-method-for-group group))) + (error "Couldn't open server")) + + (or (and entry (not (eq (car entry) t))) ; Either it's active... + (gnus-activate-group group) ; Or we can activate it... + (progn ; Or we bug out. + (when (equal major-mode 'gnus-summary-mode) + (kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + group (gnus-status-message group)))) + + (unless (gnus-request-group group t) + (when (equal major-mode 'gnus-summary-mode) + (kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + group (gnus-status-message group))) + + (setq gnus-newsgroup-name group) + (setq gnus-newsgroup-unselected nil) + (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) + + ;; Adjust and set lists of article marks. + (when info + (gnus-adjust-marked-articles info)) + + ;; Kludge to avoid having cached articles nixed out in virtual groups. + (when (gnus-virtual-group-p group) + (setq cached gnus-newsgroup-cached)) + + (setq gnus-newsgroup-unreads + (gnus-set-difference + (gnus-set-difference gnus-newsgroup-unreads gnus-newsgroup-marked) + gnus-newsgroup-dormant)) + + (setq gnus-newsgroup-processable nil) + + (gnus-update-read-articles group gnus-newsgroup-unreads) + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-group-update-group group)) + + (setq articles (gnus-articles-to-read group read-all)) + + (cond + ((null articles) + ;;(gnus-message 3 "Couldn't select newsgroup -- no articles to display") + 'quit) + ((eq articles 0) nil) + (t + ;; Init the dependencies hash table. + (setq gnus-newsgroup-dependencies + (gnus-make-hashtable (length articles))) + ;; Retrieve the headers and read them in. + (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) + (setq gnus-newsgroup-headers + (if (eq 'nov + (setq gnus-headers-retrieved-by + (gnus-retrieve-headers + articles gnus-newsgroup-name + ;; We might want to fetch old headers, but + ;; not if there is only 1 article. + (and gnus-fetch-old-headers + (or (and + (not (eq gnus-fetch-old-headers 'some)) + (not (numberp gnus-fetch-old-headers))) + (> (length articles) 1)))))) + (gnus-get-newsgroup-headers-xover + articles nil nil gnus-newsgroup-name t) + (gnus-get-newsgroup-headers))) + (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name) + + ;; Kludge to avoid having cached articles nixed out in virtual groups. + (when cached + (setq gnus-newsgroup-cached cached)) + + ;; Suppress duplicates? + (when gnus-suppress-duplicates + (gnus-dup-suppress-articles)) + + ;; Set the initial limit. + (setq gnus-newsgroup-limit (copy-sequence articles)) + ;; Remove canceled articles from the list of unread articles. + (setq gnus-newsgroup-unreads + (gnus-set-sorted-intersection + gnus-newsgroup-unreads + (setq fetched-articles + (mapcar (lambda (headers) (mail-header-number headers)) + gnus-newsgroup-headers)))) + ;; Removed marked articles that do not exist. + (gnus-update-missing-marks + (gnus-sorted-complement fetched-articles articles)) + ;; Let the Gnus agent mark articles as read. + (when gnus-agent + (gnus-agent-get-undownloaded-list)) + ;; We might want to build some more threads first. + (when (and gnus-fetch-old-headers + (eq gnus-headers-retrieved-by 'nov)) + (if (eq gnus-fetch-old-headers 'invisible) + (gnus-build-all-threads) + (gnus-build-old-threads))) + ;; Check whether auto-expire is to be done in this group. + (setq gnus-newsgroup-auto-expire + (gnus-group-auto-expirable-p group)) + ;; Set up the article buffer now, if necessary. + (unless gnus-single-article-buffer + (gnus-article-setup-buffer)) + ;; First and last article in this newsgroup. + (when gnus-newsgroup-headers + (setq gnus-newsgroup-begin + (mail-header-number (car gnus-newsgroup-headers)) + gnus-newsgroup-end + (mail-header-number + (gnus-last-element gnus-newsgroup-headers)))) + ;; GROUP is successfully selected. + (or gnus-newsgroup-headers t))))) + +(defun gnus-articles-to-read (group &optional read-all) + ;; Find out what articles the user wants to read. + (let* ((articles + ;; Select all articles if `read-all' is non-nil, or if there + ;; are no unread articles. + (if (or read-all + (and (zerop (length gnus-newsgroup-marked)) + (zerop (length gnus-newsgroup-unreads))) + (eq (gnus-group-find-parameter group 'display) + 'all)) + (gnus-uncompress-range (gnus-active group)) + (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked + (copy-sequence gnus-newsgroup-unreads)) + '<))) + (scored-list (gnus-killed-articles gnus-newsgroup-killed articles)) + (scored (length scored-list)) + (number (length articles)) + (marked (+ (length gnus-newsgroup-marked) + (length gnus-newsgroup-dormant))) + (select + (cond + ((numberp read-all) + read-all) + (t + (condition-case () + (cond + ((and (or (<= scored marked) (= scored number)) + (numberp gnus-large-newsgroup) + (> number gnus-large-newsgroup)) + (let ((input + (read-string + (format + "How many articles from %s (default %d): " + (gnus-limit-string gnus-newsgroup-name 35) + number)))) + (if (string-match "^[ \t]*$" input) number input))) + ((and (> scored marked) (< scored number) + (> (- scored number) 20)) + (let ((input + (read-string + (format "%s %s (%d scored, %d total): " + "How many articles from" + group scored number)))) + (if (string-match "^[ \t]*$" input) + number input))) + (t number)) + (quit nil)))))) + (setq select (if (stringp select) (string-to-number select) select)) + (if (or (null select) (zerop select)) + select + (if (and (not (zerop scored)) (<= (abs select) scored)) + (progn + (setq articles (sort scored-list '<)) + (setq number (length articles))) + (setq articles (copy-sequence articles))) + + (when (< (abs select) number) + (if (< select 0) + ;; Select the N oldest articles. + (setcdr (nthcdr (1- (abs select)) articles) nil) + ;; Select the N most recent articles. + (setq articles (nthcdr (- number select) articles)))) + (setq gnus-newsgroup-unselected + (gnus-sorted-intersection + gnus-newsgroup-unreads + (gnus-sorted-complement gnus-newsgroup-unreads articles))) + articles))) + +(defun gnus-killed-articles (killed articles) + (let (out) + (while articles + (when (inline (gnus-member-of-range (car articles) killed)) + (push (car articles) out)) + (setq articles (cdr articles))) + out)) + +(defun gnus-uncompress-marks (marks) + "Uncompress the mark ranges in MARKS." + (let ((uncompressed '(score bookmark)) + out) + (while marks + (if (memq (caar marks) uncompressed) + (push (car marks) out) + (push (cons (caar marks) (gnus-uncompress-range (cdar marks))) out)) + (setq marks (cdr marks))) + out)) + +(defun gnus-adjust-marked-articles (info) + "Set all article lists and remove all marks that are no longer legal." + (let* ((marked-lists (gnus-info-marks info)) + (active (gnus-active (gnus-info-group info))) + (min (car active)) + (max (cdr active)) + (types gnus-article-mark-lists) + (uncompressed '(score bookmark killed)) + marks var articles article mark) + + (while marked-lists + (setq marks (pop marked-lists)) + (set (setq var (intern (format "gnus-newsgroup-%s" + (car (rassq (setq mark (car marks)) + types))))) + (if (memq (car marks) uncompressed) (cdr marks) + (gnus-uncompress-range (cdr marks)))) + + (setq articles (symbol-value var)) + + ;; All articles have to be subsets of the active articles. + (cond + ;; Adjust "simple" lists. + ((memq mark '(tick dormant expire reply save)) + (while articles + (when (or (< (setq article (pop articles)) min) (> article max)) + (set var (delq article (symbol-value var)))))) + ;; Adjust assocs. + ((memq mark uncompressed) + (when (not (listp (cdr (symbol-value var)))) + (set var (list (symbol-value var)))) + (when (not (listp (cdr articles))) + (setq articles (list articles))) + (while articles + (when (or (not (consp (setq article (pop articles)))) + (< (car article) min) + (> (car article) max)) + (set var (delq article (symbol-value var)))))))))) + +(defun gnus-update-missing-marks (missing) + "Go through the list of MISSING articles and remove them mark lists." + (when missing + (let ((types gnus-article-mark-lists) + var m) + ;; Go through all types. + (while types + (setq var (intern (format "gnus-newsgroup-%s" (car (pop types))))) + (when (symbol-value var) + ;; This list has articles. So we delete all missing articles + ;; from it. + (setq m missing) + (while m + (set var (delq (pop m) (symbol-value var))))))))) + +(defun gnus-update-marks () + "Enter the various lists of marked articles into the newsgroup info list." + (let ((types gnus-article-mark-lists) + (info (gnus-get-info gnus-newsgroup-name)) + (uncompressed '(score bookmark killed)) + type list newmarked symbol) + (when info + ;; Add all marks lists that are non-nil to the list of marks lists. + (while (setq type (pop types)) + (when (setq list (symbol-value + (setq symbol + (intern (format "gnus-newsgroup-%s" + (car type)))))) + + ;; Get rid of the entries of the articles that have the + ;; default score. + (when (and (eq (cdr type) 'score) + gnus-save-score + list) + (let* ((arts list) + (prev (cons nil list)) + (all prev)) + (while arts + (if (or (not (consp (car arts))) + (= (cdar arts) gnus-summary-default-score)) + (setcdr prev (cdr arts)) + (setq prev arts)) + (setq arts (cdr arts))) + (setq list (cdr all)))) + + (push (cons (cdr type) + (if (memq (cdr type) uncompressed) list + (gnus-compress-sequence + (set symbol (sort list '<)) t))) + newmarked))) + + ;; Enter these new marks into the info of the group. + (if (nthcdr 3 info) + (setcar (nthcdr 3 info) newmarked) + ;; Add the marks lists to the end of the info. + (when newmarked + (setcdr (nthcdr 2 info) (list newmarked)))) + + ;; Cut off the end of the info if there's nothing else there. + (let ((i 5)) + (while (and (> i 2) + (not (nth i info))) + (when (nthcdr (decf i) info) + (setcdr (nthcdr i info) nil))))))) + +(defun gnus-set-mode-line (where) + "This function sets the mode line of the article or summary buffers. +If WHERE is `summary', the summary mode line format will be used." + ;; Is this mode line one we keep updated? + (when (memq where gnus-updated-mode-lines) + (let (mode-string) + (save-excursion + ;; We evaluate this in the summary buffer since these + ;; variables are buffer-local to that buffer. + (set-buffer gnus-summary-buffer) + ;; We bind all these variables that are used in the `eval' form + ;; below. + (let* ((mformat (symbol-value + (intern + (format "gnus-%s-mode-line-format-spec" where)))) + (gnus-tmp-group-name gnus-newsgroup-name) + (gnus-tmp-article-number (or gnus-current-article 0)) + (gnus-tmp-unread gnus-newsgroup-unreads) + (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) + (gnus-tmp-unselected (length gnus-newsgroup-unselected)) + (gnus-tmp-unread-and-unselected + (cond ((and (zerop gnus-tmp-unread-and-unticked) + (zerop gnus-tmp-unselected)) + "") + ((zerop gnus-tmp-unselected) + (format "{%d more}" gnus-tmp-unread-and-unticked)) + (t (format "{%d(+%d) more}" + gnus-tmp-unread-and-unticked + gnus-tmp-unselected)))) + (gnus-tmp-subject + (if (and gnus-current-headers + (vectorp gnus-current-headers)) + (gnus-mode-string-quote + (mail-header-subject gnus-current-headers)) + "")) + bufname-length max-len + gnus-tmp-header);; passed as argument to any user-format-funcs + (setq mode-string (eval mformat)) + (setq bufname-length (if (string-match "%b" mode-string) + (- (length + (buffer-name + (if (eq where 'summary) + nil + (get-buffer gnus-article-buffer)))) + 2) + 0)) + (setq max-len (max 4 (if gnus-mode-non-string-length + (- (window-width) + gnus-mode-non-string-length + bufname-length) + (length mode-string)))) + ;; We might have to chop a bit of the string off... + (when (> (length mode-string) max-len) + (setq mode-string + (concat (gnus-truncate-string mode-string (- max-len 3)) + "..."))) + ;; Pad the mode string a bit. + (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) + ;; Update the mode line. + (setq mode-line-buffer-identification + (gnus-mode-line-buffer-identification (list mode-string))) + (set-buffer-modified-p t)))) + +(defun gnus-create-xref-hashtb (from-newsgroup headers unreads) + "Go through the HEADERS list and add all Xrefs to a hash table. +The resulting hash table is returned, or nil if no Xrefs were found." + (let* ((virtual (gnus-virtual-group-p from-newsgroup)) + (prefix (if virtual "" (gnus-group-real-prefix from-newsgroup))) + (xref-hashtb (gnus-make-hashtable)) + start group entry number xrefs header) + (while headers + (setq header (pop headers)) + (when (and (setq xrefs (mail-header-xref header)) + (not (memq (setq number (mail-header-number header)) + unreads))) + (setq start 0) + (while (string-match "\\([^ ]+\\)[:/]\\([0-9]+\\)" xrefs start) + (setq start (match-end 0)) + (setq group (if prefix + (concat prefix (substring xrefs (match-beginning 1) + (match-end 1))) + (substring xrefs (match-beginning 1) (match-end 1)))) + (setq number + (string-to-int (substring xrefs (match-beginning 2) + (match-end 2)))) + (if (setq entry (gnus-gethash group xref-hashtb)) + (setcdr entry (cons number (cdr entry))) + (gnus-sethash group (cons number nil) xref-hashtb))))) + (and start xref-hashtb))) + +(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) + "Look through all the headers and mark the Xrefs as read." + (let ((virtual (gnus-virtual-group-p from-newsgroup)) + name entry info xref-hashtb idlist method nth4) + (save-excursion + (set-buffer gnus-group-buffer) + (when (setq xref-hashtb + (gnus-create-xref-hashtb from-newsgroup headers unreads)) + (mapatoms + (lambda (group) + (unless (string= from-newsgroup (setq name (symbol-name group))) + (setq idlist (symbol-value group)) + ;; Dead groups are not updated. + (and (prog1 + (setq entry (gnus-gethash name gnus-newsrc-hashtb) + info (nth 2 entry)) + (when (stringp (setq nth4 (gnus-info-method info))) + (setq nth4 (gnus-server-to-method nth4)))) + ;; Only do the xrefs if the group has the same + ;; select method as the group we have just read. + (or (gnus-methods-equal-p + nth4 (gnus-find-method-for-group from-newsgroup)) + virtual + (equal nth4 (setq method (gnus-find-method-for-group + from-newsgroup))) + (and (equal (car nth4) (car method)) + (equal (nth 1 nth4) (nth 1 method)))) + gnus-use-cross-reference + (or (not (eq gnus-use-cross-reference t)) + virtual + ;; Only do cross-references on subscribed + ;; groups, if that is what is wanted. + (<= (gnus-info-level info) gnus-level-subscribed)) + (gnus-group-make-articles-read name idlist)))) + xref-hashtb))))) + +(defun gnus-compute-read-articles (group articles) + (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + (active (gnus-active group)) + ninfo) + (when entry + ;; First peel off all illegal article numbers. + (when active + (let ((ids articles) + id first) + (while (setq id (pop ids)) + (when (and first (> id (cdr active))) + ;; We'll end up in this situation in one particular + ;; obscure situation. If you re-scan a group and get + ;; a new article that is cross-posted to a different + ;; group that has not been re-scanned, you might get + ;; crossposted article that has a higher number than + ;; Gnus believes possible. So we re-activate this + ;; group as well. This might mean doing the + ;; crossposting thingy will *increase* the number + ;; of articles in some groups. Tsk, tsk. + (setq active (or (gnus-activate-group group) active))) + (when (or (> id (cdr active)) + (< id (car active))) + (setq articles (delq id articles)))))) + ;; If the read list is nil, we init it. + (if (and active + (null (gnus-info-read info)) + (> (car active) 1)) + (setq ninfo (cons 1 (1- (car active)))) + (setq ninfo (gnus-info-read info))) + ;; Then we add the read articles to the range. + (gnus-add-to-range + ninfo (setq articles (sort articles '<)))))) + +(defun gnus-group-make-articles-read (group articles) + "Update the info of GROUP to say that ARTICLES are read." + (let* ((num 0) + (entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + (active (gnus-active group)) + range) + (when entry + (setq range (gnus-compute-read-articles group articles)) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-group-update-group ,group t)))) + ;; Add the read articles to the range. + (gnus-info-set-read info range) + ;; Then we have to re-compute how many unread + ;; articles there are in this group. + (when active + (cond + ((not range) + (setq num (- (1+ (cdr active)) (car active)))) + ((not (listp (cdr range))) + (setq num (- (cdr active) (- (1+ (cdr range)) + (car range))))) + (t + (while range + (if (numberp (car range)) + (setq num (1+ num)) + (setq num (+ num (- (1+ (cdar range)) (caar range))))) + (setq range (cdr range))) + (setq num (- (cdr active) num)))) + ;; Update the number of unread articles. + (setcar entry num) + ;; Update the group buffer. + (gnus-group-update-group group t))))) + +(defun gnus-methods-equal-p (m1 m2) + (let ((m1 (or m1 gnus-select-method)) + (m2 (or m2 gnus-select-method))) + (or (equal m1 m2) + (and (eq (car m1) (car m2)) + (or (not (memq 'address (assoc (symbol-name (car m1)) + gnus-valid-select-methods))) + (equal (nth 1 m1) (nth 1 m2))))))) + +(defvar gnus-newsgroup-none-id 0) + +(defun gnus-get-newsgroup-headers (&optional dependencies force-new) + (let ((cur nntp-server-buffer) + (dependencies + (or dependencies + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-dependencies))) + headers id id-dep ref-dep end ref) + (save-excursion + (set-buffer nntp-server-buffer) + ;; Translate all TAB characters into SPACE characters. + (subst-char-in-region (point-min) (point-max) ?\t ? t) + (run-hooks 'gnus-parse-headers-hook) + (let ((case-fold-search t) + in-reply-to header p lines) + (goto-char (point-min)) + ;; Search to the beginning of the next header. Error messages + ;; do not begin with 2 or 3. + (while (re-search-forward "^[23][0-9]+ " nil t) + (setq id nil + ref nil) + ;; This implementation of this function, with nine + ;; search-forwards instead of the one re-search-forward and + ;; a case (which basically was the old function) is actually + ;; about twice as fast, even though it looks messier. You + ;; can't have everything, I guess. Speed and elegance + ;; doesn't always go hand in hand. + (setq + header + (vector + ;; Number. + (prog1 + (read cur) + (end-of-line) + (setq p (point)) + (narrow-to-region (point) + (or (and (search-forward "\n.\n" nil t) + (- (point) 2)) + (point)))) + ;; Subject. + (progn + (goto-char p) + (if (search-forward "\nsubject: " nil t) + ;; 1997/5/4 by MORIOKA Tomohiko + (funcall + gnus-unstructured-field-decoder (nnheader-header-value)) + "(none)")) + ;; From. + (progn + (goto-char p) + (if (search-forward "\nfrom: " nil t) + ;; 1997/5/4 by MORIOKA Tomohiko + (funcall + gnus-structured-field-decoder (nnheader-header-value)) + "(nobody)")) + ;; Date. + (progn + (goto-char p) + (if (search-forward "\ndate: " nil t) + (nnheader-header-value) "")) + ;; Message-ID. + (progn + (goto-char p) + (setq id (if (search-forward "\nmessage-id:" nil t) + (buffer-substring + (1- (or (search-forward "<" nil t) (point))) + (or (search-forward ">" nil t) (point))) + ;; If there was no message-id, we just fake one + ;; to make subsequent routines simpler. + (nnheader-generate-fake-message-id)))) + ;; References. + (progn + (goto-char p) + (if (search-forward "\nreferences: " nil t) + (progn + (setq end (point)) + (prog1 + (nnheader-header-value) + (setq ref + (buffer-substring + (progn + (end-of-line) + (search-backward ">" end t) + (1+ (point))) + (progn + (search-backward "<" end t) + (point)))))) + ;; Get the references from the in-reply-to header if there + ;; were no references and the in-reply-to header looks + ;; promising. + (if (and (search-forward "\nin-reply-to: " nil t) + (setq in-reply-to (nnheader-header-value)) + (string-match "<[^>]+>" in-reply-to)) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (setq ref nil)))) + ;; Chars. + 0 + ;; Lines. + (progn + (goto-char p) + (if (search-forward "\nlines: " nil t) + (if (numberp (setq lines (ignore-errors (read cur)))) + lines 0) + 0)) + ;; Xref. + (progn + (goto-char p) + (and (search-forward "\nxref: " nil t) + (nnheader-header-value))))) + (when (equal id ref) + (setq ref nil)) + + (when gnus-alter-header-function + (funcall gnus-alter-header-function header) + (setq id (mail-header-id header) + ref (gnus-parent-id (mail-header-references header)))) + + ;; We do the threading while we read the headers. The + ;; message-id and the last reference are both entered into + ;; the same hash table. Some tippy-toeing around has to be + ;; done in case an article has arrived before the article + ;; which it refers to. + (if (boundp (setq id-dep (intern id dependencies))) + (if (and (car (symbol-value id-dep)) + (not force-new)) + ;; An article with this Message-ID has already been seen. + (if gnus-summary-ignore-duplicates + ;; We ignore this one, except we add + ;; any additional Xrefs (in case the two articles + ;; came from different servers). + (progn + (mail-header-set-xref + (car (symbol-value id-dep)) + (concat (or (mail-header-xref + (car (symbol-value id-dep))) + "") + (or (mail-header-xref header) ""))) + (setq header nil)) + ;; We rename the Message-ID. + (set + (setq id-dep (intern (setq id (nnmail-message-id)) + dependencies)) + (list header)) + (mail-header-set-id header id)) + (setcar (symbol-value id-dep) header)) + (set id-dep (list header))) + (when header + (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (symbol-value id-dep)))) + (set ref-dep (list nil (symbol-value id-dep)))) + (push header headers)) + (goto-char (point-max)) + (widen)) + (nreverse headers))))) + +;; The following macros and functions were written by Felix Lee +;; . + +(defmacro gnus-nov-read-integer () + '(prog1 + (if (= (following-char) ?\t) + 0 + (let ((num (ignore-errors (read buffer)))) + (if (numberp num) num 0))) + (unless (eobp) + (forward-char 1)))) + +(defmacro gnus-nov-skip-field () + '(search-forward "\t" eol 'move)) + +(defmacro gnus-nov-field () + '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol))) + +;; (defvar gnus-nov-none-counter 0) + +;; This function has to be called with point after the article number +;; on the beginning of the line. +(defun gnus-nov-parse-line (number dependencies &optional force-new) + (let ((eol (gnus-point-at-eol)) + (buffer (current-buffer)) + header ref id id-dep ref-dep) + + ;; overview: [num subject from date id refs chars lines misc] + (unwind-protect + (progn + (narrow-to-region (point) eol) + (unless (eobp) + (forward-char)) + + (setq header + (vector + number ; number + (funcall + gnus-unstructured-field-decoder (gnus-nov-field)) ; subject + (funcall + gnus-structured-field-decoder (gnus-nov-field)) ; from + (gnus-nov-field) ; date + (setq id (or (gnus-nov-field) + (nnheader-generate-fake-message-id))) ; id + (progn + (let ((beg (point))) + (search-forward "\t" eol) + (if (search-backward ">" beg t) + (setq ref + (buffer-substring + (1+ (point)) + (search-backward "<" beg t))) + (setq ref nil)) + (goto-char beg)) + (gnus-nov-field)) ; refs + (gnus-nov-read-integer) ; chars + (gnus-nov-read-integer) ; lines + (if (= (following-char) ?\n) + nil + (gnus-nov-field))))) ; misc + + (widen)) + + (when gnus-alter-header-function + (funcall gnus-alter-header-function header) + (setq id (mail-header-id header) + ref (gnus-parent-id (mail-header-references header)))) + + ;; We build the thread tree. + (when (equal id ref) + ;; This article refers back to itself. Naughty, naughty. + (setq ref nil)) + (if (boundp (setq id-dep (intern id dependencies))) + (if (and (car (symbol-value id-dep)) + (not force-new)) + ;; An article with this Message-ID has already been seen. + (if gnus-summary-ignore-duplicates + ;; We ignore this one, except we add any additional + ;; Xrefs (in case the two articles came from different + ;; servers. + (progn + (mail-header-set-xref + (car (symbol-value id-dep)) + (concat (or (mail-header-xref + (car (symbol-value id-dep))) + "") + (or (mail-header-xref header) ""))) + (setq header nil)) + ;; We rename the Message-ID. + (set + (setq id-dep (intern (setq id (nnmail-message-id)) + dependencies)) + (list header)) + (mail-header-set-id header id)) + (setcar (symbol-value id-dep) header)) + (set id-dep (list header))) + (when header + (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (symbol-value id-dep)))) + (set ref-dep (list nil (symbol-value id-dep))))) + header)) + +;; Goes through the xover lines and returns a list of vectors +(defun gnus-get-newsgroup-headers-xover (sequence &optional + force-new dependencies + group also-fetch-heads) + "Parse the news overview data in the server buffer, and return a +list of headers that match SEQUENCE (see `nntp-retrieve-headers')." + ;; Get the Xref when the users reads the articles since most/some + ;; NNTP servers do not include Xrefs when using XOVER. + (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) + (let ((cur nntp-server-buffer) + (dependencies (or dependencies gnus-newsgroup-dependencies)) + number headers header) + (save-excursion + (set-buffer nntp-server-buffer) + ;; Allow the user to mangle the headers before parsing them. + (run-hooks 'gnus-parse-headers-hook) + (goto-char (point-min)) + (while (not (eobp)) + (condition-case () + (while (and sequence (not (eobp))) + (setq number (read cur)) + (while (and sequence + (< (car sequence) number)) + (setq sequence (cdr sequence))) + (and sequence + (eq number (car sequence)) + (progn + (setq sequence (cdr sequence)) + (setq header (inline + (gnus-nov-parse-line + number dependencies force-new)))) + (push header headers)) + (forward-line 1)) + (error + (gnus-error 4 "Strange nov line (%d)" + (count-lines (point-min) (point))))) + (forward-line 1)) + ;; A common bug in inn is that if you have posted an article and + ;; then retrieves the active file, it will answer correctly -- + ;; the new article is included. However, a NOV entry for the + ;; article may not have been generated yet, so this may fail. + ;; We work around this problem by retrieving the last few + ;; headers using HEAD. + (if (or (not also-fetch-heads) + (not sequence)) + ;; We (probably) got all the headers. + (nreverse headers) + (let ((gnus-nov-is-evil t)) + (nconc + (nreverse headers) + (when (gnus-retrieve-headers sequence group) + (gnus-get-newsgroup-headers)))))))) + +(defun gnus-article-get-xrefs () + "Fill in the Xref value in `gnus-current-headers', if necessary. +This is meant to be called in `gnus-article-internal-prepare-hook'." + (let ((headers (save-excursion (set-buffer gnus-summary-buffer) + gnus-current-headers))) + (or (not gnus-use-cross-reference) + (not headers) + (and (mail-header-xref headers) + (not (string= (mail-header-xref headers) ""))) + (let ((case-fold-search t) + xref) + (save-restriction + (nnheader-narrow-to-headers) + (goto-char (point-min)) + (when (or (and (eq (downcase (following-char)) ?x) + (looking-at "Xref:")) + (search-forward "\nXref:" nil t)) + (goto-char (1+ (match-end 0))) + (setq xref (buffer-substring (point) + (progn (end-of-line) (point)))) + (mail-header-set-xref headers xref))))))) + +(defun gnus-summary-insert-subject (id &optional old-header use-old-header) + "Find article ID and insert the summary line for that article." + (let ((header (if (and old-header use-old-header) + old-header (gnus-read-header id))) + (number (and (numberp id) id)) + pos d) + (when header + ;; Rebuild the thread that this article is part of and go to the + ;; article we have fetched. + (when (and (not gnus-show-threads) + old-header) + (when (setq d (gnus-data-find (mail-header-number old-header))) + (goto-char (gnus-data-pos d)) + (gnus-data-remove + number + (- (gnus-point-at-bol) + (prog1 + (1+ (gnus-point-at-eol)) + (gnus-delete-line)))))) + (when old-header + (mail-header-set-number header (mail-header-number old-header))) + (setq gnus-newsgroup-sparse + (delq (setq number (mail-header-number header)) + gnus-newsgroup-sparse)) + (setq gnus-newsgroup-ancient (delq number gnus-newsgroup-ancient)) + (gnus-rebuild-thread (mail-header-id header)) + (gnus-summary-goto-subject number nil t)) + (when (and (numberp number) + (> number 0)) + ;; We have to update the boundaries even if we can't fetch the + ;; article if ID is a number -- so that the next `P' or `N' + ;; command will fetch the previous (or next) article even + ;; if the one we tried to fetch this time has been canceled. + (when (> number gnus-newsgroup-end) + (setq gnus-newsgroup-end number)) + (when (< number gnus-newsgroup-begin) + (setq gnus-newsgroup-begin number)) + (setq gnus-newsgroup-unselected + (delq number gnus-newsgroup-unselected))) + ;; Report back a success? + (and header (mail-header-number header)))) + +;;; Process/prefix in the summary buffer + +(defun gnus-summary-work-articles (n) + "Return a list of articles to be worked upon. The prefix argument, +the list of process marked articles, and the current article will be +taken into consideration." + (cond + (n + ;; A numerical prefix has been given. + (setq n (prefix-numeric-value n)) + (let ((backward (< n 0)) + (n (abs (prefix-numeric-value n))) + articles article) + (save-excursion + (while + (and (> n 0) + (push (setq article (gnus-summary-article-number)) + articles) + (if backward + (gnus-summary-find-prev nil article) + (gnus-summary-find-next nil article))) + (decf n))) + (nreverse articles))) + ((gnus-region-active-p) + ;; Work on the region between point and mark. + (let ((max (max (point) (mark))) + articles article) + (save-excursion + (goto-char (min (point) (mark))) + (while + (and + (push (setq article (gnus-summary-article-number)) articles) + (gnus-summary-find-next nil article) + (< (point) max))) + (nreverse articles)))) + (gnus-newsgroup-processable + ;; There are process-marked articles present. + ;; Save current state. + (gnus-summary-save-process-mark) + ;; Return the list. + (reverse gnus-newsgroup-processable)) + (t + ;; Just return the current article. + (list (gnus-summary-article-number))))) + +(defun gnus-summary-save-process-mark () + "Push the current set of process marked articles on the stack." + (interactive) + (push (copy-sequence gnus-newsgroup-processable) + gnus-newsgroup-process-stack)) + +(defun gnus-summary-kill-process-mark () + "Push the current set of process marked articles on the stack and unmark." + (interactive) + (gnus-summary-save-process-mark) + (gnus-summary-unmark-all-processable)) + +(defun gnus-summary-yank-process-mark () + "Pop the last process mark state off the stack and restore it." + (interactive) + (unless gnus-newsgroup-process-stack + (error "Empty mark stack")) + (gnus-summary-process-mark-set (pop gnus-newsgroup-process-stack))) + +(defun gnus-summary-process-mark-set (set) + "Make SET into the current process marked articles." + (gnus-summary-unmark-all-processable) + (while set + (gnus-summary-set-process-mark (pop set)))) + +;;; Searching and stuff + +(defun gnus-summary-search-group (&optional backward use-level) + "Search for next unread newsgroup. +If optional argument BACKWARD is non-nil, search backward instead." + (save-excursion + (set-buffer gnus-group-buffer) + (when (gnus-group-search-forward + backward nil (if use-level (gnus-group-group-level) nil)) + (gnus-group-group-name)))) + +(defun gnus-summary-best-group (&optional exclude-group) + "Find the name of the best unread group. +If EXCLUDE-GROUP, do not go to this group." + (save-excursion + (set-buffer gnus-group-buffer) + (save-excursion + (gnus-group-best-unread-group exclude-group)))) + +(defun gnus-summary-find-next (&optional unread article backward) + (if backward (gnus-summary-find-prev) + (let* ((dummy (gnus-summary-article-intangible-p)) + (article (or article (gnus-summary-article-number))) + (arts (gnus-data-find-list article)) + result) + (when (and (not dummy) + (or (not gnus-summary-check-current) + (not unread) + (not (gnus-data-unread-p (car arts))))) + (setq arts (cdr arts))) + (when (setq result + (if unread + (progn + (while arts + (when (gnus-data-unread-p (car arts)) + (setq result (car arts) + arts nil)) + (setq arts (cdr arts))) + result) + (car arts))) + (goto-char (gnus-data-pos result)) + (gnus-data-number result))))) + +(defun gnus-summary-find-prev (&optional unread article) + (let* ((eobp (eobp)) + (article (or article (gnus-summary-article-number))) + (arts (gnus-data-find-list article (gnus-data-list 'rev))) + result) + (when (and (not eobp) + (or (not gnus-summary-check-current) + (not unread) + (not (gnus-data-unread-p (car arts))))) + (setq arts (cdr arts))) + (when (setq result + (if unread + (progn + (while arts + (when (gnus-data-unread-p (car arts)) + (setq result (car arts) + arts nil)) + (setq arts (cdr arts))) + result) + (car arts))) + (goto-char (gnus-data-pos result)) + (gnus-data-number result)))) + +(defun gnus-summary-find-subject (subject &optional unread backward article) + (let* ((simp-subject (gnus-simplify-subject-fully subject)) + (article (or article (gnus-summary-article-number))) + (articles (gnus-data-list backward)) + (arts (gnus-data-find-list article articles)) + result) + (when (or (not gnus-summary-check-current) + (not unread) + (not (gnus-data-unread-p (car arts)))) + (setq arts (cdr arts))) + (while arts + (and (or (not unread) + (gnus-data-unread-p (car arts))) + (vectorp (gnus-data-header (car arts))) + (gnus-subject-equal + simp-subject (mail-header-subject (gnus-data-header (car arts))) t) + (setq result (car arts) + arts nil)) + (setq arts (cdr arts))) + (and result + (goto-char (gnus-data-pos result)) + (gnus-data-number result)))) + +(defun gnus-summary-search-forward (&optional unread subject backward) + "Search forward for an article. +If UNREAD, look for unread articles. If SUBJECT, look for +articles with that subject. If BACKWARD, search backward instead." + (cond (subject (gnus-summary-find-subject subject unread backward)) + (backward (gnus-summary-find-prev unread)) + (t (gnus-summary-find-next unread)))) + +(defun gnus-recenter (&optional n) + "Center point in window and redisplay frame. +Also do horizontal recentering." + (interactive "P") + (when (and gnus-auto-center-summary + (not (eq gnus-auto-center-summary 'vertical))) + (gnus-horizontal-recenter)) + (recenter n)) + +(defun gnus-summary-recenter () + "Center point in the summary window. +If `gnus-auto-center-summary' is nil, or the article buffer isn't +displayed, no centering will be performed." + ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). + ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. + (let* ((top (cond ((< (window-height) 4) 0) + ((< (window-height) 7) 1) + (t 2))) + (height (1- (window-height))) + (bottom (save-excursion (goto-char (point-max)) + (forward-line (- height)) + (point))) + (window (get-buffer-window (current-buffer)))) + ;; The user has to want it. + (when gnus-auto-center-summary + (when (get-buffer-window gnus-article-buffer) + ;; Only do recentering when the article buffer is displayed, + ;; Set the window start to either `bottom', which is the biggest + ;; possible valid number, or the second line from the top, + ;; whichever is the least. + (set-window-start + window (min bottom (save-excursion + (forward-line (- top)) (point))))) + ;; Do horizontal recentering while we're at it. + (when (and (get-buffer-window (current-buffer) t) + (not (eq gnus-auto-center-summary 'vertical))) + (let ((selected (selected-window))) + (select-window (get-buffer-window (current-buffer) t)) + (gnus-summary-position-point) + (gnus-horizontal-recenter) + (select-window selected)))))) + +(defun gnus-summary-jump-to-group (newsgroup) + "Move point to NEWSGROUP in group mode buffer." + ;; Keep update point of group mode buffer if visible. + (if (eq (current-buffer) (get-buffer gnus-group-buffer)) + (save-window-excursion + ;; Take care of tree window mode. + (when (get-buffer-window gnus-group-buffer) + (pop-to-buffer gnus-group-buffer)) + (gnus-group-jump-to-group newsgroup)) + (save-excursion + ;; Take care of tree window mode. + (if (get-buffer-window gnus-group-buffer) + (pop-to-buffer gnus-group-buffer) + (set-buffer gnus-group-buffer)) + (gnus-group-jump-to-group newsgroup)))) + +;; This function returns a list of article numbers based on the +;; difference between the ranges of read articles in this group and +;; the range of active articles. +(defun gnus-list-of-unread-articles (group) + (let* ((read (gnus-info-read (gnus-get-info group))) + (active (or (gnus-active group) (gnus-activate-group group))) + (last (cdr active)) + first nlast unread) + ;; If none are read, then all are unread. + (if (not read) + (setq first (car active)) + ;; If the range of read articles is a single range, then the + ;; first unread article is the article after the last read + ;; article. Sounds logical, doesn't it? + (if (not (listp (cdr read))) + (setq first (1+ (cdr read))) + ;; `read' is a list of ranges. + (when (/= (setq nlast (or (and (numberp (car read)) (car read)) + (caar read))) + 1) + (setq first 1)) + (while read + (when first + (while (< first nlast) + (push first unread) + (setq first (1+ first)))) + (setq first (1+ (if (atom (car read)) (car read) (cdar read)))) + (setq nlast (if (atom (cadr read)) (cadr read) (caadr read))) + (setq read (cdr read))))) + ;; And add the last unread articles. + (while (<= first last) + (push first unread) + (setq first (1+ first))) + ;; Return the list of unread articles. + (delq 0 (nreverse unread)))) + +(defun gnus-list-of-read-articles (group) + "Return a list of unread, unticked and non-dormant articles." + (let* ((info (gnus-get-info group)) + (marked (gnus-info-marks info)) + (active (gnus-active group))) + (and info active + (gnus-set-difference + (gnus-sorted-complement + (gnus-uncompress-range active) + (gnus-list-of-unread-articles group)) + (append + (gnus-uncompress-range (cdr (assq 'dormant marked))) + (gnus-uncompress-range (cdr (assq 'tick marked)))))))) + +;; Various summary commands + +(defun gnus-summary-universal-argument (arg) + "Perform any operation on all articles that are process/prefixed." + (interactive "P") + (gnus-set-global-variables) + (let ((articles (gnus-summary-work-articles arg)) + func article) + (if (eq + (setq + func + (key-binding + (read-key-sequence + (substitute-command-keys + "\\\\[gnus-summary-universal-argument]" + )))) + 'undefined) + (gnus-error 1 "Undefined key") + (save-excursion + (while articles + (gnus-summary-goto-subject (setq article (pop articles))) + (let (gnus-newsgroup-processable) + (command-execute func)) + (gnus-summary-remove-process-mark article))))) + (gnus-summary-position-point)) + +(defun gnus-summary-toggle-truncation (&optional arg) + "Toggle truncation of summary lines. +With arg, turn line truncation on iff arg is positive." + (interactive "P") + (setq truncate-lines + (if (null arg) (not truncate-lines) + (> (prefix-numeric-value arg) 0))) + (redraw-display)) + +(defun gnus-summary-reselect-current-group (&optional all rescan) + "Exit and then reselect the current newsgroup. +The prefix argument ALL means to select all articles." + (interactive "P") + (gnus-set-global-variables) + (when (gnus-ephemeral-group-p gnus-newsgroup-name) + (error "Ephemeral groups can't be reselected")) + (let ((current-subject (gnus-summary-article-number)) + (group gnus-newsgroup-name)) + (setq gnus-newsgroup-begin nil) + (gnus-summary-exit) + ;; We have to adjust the point of group mode buffer because + ;; point was moved to the next unread newsgroup by exiting. + (gnus-summary-jump-to-group group) + (when rescan + (save-excursion + (gnus-group-get-new-news-this-group 1))) + (gnus-group-read-group all t) + (gnus-summary-goto-subject current-subject nil t))) + +(defun gnus-summary-rescan-group (&optional all) + "Exit the newsgroup, ask for new articles, and select the newsgroup." + (interactive "P") + (gnus-summary-reselect-current-group all t)) + +(defun gnus-summary-update-info (&optional non-destructive) + (save-excursion + (let ((group gnus-newsgroup-name)) + (when gnus-newsgroup-kill-headers + (setq gnus-newsgroup-killed + (gnus-compress-sequence + (nconc + (gnus-set-sorted-intersection + (gnus-uncompress-range gnus-newsgroup-killed) + (setq gnus-newsgroup-unselected + (sort gnus-newsgroup-unselected '<))) + (setq gnus-newsgroup-unreads + (sort gnus-newsgroup-unreads '<))) + t))) + (unless (listp (cdr gnus-newsgroup-killed)) + (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) + (let ((headers gnus-newsgroup-headers)) + (when (and (not gnus-save-score) + (not non-destructive)) + (setq gnus-newsgroup-scored nil)) + ;; Set the new ranges of read articles. + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-force-boundary)) + (gnus-update-read-articles + group (append gnus-newsgroup-unreads gnus-newsgroup-unselected)) + ;; Set the current article marks. + (gnus-update-marks) + ;; Do the cross-ref thing. + (when gnus-use-cross-reference + (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads)) + ;; Do adaptive scoring, and possibly save score files. + (when gnus-newsgroup-adaptive + (gnus-score-adaptive)) + (when gnus-use-scoring + (gnus-score-save)) + ;; Do not switch windows but change the buffer to work. + (set-buffer gnus-group-buffer) + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-group-update-group group)))))) + +(defun gnus-summary-save-newsrc (&optional force) + "Save the current number of read/marked articles in the dribble buffer. +The dribble buffer will then be saved. +If FORCE (the prefix), also save the .newsrc file(s)." + (interactive "P") + (gnus-summary-update-info t) + (if force + (gnus-save-newsrc-file) + (gnus-dribble-save))) + +(defun gnus-summary-exit (&optional temporary) + "Exit reading current newsgroup, and then return to group selection mode. +gnus-exit-group-hook is called with no arguments if that value is non-nil." + (interactive) + (gnus-set-global-variables) + (gnus-kill-save-kill-buffer) + (let* ((group gnus-newsgroup-name) + (quit-config (gnus-group-quit-config gnus-newsgroup-name)) + (mode major-mode) + (group-point nil) + (buf (current-buffer))) + (run-hooks 'gnus-summary-prepare-exit-hook) + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (gnus-kill-buffer gnus-original-article-buffer) + (setq gnus-article-current nil)) + (when gnus-use-cache + (gnus-cache-possibly-remove-articles) + (gnus-cache-save-buffers)) + (gnus-async-prefetch-remove-group group) + (when gnus-suppress-duplicates + (gnus-dup-enter-articles)) + (when gnus-use-trees + (gnus-tree-close group)) + ;; Make all changes in this group permanent. + (unless quit-config + (run-hooks 'gnus-exit-group-hook) + (gnus-summary-update-info)) + (gnus-close-group group) + ;; Make sure where we were, and go to next newsgroup. + (set-buffer gnus-group-buffer) + (unless quit-config + (gnus-group-jump-to-group group)) + (run-hooks 'gnus-summary-exit-hook) + (unless quit-config + (gnus-group-next-unread-group 1)) + (setq group-point (point)) + (if temporary + nil ;Nothing to do. + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer) + (setq gnus-article-current nil)) + (set-buffer buf) + (if (not gnus-kill-summary-on-exit) + (gnus-deaden-summary) + ;; We set all buffer-local variables to nil. It is unclear why + ;; this is needed, but if we don't, buffer-local variables are + ;; not garbage-collected, it seems. This would the lead to en + ;; ever-growing Emacs. + (gnus-summary-clear-local-variables) + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) + ;; We clear the global counterparts of the buffer-local + ;; variables as well, just to be on the safe side. + (set-buffer gnus-group-buffer) + (gnus-summary-clear-local-variables) + ;; Return to group mode buffer. + (when (eq mode 'gnus-summary-mode) + (gnus-kill-buffer buf))) + (setq gnus-current-select-method gnus-select-method) + (pop-to-buffer gnus-group-buffer) + ;; Clear the current group name. + (if (not quit-config) + (progn + (goto-char group-point) + (gnus-configure-windows 'group 'force)) + (gnus-handle-ephemeral-exit quit-config)) + (unless quit-config + (setq gnus-newsgroup-name nil))))) + +(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update) +(defun gnus-summary-exit-no-update (&optional no-questions) + "Quit reading current newsgroup without updating read article info." + (interactive) + (gnus-set-global-variables) + (let* ((group gnus-newsgroup-name) + (quit-config (gnus-group-quit-config group))) + (when (or no-questions + gnus-expert-user + (gnus-y-or-n-p "Discard changes to this group and exit? ")) + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer) + (setq gnus-article-current nil)) + (if (not gnus-kill-summary-on-exit) + (gnus-deaden-summary) + (gnus-close-group group) + (gnus-summary-clear-local-variables) + (set-buffer gnus-group-buffer) + (gnus-summary-clear-local-variables) + (when (get-buffer gnus-summary-buffer) + (kill-buffer gnus-summary-buffer))) + (unless gnus-single-article-buffer + (setq gnus-article-current nil)) + (when gnus-use-trees + (gnus-tree-close group)) + (gnus-async-prefetch-remove-group group) + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) + ;; Return to the group buffer. + (gnus-configure-windows 'group 'force) + ;; Clear the current group name. + (setq gnus-newsgroup-name nil) + (when (equal (gnus-group-group-name) group) + (gnus-group-next-unread-group 1)) + (when quit-config + (gnus-handle-ephemeral-exit quit-config))))) + +(defun gnus-handle-ephemeral-exit (quit-config) + "Handle movement when leaving an ephemeral group. The state +which existed when entering the ephemeral is reset." + (if (not (buffer-name (car quit-config))) + (gnus-configure-windows 'group 'force) + (set-buffer (car quit-config)) + (cond ((eq major-mode 'gnus-summary-mode) + (gnus-set-global-variables)) + ((eq major-mode 'gnus-article-mode) + (save-excursion + ;; The `gnus-summary-buffer' variable may point + ;; to the old summary buffer when using a single + ;; article buffer. + (unless (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-group-buffer)) + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables)))) + (if (or (eq (cdr quit-config) 'article) + (eq (cdr quit-config) 'pick)) + (progn + ;; The current article may be from the ephemeral group + ;; thus it is best that we reload this article + (gnus-summary-show-article) + (if (and (boundp 'gnus-pick-mode) (symbol-value 'gnus-pick-mode)) + (gnus-configure-windows 'pick 'force) + (gnus-configure-windows (cdr quit-config) 'force))) + (gnus-configure-windows (cdr quit-config) 'force)) + (when (eq major-mode 'gnus-summary-mode) + (gnus-summary-next-subject 1 nil t) + (gnus-summary-recenter) + (gnus-summary-position-point)))) + +;;; Dead summaries. + +(defvar gnus-dead-summary-mode-map nil) + +(unless gnus-dead-summary-mode-map + (setq gnus-dead-summary-mode-map (make-keymap)) + (suppress-keymap gnus-dead-summary-mode-map) + (substitute-key-definition + 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map) + (let ((keys '("\C-d" "\r" "\177" [delete]))) + (while keys + (define-key gnus-dead-summary-mode-map + (pop keys) 'gnus-summary-wake-up-the-dead)))) + +(defvar gnus-dead-summary-mode nil + "Minor mode for Gnus summary buffers.") + +(defun gnus-dead-summary-mode (&optional arg) + "Minor mode for Gnus summary buffers." + (interactive "P") + (when (eq major-mode 'gnus-summary-mode) + (make-local-variable 'gnus-dead-summary-mode) + (setq gnus-dead-summary-mode + (if (null arg) (not gnus-dead-summary-mode) + (> (prefix-numeric-value arg) 0))) + (when gnus-dead-summary-mode + (gnus-add-minor-mode + 'gnus-dead-summary-mode " Dead" gnus-dead-summary-mode-map)))) + +(defun gnus-deaden-summary () + "Make the current summary buffer into a dead summary buffer." + ;; Kill any previous dead summary buffer. + (when (and gnus-dead-summary + (buffer-name gnus-dead-summary)) + (save-excursion + (set-buffer gnus-dead-summary) + (when gnus-dead-summary-mode + (kill-buffer (current-buffer))))) + ;; Make this the current dead summary. + (setq gnus-dead-summary (current-buffer)) + (gnus-dead-summary-mode 1) + (let ((name (buffer-name))) + (when (string-match "Summary" name) + (rename-buffer + (concat (substring name 0 (match-beginning 0)) "Dead " + (substring name (match-beginning 0))) + t)))) + +(defun gnus-kill-or-deaden-summary (buffer) + "Kill or deaden the summary BUFFER." + (when (and (buffer-name buffer) + (not gnus-single-article-buffer)) + (save-excursion + (set-buffer buffer) + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer))) + (cond (gnus-kill-summary-on-exit + (when (and gnus-use-trees + (and (get-buffer buffer) + (buffer-name (get-buffer buffer)))) + (save-excursion + (set-buffer (get-buffer buffer)) + (gnus-tree-close gnus-newsgroup-name))) + (gnus-kill-buffer buffer)) + ((and (get-buffer buffer) + (buffer-name (get-buffer buffer))) + (save-excursion + (set-buffer buffer) + (gnus-deaden-summary))))) + +(defun gnus-summary-wake-up-the-dead (&rest args) + "Wake up the dead summary buffer." + (interactive) + (gnus-dead-summary-mode -1) + (let ((name (buffer-name))) + (when (string-match "Dead " name) + (rename-buffer + (concat (substring name 0 (match-beginning 0)) + (substring name (match-end 0))) + t))) + (gnus-message 3 "This dead summary is now alive again")) + +;; Suggested by Andrew Eskilsson . +(defun gnus-summary-fetch-faq (&optional faq-dir) + "Fetch the FAQ for the current group. +If FAQ-DIR (the prefix), prompt for a directory to search for the faq +in." + (interactive + (list + (when current-prefix-arg + (completing-read + "Faq dir: " (and (listp gnus-group-faq-directory) + (mapcar (lambda (file) (list file)) + gnus-group-faq-directory)))))) + (let (gnus-faq-buffer) + (when (setq gnus-faq-buffer + (gnus-group-fetch-faq gnus-newsgroup-name faq-dir)) + (gnus-configure-windows 'summary-faq)))) + +;; Suggested by Per Abrahamsen . +(defun gnus-summary-describe-group (&optional force) + "Describe the current newsgroup." + (interactive "P") + (gnus-group-describe-group force gnus-newsgroup-name)) + +(defun gnus-summary-describe-briefly () + "Describe summary mode commands briefly." + (interactive) + (gnus-message 6 + (substitute-command-keys "\\\\[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"))) + +;; Walking around group mode buffer from summary mode. + +(defun gnus-summary-next-group (&optional no-article target-group backward) + "Exit current newsgroup and then select next unread newsgroup. +If prefix argument NO-ARTICLE is non-nil, no article is selected +initially. If NEXT-GROUP, go to this group. If BACKWARD, go to +previous group instead." + (interactive "P") + (gnus-set-global-variables) + ;; Stop pre-fetching. + (gnus-async-halt-prefetch) + (let ((current-group gnus-newsgroup-name) + (current-buffer (current-buffer)) + entered) + ;; First we semi-exit this group to update Xrefs and all variables. + ;; We can't do a real exit, because the window conf must remain + ;; the same in case the user is prompted for info, and we don't + ;; want the window conf to change before that... + (gnus-summary-exit t) + (while (not entered) + ;; Then we find what group we are supposed to enter. + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group current-group) + (setq target-group + (or target-group + (if (eq gnus-keep-same-level 'best) + (gnus-summary-best-group gnus-newsgroup-name) + (gnus-summary-search-group backward gnus-keep-same-level)))) + (if (not target-group) + ;; There are no further groups, so we return to the group + ;; buffer. + (progn + (gnus-message 5 "Returning to the group buffer") + (setq entered t) + (when (gnus-buffer-live-p current-buffer) + (set-buffer current-buffer) + (gnus-summary-exit)) + (run-hooks 'gnus-group-no-more-groups-hook)) + ;; We try to enter the target group. + (gnus-group-jump-to-group target-group) + (let ((unreads (gnus-group-group-unread))) + (if (and (or (eq t unreads) + (and unreads (not (zerop unreads)))) + (gnus-summary-read-group + target-group nil no-article + (and (buffer-name current-buffer) current-buffer))) + (setq entered t) + (setq current-group target-group + target-group nil))))))) + +(defun gnus-summary-prev-group (&optional no-article) + "Exit current newsgroup and then select previous unread newsgroup. +If prefix argument NO-ARTICLE is non-nil, no article is selected initially." + (interactive "P") + (gnus-summary-next-group no-article nil t)) + +;; Walking around summary lines. + +(defun gnus-summary-first-subject (&optional unread) + "Go to the first unread subject. +If UNREAD is non-nil, go to the first unread article. +Returns the article selected or nil if there are no unread articles." + (interactive "P") + (prog1 + (cond + ;; Empty summary. + ((null gnus-newsgroup-data) + (gnus-message 3 "No articles in the group") + nil) + ;; Pick the first article. + ((not unread) + (goto-char (gnus-data-pos (car gnus-newsgroup-data))) + (gnus-data-number (car gnus-newsgroup-data))) + ;; No unread articles. + ((null gnus-newsgroup-unreads) + (gnus-message 3 "No more unread articles") + nil) + ;; Find the first unread article. + (t + (let ((data gnus-newsgroup-data)) + (while (and data + (not (gnus-data-unread-p (car data)))) + (setq data (cdr data))) + (when data + (goto-char (gnus-data-pos (car data))) + (gnus-data-number (car data)))))) + (gnus-summary-position-point))) + +(defun gnus-summary-next-subject (n &optional unread dont-display) + "Go to next N'th summary line. +If N is negative, go to the previous N'th subject line. +If UNREAD is non-nil, only unread articles are selected. +The difference between N and the actual number of steps taken is +returned." + (interactive "p") + (let ((backward (< n 0)) + (n (abs n))) + (while (and (> n 0) + (if backward + (gnus-summary-find-prev unread) + (gnus-summary-find-next unread))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more%s articles" + (if unread " unread" ""))) + (unless dont-display + (gnus-summary-recenter) + (gnus-summary-position-point)) + n)) + +(defun gnus-summary-next-unread-subject (n) + "Go to next N'th unread summary line." + (interactive "p") + (gnus-summary-next-subject n t)) + +(defun gnus-summary-prev-subject (n &optional unread) + "Go to previous N'th summary line. +If optional argument UNREAD is non-nil, only unread article is selected." + (interactive "p") + (gnus-summary-next-subject (- n) unread)) + +(defun gnus-summary-prev-unread-subject (n) + "Go to previous N'th unread summary line." + (interactive "p") + (gnus-summary-next-subject (- n) t)) + +(defun gnus-summary-goto-subject (article &optional force silent) + "Go the subject line of ARTICLE. +If FORCE, also allow jumping to articles not currently shown." + (interactive "nArticle number: ") + (let ((b (point)) + (data (gnus-data-find article))) + ;; We read in the article if we have to. + (and (not data) + force + (gnus-summary-insert-subject article (and (vectorp force) force) t) + (setq data (gnus-data-find article))) + (goto-char b) + (if (not data) + (progn + (unless silent + (gnus-message 3 "Can't find article %d" article)) + nil) + (goto-char (gnus-data-pos data)) + article))) + +;; Walking around summary lines with displaying articles. + +(defun gnus-summary-expand-window (&optional arg) + "Make the summary buffer take up the entire Emacs frame. +Given a prefix, will force an `article' buffer configuration." + (interactive "P") + (gnus-set-global-variables) + (if arg + (gnus-configure-windows 'article 'force) + (gnus-configure-windows 'summary 'force))) + +(defun gnus-summary-display-article (article &optional all-header) + "Display ARTICLE in article buffer." + (gnus-set-global-variables) + (if (null article) + nil + (prog1 + (if gnus-summary-display-article-function + (funcall gnus-summary-display-article-function article all-header) + (gnus-article-prepare article all-header)) + (run-hooks 'gnus-select-article-hook) + (when (and gnus-current-article + (not (zerop gnus-current-article))) + (gnus-summary-goto-subject gnus-current-article)) + (gnus-summary-recenter) + (when (and gnus-use-trees gnus-show-threads) + (gnus-possibly-generate-tree article) + (gnus-highlight-selected-tree article)) + ;; Successfully display article. + (gnus-article-set-window-start + (cdr (assq article gnus-newsgroup-bookmarks)))))) + +(defun gnus-summary-select-article (&optional all-headers force pseudo article) + "Select the current article. +If ALL-HEADERS is non-nil, show all header fields. If FORCE is +non-nil, the article will be re-fetched even if it already present in +the article buffer. If PSEUDO is non-nil, pseudo-articles will also +be displayed." + ;; Make sure we are in the summary buffer to work around bbdb bug. + (unless (eq major-mode 'gnus-summary-mode) + (set-buffer gnus-summary-buffer)) + (let ((article (or article (gnus-summary-article-number))) + (all-headers (not (not all-headers))) ;Must be T or NIL. + gnus-summary-display-article-function + did) + (and (not pseudo) + (gnus-summary-article-pseudo-p article) + (error "This is a pseudo-article")) + (prog1 + (save-excursion + (set-buffer gnus-summary-buffer) + (if (or (and gnus-single-article-buffer + (or (null gnus-current-article) + (null gnus-article-current) + (null (get-buffer gnus-article-buffer)) + (not (eq article (cdr gnus-article-current))) + (not (equal (car gnus-article-current) + gnus-newsgroup-name)))) + (and (not gnus-single-article-buffer) + (or (null gnus-current-article) + (not (eq gnus-current-article article)))) + force) + ;; The requested article is different from the current article. + (prog1 + (gnus-summary-display-article article all-headers) + (setq did article)) + (when (or all-headers gnus-show-all-headers) + (gnus-article-show-all-headers)) + 'old)) + (when did + (gnus-article-set-window-start + (cdr (assq article gnus-newsgroup-bookmarks))))))) + +(defun gnus-summary-set-current-mark (&optional current-mark) + "Obsolete function." + nil) + +(defun gnus-summary-next-article (&optional unread subject backward push) + "Select the next article. +If UNREAD, only unread articles are selected. +If SUBJECT, only articles with SUBJECT are selected. +If BACKWARD, the previous article is selected instead of the next." + (interactive "P") + (gnus-set-global-variables) + (cond + ;; Is there such an article? + ((and (gnus-summary-search-forward unread subject backward) + (or (gnus-summary-display-article (gnus-summary-article-number)) + (eq (gnus-summary-article-mark) gnus-canceled-mark))) + (gnus-summary-position-point)) + ;; If not, we try the first unread, if that is wanted. + ((and subject + gnus-auto-select-same + (gnus-summary-first-unread-article)) + (gnus-summary-position-point) + (gnus-message 6 "Wrapped")) + ;; Try to get next/previous article not displayed in this group. + ((and gnus-auto-extend-newsgroup + (not unread) (not subject)) + (gnus-summary-goto-article + (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end)) + nil t)) + ;; Go to next/previous group. + (t + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-summary-jump-to-group gnus-newsgroup-name)) + (let ((cmd last-command-char) + (point + (save-excursion + (set-buffer gnus-group-buffer) + (point))) + (group + (if (eq gnus-keep-same-level 'best) + (gnus-summary-best-group gnus-newsgroup-name) + (gnus-summary-search-group backward gnus-keep-same-level)))) + ;; For some reason, the group window gets selected. We change + ;; it back. + (select-window (get-buffer-window (current-buffer))) + ;; Select next unread newsgroup automagically. + (cond + ((or (not gnus-auto-select-next) + (not cmd)) + (gnus-message 7 "No more%s articles" (if unread " unread" ""))) + ((or (eq gnus-auto-select-next 'quietly) + (and (eq gnus-auto-select-next 'slightly-quietly) + push) + (and (eq gnus-auto-select-next 'almost-quietly) + (gnus-summary-last-article-p))) + ;; Select quietly. + (if (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-summary-exit) + (gnus-message 7 "No more%s articles (%s)..." + (if unread " unread" "") + (if group (concat "selecting " group) + "exiting")) + (gnus-summary-next-group nil group backward))) + (t + (when (gnus-key-press-event-p last-input-event) + (gnus-summary-walk-group-buffer + gnus-newsgroup-name cmd unread backward point)))))))) + +(defun gnus-summary-walk-group-buffer (from-group cmd unread backward start) + (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1)) + (?\C-p (gnus-group-prev-unread-group 1)))) + (cursor-in-echo-area t) + keve key group ended) + (save-excursion + (set-buffer gnus-group-buffer) + (goto-char start) + (setq group + (if (eq gnus-keep-same-level 'best) + (gnus-summary-best-group gnus-newsgroup-name) + (gnus-summary-search-group backward gnus-keep-same-level)))) + (while (not ended) + (gnus-message + 5 "No more%s articles%s" (if unread " unread" "") + (if (and group + (not (gnus-ephemeral-group-p gnus-newsgroup-name))) + (format " (Type %s for %s [%s])" + (single-key-description cmd) group + (car (gnus-gethash group gnus-newsrc-hashtb))) + (format " (Type %s to exit %s)" + (single-key-description cmd) + gnus-newsgroup-name))) + ;; Confirm auto selection. + (setq key (car (setq keve (gnus-read-event-char)))) + (setq ended t) + (cond + ((assq key keystrokes) + (let ((obuf (current-buffer))) + (switch-to-buffer gnus-group-buffer) + (when group + (gnus-group-jump-to-group group)) + (eval (cadr (assq key keystrokes))) + (setq group (gnus-group-group-name)) + (switch-to-buffer obuf)) + (setq ended nil)) + ((equal key cmd) + (if (or (not group) + (gnus-ephemeral-group-p gnus-newsgroup-name)) + (gnus-summary-exit) + (gnus-summary-next-group nil group backward))) + (t + (push (cdr keve) unread-command-events)))))) + +(defun gnus-summary-next-unread-article () + "Select unread article after current one." + (interactive) + (gnus-summary-next-article + (or (not (eq gnus-summary-goto-unread 'never)) + (gnus-summary-last-article-p (gnus-summary-article-number))) + (and gnus-auto-select-same + (gnus-summary-article-subject)))) + +(defun gnus-summary-prev-article (&optional unread subject) + "Select the article after the current one. +If UNREAD is non-nil, only unread articles are selected." + (interactive "P") + (gnus-summary-next-article unread subject t)) + +(defun gnus-summary-prev-unread-article () + "Select unread article before current one." + (interactive) + (gnus-summary-prev-article + (or (not (eq gnus-summary-goto-unread 'never)) + (gnus-summary-first-article-p (gnus-summary-article-number))) + (and gnus-auto-select-same + (gnus-summary-article-subject)))) + +(defun gnus-summary-next-page (&optional lines circular) + "Show next page of the selected article. +If at the end of the current article, select the next article. +LINES says how many lines should be scrolled up. + +If CIRCULAR is non-nil, go to the start of the article instead of +selecting the next article when reaching the end of the current +article." + (interactive "P") + (setq gnus-summary-buffer (current-buffer)) + (gnus-set-global-variables) + (let ((article (gnus-summary-article-number)) + (article-window (get-buffer-window gnus-article-buffer t)) + endp) + (gnus-configure-windows 'article) + (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark) + (if (and (eq gnus-summary-goto-unread 'never) + (not (gnus-summary-last-article-p article))) + (gnus-summary-next-article) + (gnus-summary-next-unread-article)) + (if (or (null gnus-current-article) + (null gnus-article-current) + (/= article (cdr gnus-article-current)) + (not (equal (car gnus-article-current) gnus-newsgroup-name))) + ;; Selected subject is different from current article's. + (gnus-summary-display-article article) + (when article-window + (gnus-eval-in-buffer-window gnus-article-buffer + (setq endp (gnus-article-next-page lines))) + (when endp + (cond (circular + (gnus-summary-beginning-of-article)) + (lines + (gnus-message 3 "End of message")) + ((null lines) + (if (and (eq gnus-summary-goto-unread 'never) + (not (gnus-summary-last-article-p article))) + (gnus-summary-next-article) + (gnus-summary-next-unread-article)))))))) + (gnus-summary-recenter) + (gnus-summary-position-point))) + +(defun gnus-summary-prev-page (&optional lines move) + "Show previous page of selected article. +Argument LINES specifies lines to be scrolled down. +If MOVE, move to the previous unread article if point is at +the beginning of the buffer." + (interactive "P") + (gnus-set-global-variables) + (let ((article (gnus-summary-article-number)) + (article-window (get-buffer-window gnus-article-buffer t)) + endp) + (gnus-configure-windows 'article) + (if (or (null gnus-current-article) + (null gnus-article-current) + (/= article (cdr gnus-article-current)) + (not (equal (car gnus-article-current) gnus-newsgroup-name))) + ;; Selected subject is different from current article's. + (gnus-summary-display-article article) + (gnus-summary-recenter) + (when article-window + (gnus-eval-in-buffer-window gnus-article-buffer + (setq endp (gnus-article-prev-page lines))) + (when (and move endp) + (cond (lines + (gnus-message 3 "Beginning of message")) + ((null lines) + (if (and (eq gnus-summary-goto-unread 'never) + (not (gnus-summary-first-article-p article))) + (gnus-summary-prev-article) + (gnus-summary-prev-unread-article)))))))) + (gnus-summary-position-point)) + +(defun gnus-summary-prev-page-or-article (&optional lines) + "Show previous page of selected article. +Argument LINES specifies lines to be scrolled down. +If at the beginning of the article, go to the next article." + (interactive "P") + (gnus-summary-prev-page lines t)) + +(defun gnus-summary-scroll-up (lines) + "Scroll up (or down) one line current article. +Argument LINES specifies lines to be scrolled up (or down if negative)." + (interactive "p") + (gnus-set-global-variables) + (gnus-configure-windows 'article) + (gnus-summary-show-thread) + (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old) + (gnus-eval-in-buffer-window gnus-article-buffer + (cond ((> lines 0) + (when (gnus-article-next-page lines) + (gnus-message 3 "End of message"))) + ((< lines 0) + (gnus-article-prev-page (- lines)))))) + (gnus-summary-recenter) + (gnus-summary-position-point)) + +(defun gnus-summary-next-same-subject () + "Select next article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-next-article nil (gnus-summary-article-subject))) + +(defun gnus-summary-prev-same-subject () + "Select previous article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-prev-article nil (gnus-summary-article-subject))) + +(defun gnus-summary-next-unread-same-subject () + "Select next unread article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-next-article t (gnus-summary-article-subject))) + +(defun gnus-summary-prev-unread-same-subject () + "Select previous unread article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-prev-article t (gnus-summary-article-subject))) + +(defun gnus-summary-first-unread-article () + "Select the first unread article. +Return nil if there are no unread articles." + (interactive) + (gnus-set-global-variables) + (prog1 + (when (gnus-summary-first-subject t) + (gnus-summary-show-thread) + (gnus-summary-first-subject t) + (gnus-summary-display-article (gnus-summary-article-number))) + (gnus-summary-position-point))) + +(defun gnus-summary-first-article () + "Select the first article. +Return nil if there are no articles." + (interactive) + (gnus-set-global-variables) + (prog1 + (when (gnus-summary-first-subject) + (gnus-summary-show-thread) + (gnus-summary-first-subject) + (gnus-summary-display-article (gnus-summary-article-number))) + (gnus-summary-position-point))) + +(defun gnus-summary-best-unread-article () + "Select the unread article with the highest score." + (interactive) + (gnus-set-global-variables) + (let ((best -1000000) + (data gnus-newsgroup-data) + article score) + (while data + (and (gnus-data-unread-p (car data)) + (> (setq score + (gnus-summary-article-score (gnus-data-number (car data)))) + best) + (setq best score + article (gnus-data-number (car data)))) + (setq data (cdr data))) + (prog1 + (if article + (gnus-summary-goto-article article) + (error "No unread articles")) + (gnus-summary-position-point)))) + +(defun gnus-summary-last-subject () + "Go to the last displayed subject line in the group." + (let ((article (gnus-data-number (car (gnus-data-list t))))) + (when article + (gnus-summary-goto-subject article)))) + +(defun gnus-summary-goto-article (article &optional all-headers force) + "Fetch ARTICLE (article number or Message-ID) and display it if it exists. +If ALL-HEADERS is non-nil, no header lines are hidden." + (interactive + (list + (completing-read + "Article number or Message-ID: " + (mapcar (lambda (number) (list (int-to-string number))) + gnus-newsgroup-limit)) + current-prefix-arg + t)) + (prog1 + (if (and (stringp article) + (string-match "@" article)) + (gnus-summary-refer-article article) + (when (stringp article) + (setq article (string-to-number article))) + (if (gnus-summary-goto-subject article force) + (gnus-summary-display-article article all-headers) + (gnus-message 4 "Couldn't go to article %s" article) nil)) + (gnus-summary-position-point))) + +(defun gnus-summary-goto-last-article () + "Go to the previously read article." + (interactive) + (prog1 + (when gnus-last-article + (gnus-summary-goto-article gnus-last-article)) + (gnus-summary-position-point))) + +(defun gnus-summary-pop-article (number) + "Pop one article off the history and go to the previous. +NUMBER articles will be popped off." + (interactive "p") + (let (to) + (setq gnus-newsgroup-history + (cdr (setq to (nthcdr number gnus-newsgroup-history)))) + (if to + (gnus-summary-goto-article (car to)) + (error "Article history empty"))) + (gnus-summary-position-point)) + +;; Summary commands and functions for limiting the summary buffer. + +(defun gnus-summary-limit-to-articles (n) + "Limit the summary buffer to the next N articles. +If not given a prefix, use the process marked articles instead." + (interactive "P") + (gnus-set-global-variables) + (prog1 + (let ((articles (gnus-summary-work-articles n))) + (setq gnus-newsgroup-processable nil) + (gnus-summary-limit articles)) + (gnus-summary-position-point))) + +(defun gnus-summary-pop-limit (&optional total) + "Restore the previous limit. +If given a prefix, remove all limits." + (interactive "P") + (gnus-set-global-variables) + (when total + (setq gnus-newsgroup-limits + (list (mapcar (lambda (h) (mail-header-number h)) + gnus-newsgroup-headers)))) + (unless gnus-newsgroup-limits + (error "No limit to pop")) + (prog1 + (gnus-summary-limit nil 'pop) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-to-subject (subject &optional header) + "Limit the summary buffer to articles that have subjects that match a regexp." + (interactive "sLimit to subject (regexp): ") + (unless header + (setq header "subject")) + (when (not (equal "" subject)) + (prog1 + (let ((articles (gnus-summary-find-matching + (or header "subject") subject 'all))) + (unless articles + (error "Found no matches for \"%s\"" subject)) + (gnus-summary-limit articles)) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-to-author (from) + "Limit the summary buffer to articles that have authors that match a regexp." + (interactive "sLimit to author (regexp): ") + (gnus-summary-limit-to-subject from "from")) + +(defun gnus-summary-limit-to-age (age &optional younger-p) + "Limit the summary buffer to articles that are older than (or equal) AGE days. +If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to +articles that are younger than AGE days." + (interactive "nTime in days: \nP") + (prog1 + (let ((data gnus-newsgroup-data) + (cutoff (nnmail-days-to-time age)) + articles d date is-younger) + (while (setq d (pop data)) + (when (and (vectorp (gnus-data-header d)) + (setq date (mail-header-date (gnus-data-header d)))) + (setq is-younger (nnmail-time-less + (nnmail-time-since (nnmail-date-to-time date)) + cutoff)) + (when (if younger-p is-younger (not is-younger)) + (push (gnus-data-number d) articles)))) + (gnus-summary-limit (nreverse articles))) + (gnus-summary-position-point))) + +(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) +(make-obsolete + 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) + +(defun gnus-summary-limit-to-unread (&optional all) + "Limit the summary buffer to articles that are not marked as read. +If ALL is non-nil, limit strictly to unread articles." + (interactive "P") + (if all + (gnus-summary-limit-to-marks (char-to-string gnus-unread-mark)) + (gnus-summary-limit-to-marks + ;; Concat all the marks that say that an article is read and have + ;; those removed. + (list gnus-del-mark gnus-read-mark gnus-ancient-mark + gnus-killed-mark gnus-kill-file-mark + gnus-low-score-mark gnus-expirable-mark + gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark + gnus-duplicate-mark gnus-souped-mark) + 'reverse))) + +(defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-exclude-marks) +(make-obsolete 'gnus-summary-delete-marked-with + 'gnus-summary-limit-exlude-marks) + +(defun gnus-summary-limit-exclude-marks (marks &optional reverse) + "Exclude articles that are marked with MARKS (e.g. \"DK\"). +If REVERSE, limit the summary buffer to articles that are marked +with MARKS. MARKS can either be a string of marks or a list of marks. +Returns how many articles were removed." + (interactive "sMarks: ") + (gnus-summary-limit-to-marks marks t)) + +(defun gnus-summary-limit-to-marks (marks &optional reverse) + "Limit the summary buffer to articles that are marked with MARKS (e.g. \"DK\"). +If REVERSE (the prefix), limit the summary buffer to articles that are +not marked with MARKS. MARKS can either be a string of marks or a +list of marks. +Returns how many articles were removed." + (interactive "sMarks: \nP") + (gnus-set-global-variables) + (prog1 + (let ((data gnus-newsgroup-data) + (marks (if (listp marks) marks + (append marks nil))) ; Transform to list. + articles) + (while data + (when (if reverse (not (memq (gnus-data-mark (car data)) marks)) + (memq (gnus-data-mark (car data)) marks)) + (push (gnus-data-number (car data)) articles)) + (setq data (cdr data))) + (gnus-summary-limit articles)) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-to-score (&optional score) + "Limit to articles with score at or above SCORE." + (interactive "P") + (gnus-set-global-variables) + (setq score (if score + (prefix-numeric-value score) + (or gnus-summary-default-score 0))) + (let ((data gnus-newsgroup-data) + articles) + (while data + (when (>= (gnus-summary-article-score (gnus-data-number (car data))) + score) + (push (gnus-data-number (car data)) articles)) + (setq data (cdr data))) + (prog1 + (gnus-summary-limit articles) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-include-thread (id) + "Display all the hidden articles that in the current thread." + (interactive (mail-header-id (gnus-summary-article-header))) + (gnus-set-global-variables) + (let ((articles (gnus-articles-in-thread + (gnus-id-to-thread (gnus-root-id id))))) + (prog1 + (gnus-summary-limit (nconc articles gnus-newsgroup-limit)) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-include-dormant () + "Display all the hidden articles that are marked as dormant." + (interactive) + (gnus-set-global-variables) + (unless gnus-newsgroup-dormant + (error "There are no dormant articles in this group")) + (prog1 + (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit)) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-exclude-dormant () + "Hide all dormant articles." + (interactive) + (gnus-set-global-variables) + (prog1 + (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-exclude-childless-dormant () + "Hide all dormant articles that have no children." + (interactive) + (gnus-set-global-variables) + (let ((data (gnus-data-list t)) + articles d children) + ;; Find all articles that are either not dormant or have + ;; children. + (while (setq d (pop data)) + (when (or (not (= (gnus-data-mark d) gnus-dormant-mark)) + (and (setq children + (gnus-article-children (gnus-data-number d))) + (let (found) + (while children + (when (memq (car children) articles) + (setq children nil + found t)) + (pop children)) + found))) + (push (gnus-data-number d) articles))) + ;; Do the limiting. + (prog1 + (gnus-summary-limit articles) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-mark-excluded-as-read (&optional all) + "Mark all unread excluded articles as read. +If ALL, mark even excluded ticked and dormants as read." + (interactive "P") + (let ((articles (gnus-sorted-complement + (sort + (mapcar (lambda (h) (mail-header-number h)) + gnus-newsgroup-headers) + '<) + (sort gnus-newsgroup-limit '<))) + article) + (setq gnus-newsgroup-unreads gnus-newsgroup-limit) + (if all + (setq gnus-newsgroup-dormant nil + gnus-newsgroup-marked nil + gnus-newsgroup-reads + (nconc + (mapcar (lambda (n) (cons n gnus-catchup-mark)) articles) + gnus-newsgroup-reads)) + (while (setq article (pop articles)) + (unless (or (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-marked)) + (push (cons article gnus-catchup-mark) gnus-newsgroup-reads)))))) + +(defun gnus-summary-limit (articles &optional pop) + (if pop + ;; We pop the previous limit off the stack and use that. + (setq articles (car gnus-newsgroup-limits) + gnus-newsgroup-limits (cdr gnus-newsgroup-limits)) + ;; We use the new limit, so we push the old limit on the stack. + (push gnus-newsgroup-limit gnus-newsgroup-limits)) + ;; Set the limit. + (setq gnus-newsgroup-limit articles) + (let ((total (length gnus-newsgroup-data)) + (data (gnus-data-find-list (gnus-summary-article-number))) + (gnus-summary-mark-below nil) ; Inhibit this. + found) + ;; This will do all the work of generating the new summary buffer + ;; according to the new limit. + (gnus-summary-prepare) + ;; Hide any threads, possibly. + (and gnus-show-threads + gnus-thread-hide-subtree + (gnus-summary-hide-all-threads)) + ;; Try to return to the article you were at, or one in the + ;; neighborhood. + (when data + ;; We try to find some article after the current one. + (while data + (when (gnus-summary-goto-subject (gnus-data-number (car data)) nil t) + (setq data nil + found t)) + (setq data (cdr data)))) + (unless found + ;; If there is no data, that means that we were after the last + ;; article. The same goes when we can't find any articles + ;; after the current one. + (goto-char (point-max)) + (gnus-summary-find-prev)) + ;; We return how many articles were removed from the summary + ;; buffer as a result of the new limit. + (- total (length gnus-newsgroup-data)))) + +(defsubst gnus-invisible-cut-children (threads) + (let ((num 0)) + (while threads + (when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit) + (incf num)) + (pop threads)) + (< num 2))) + +(defsubst gnus-cut-thread (thread) + "Go forwards in the thread until we find an article that we want to display." + (when (or (eq gnus-fetch-old-headers 'some) + (eq gnus-fetch-old-headers 'invisible) + (eq gnus-build-sparse-threads 'some) + (eq gnus-build-sparse-threads 'more)) + ;; Deal with old-fetched headers and sparse threads. + (while (and + thread + (or + (gnus-summary-article-sparse-p (mail-header-number (car thread))) + (gnus-summary-article-ancient-p + (mail-header-number (car thread)))) + (if (or (<= (length (cdr thread)) 1) + (eq gnus-fetch-old-headers 'invisible)) + (setq gnus-newsgroup-limit + (delq (mail-header-number (car thread)) + gnus-newsgroup-limit) + thread (cadr thread)) + (when (gnus-invisible-cut-children (cdr thread)) + (let ((th (cdr thread))) + (while th + (if (memq (mail-header-number (caar th)) + gnus-newsgroup-limit) + (setq thread (car th) + th nil) + (setq th (cdr th)))))))))) + thread) + +(defun gnus-cut-threads (threads) + "Cut off all uninteresting articles from the beginning of threads." + (when (or (eq gnus-fetch-old-headers 'some) + (eq gnus-fetch-old-headers 'invisible) + (eq gnus-build-sparse-threads 'some) + (eq gnus-build-sparse-threads 'more)) + (let ((th threads)) + (while th + (setcar th (gnus-cut-thread (car th))) + (setq th (cdr th))))) + ;; Remove nixed out threads. + (delq nil threads)) + +(defun gnus-summary-initial-limit (&optional show-if-empty) + "Figure out what the initial limit is supposed to be on group entry. +This entails weeding out unwanted dormants, low-scored articles, +fetch-old-headers verbiage, and so on." + ;; Most groups have nothing to remove. + (if (or gnus-inhibit-limiting + (and (null gnus-newsgroup-dormant) + (not (eq gnus-fetch-old-headers 'some)) + (not (eq gnus-fetch-old-headers 'invisible)) + (null gnus-summary-expunge-below) + (not (eq gnus-build-sparse-threads 'some)) + (not (eq gnus-build-sparse-threads 'more)) + (null gnus-thread-expunge-below) + (not gnus-use-nocem))) + () ; Do nothing. + (push gnus-newsgroup-limit gnus-newsgroup-limits) + (setq gnus-newsgroup-limit nil) + (mapatoms + (lambda (node) + (unless (car (symbol-value node)) + ;; These threads have no parents -- they are roots. + (let ((nodes (cdr (symbol-value node))) + thread) + (while nodes + (if (and gnus-thread-expunge-below + (< (gnus-thread-total-score (car nodes)) + gnus-thread-expunge-below)) + (gnus-expunge-thread (pop nodes)) + (setq thread (pop nodes)) + (gnus-summary-limit-children thread)))))) + gnus-newsgroup-dependencies) + ;; If this limitation resulted in an empty group, we might + ;; pop the previous limit and use it instead. + (when (and (not gnus-newsgroup-limit) + show-if-empty) + (setq gnus-newsgroup-limit (pop gnus-newsgroup-limits))) + gnus-newsgroup-limit)) + +(defun gnus-summary-limit-children (thread) + "Return 1 if this subthread is visible and 0 if it is not." + ;; First we get the number of visible children to this thread. This + ;; is done by recursing down the thread using this function, so this + ;; will really go down to a leaf article first, before slowly + ;; working its way up towards the root. + (when thread + (let ((children + (if (cdr thread) + (apply '+ (mapcar 'gnus-summary-limit-children + (cdr thread))) + 0)) + (number (mail-header-number (car thread))) + score) + (if (and + (not (memq number gnus-newsgroup-marked)) + (or + ;; If this article is dormant and has absolutely no visible + ;; children, then this article isn't visible. + (and (memq number gnus-newsgroup-dormant) + (zerop children)) + ;; If this is "fetch-old-headered" and there is no + ;; visible children, then we don't want this article. + (and (eq gnus-fetch-old-headers 'some) + (gnus-summary-article-ancient-p number) + (zerop children)) + ;; If this is "fetch-old-headered" and `invisible', then + ;; we don't want this article. + (and (eq gnus-fetch-old-headers 'invisible) + (gnus-summary-article-ancient-p number)) + ;; If this is a sparsely inserted article with no children, + ;; we don't want it. + (and (eq gnus-build-sparse-threads 'some) + (gnus-summary-article-sparse-p number) + (zerop children)) + ;; If we use expunging, and this article is really + ;; low-scored, then we don't want this article. + (when (and gnus-summary-expunge-below + (< (setq score + (or (cdr (assq number gnus-newsgroup-scored)) + gnus-summary-default-score)) + gnus-summary-expunge-below)) + ;; We increase the expunge-tally here, but that has + ;; nothing to do with the limits, really. + (incf gnus-newsgroup-expunged-tally) + ;; We also mark as read here, if that's wanted. + (when (and gnus-summary-mark-below + (< score gnus-summary-mark-below)) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads))) + t) + ;; Check NoCeM things. + (if (and gnus-use-nocem + (gnus-nocem-unwanted-article-p + (mail-header-id (car thread)))) + (progn + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + t)))) + ;; Nope, invisible article. + 0 + ;; Ok, this article is to be visible, so we add it to the limit + ;; and return 1. + (push number gnus-newsgroup-limit) + 1)))) + +(defun gnus-expunge-thread (thread) + "Mark all articles in THREAD as read." + (let* ((number (mail-header-number (car thread)))) + (incf gnus-newsgroup-expunged-tally) + ;; We also mark as read here, if that's wanted. + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads))) + ;; Go recursively through all subthreads. + (mapcar 'gnus-expunge-thread (cdr thread))) + +;; Summary article oriented commands + +(defun gnus-summary-refer-parent-article (n) + "Refer parent article N times. +If N is negative, go to ancestor -N instead. +The difference between N and the number of articles fetched is returned." + (interactive "p") + (gnus-set-global-variables) + (let ((skip 1) + error header ref) + (when (not (natnump n)) + (setq skip (abs n) + n 1)) + (while (and (> n 0) + (not error)) + (setq header (gnus-summary-article-header)) + (if (and (eq (mail-header-number header) + (cdr gnus-article-current)) + (equal gnus-newsgroup-name + (car gnus-article-current))) + ;; If we try to find the parent of the currently + ;; displayed article, then we take a look at the actual + ;; References header, since this is slightly more + ;; reliable than the References field we got from the + ;; server. + (save-excursion + (set-buffer gnus-original-article-buffer) + (nnheader-narrow-to-headers) + (unless (setq ref (message-fetch-field "references")) + (setq ref (message-fetch-field "in-reply-to"))) + (widen)) + (setq ref + ;; It's not the current article, so we take a bet on + ;; the value we got from the server. + (mail-header-references header))) + (if (and ref + (not (equal ref ""))) + (unless (gnus-summary-refer-article (gnus-parent-id ref skip)) + (gnus-message 1 "Couldn't find parent")) + (gnus-message 1 "No references in article %d" + (gnus-summary-article-number)) + (setq error t)) + (decf n)) + (gnus-summary-position-point) + n)) + +(defun gnus-summary-refer-references () + "Fetch all articles mentioned in the References header. +Return the number of articles fetched." + (interactive) + (gnus-set-global-variables) + (let ((ref (mail-header-references (gnus-summary-article-header))) + (current (gnus-summary-article-number)) + (n 0)) + (if (or (not ref) + (equal ref "")) + (error "No References in the current article") + ;; For each Message-ID in the References header... + (while (string-match "<[^>]*>" ref) + (incf n) + ;; ... fetch that article. + (gnus-summary-refer-article + (prog1 (match-string 0 ref) + (setq ref (substring ref (match-end 0)))))) + (gnus-summary-goto-subject current) + (gnus-summary-position-point) + n))) + +(defun gnus-summary-refer-thread (&optional limit) + "Fetch all articles in the current thread. +If LIMIT (the numerical prefix), fetch that many old headers instead +of what's specified by the `gnus-refer-thread-limit' variable." + (interactive "P") + (gnus-set-global-variables) + (let ((id (mail-header-id (gnus-summary-article-header))) + (limit (if limit (prefix-numeric-value limit) + gnus-refer-thread-limit)) + fmethod root) + ;; We want to fetch LIMIT *old* headers, but we also have to + ;; re-fetch all the headers in the current buffer, because many of + ;; them may be undisplayed. So we adjust LIMIT. + (when (numberp limit) + (incf limit (- gnus-newsgroup-end gnus-newsgroup-begin))) + (unless (eq gnus-fetch-old-headers 'invisible) + (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) + ;; Retrieve the headers and read them in. + (if (eq (gnus-retrieve-headers + (list gnus-newsgroup-end) gnus-newsgroup-name limit) + 'nov) + (gnus-build-all-threads) + (error "Can't fetch thread from backends that don't support NOV")) + (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) + (gnus-summary-limit-include-thread id))) + +(defun gnus-summary-refer-article (message-id &optional arg) + "Fetch an article specified by MESSAGE-ID. +If ARG (the prefix), fetch the article using `gnus-refer-article-method' +or `gnus-select-method', no matter what backend the article comes from." + (interactive "sMessage-ID: \nP") + (when (and (stringp message-id) + (not (zerop (length message-id)))) + ;; Construct the correct Message-ID if necessary. + ;; Suggested by tale@pawl.rpi.edu. + (unless (string-match "^<" message-id) + (setq message-id (concat "<" message-id))) + (unless (string-match ">$" message-id) + (setq message-id (concat message-id ">"))) + (let* ((header (gnus-id-to-header message-id)) + (sparse (and header + (gnus-summary-article-sparse-p + (mail-header-number header)) + (memq (mail-header-number header) + gnus-newsgroup-limit)))) + (if (and header + (or (not (gnus-summary-article-sparse-p + (mail-header-number header))) + sparse)) + (prog1 + ;; The article is present in the buffer, so we just go to it. + (gnus-summary-goto-article + (mail-header-number header) nil t) + (when sparse + (gnus-summary-update-article (mail-header-number header)))) + ;; We fetch the article + (let ((gnus-override-method + (cond ((gnus-news-group-p gnus-newsgroup-name) + gnus-refer-article-method) + (arg + (or gnus-refer-article-method gnus-select-method)) + (t nil))) + number) + ;; Start the special refer-article method, if necessary. + (when (and gnus-refer-article-method + (gnus-news-group-p gnus-newsgroup-name)) + (gnus-check-server gnus-refer-article-method)) + ;; Fetch the header, and display the article. + (if (setq number (gnus-summary-insert-subject message-id)) + (gnus-summary-select-article nil nil nil number) + (gnus-message 3 "Couldn't fetch article %s" message-id))))))) + +(defun gnus-summary-enter-digest-group (&optional force) + "Enter an nndoc group based on the current article. +If FORCE, force a digest interpretation. If not, try +to guess what the document format is." + (interactive "P") + (gnus-set-global-variables) + (let ((conf gnus-current-window-configuration)) + (save-excursion + (gnus-summary-select-article)) + (setq gnus-current-window-configuration conf) + (let* ((name (format "%s-%d" + (gnus-group-prefixed-name + gnus-newsgroup-name (list 'nndoc "")) + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-current-article))) + (ogroup gnus-newsgroup-name) + (params (append (gnus-info-params (gnus-get-info ogroup)) + (list (cons 'to-group ogroup)) + (list (cons 'save-article-group ogroup)))) + (case-fold-search t) + (buf (current-buffer)) + dig) + (save-excursion + (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) + (insert-buffer-substring gnus-original-article-buffer) + ;; Remove lines that may lead nndoc to misinterpret the + ;; document type. + (narrow-to-region + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point))) + (goto-char (point-min)) + (delete-matching-lines "^\\(Path\\):\\|^From ") + (widen)) + (unwind-protect + (if (gnus-group-read-ephemeral-group + name `(nndoc ,name (nndoc-address ,(get-buffer dig)) + (nndoc-article-type + ,(if force 'digest 'guess))) t) + ;; Make all postings to this group go to the parent group. + (nconc (gnus-info-params (gnus-get-info name)) + params) + ;; Couldn't select this doc group. + (switch-to-buffer buf) + (gnus-set-global-variables) + (gnus-configure-windows 'summary) + (gnus-message 3 "Article couldn't be entered?")) + (kill-buffer dig))))) + +(defun gnus-summary-read-document (n) + "Open a new group based on the current article(s). +This will allow you to read digests and other similar +documents as newsgroups. +Obeys the standard process/prefix convention." + (interactive "P") + (let* ((articles (gnus-summary-work-articles n)) + (ogroup gnus-newsgroup-name) + (params (append (gnus-info-params (gnus-get-info ogroup)) + (list (cons 'to-group ogroup)))) + article group egroup groups vgroup) + (while (setq article (pop articles)) + (setq group (format "%s-%d" gnus-newsgroup-name article)) + (gnus-summary-remove-process-mark article) + (when (gnus-summary-display-article article) + (save-excursion + (nnheader-temp-write nil + (insert-buffer-substring gnus-original-article-buffer) + ;; Remove some headers that may lead nndoc to make + ;; the wrong guess. + (message-narrow-to-head) + (goto-char (point-min)) + (delete-matching-lines "^\\(Path\\):\\|^From ") + (widen) + (if (setq egroup + (gnus-group-read-ephemeral-group + group `(nndoc ,group (nndoc-address ,(current-buffer)) + (nndoc-article-type guess)) + t nil t)) + (progn + ;; Make all postings to this group go to the parent group. + (nconc (gnus-info-params (gnus-get-info egroup)) + params) + (push egroup groups)) + ;; Couldn't select this doc group. + (gnus-error 3 "Article couldn't be entered")))))) + ;; Now we have selected all the documents. + (cond + ((not groups) + (error "None of the articles could be interpreted as documents")) + ((gnus-group-read-ephemeral-group + (setq vgroup (format + "nnvirtual:%s-%s" gnus-newsgroup-name + (format-time-string "%Y%m%dT%H%M%S" (current-time)))) + `(nnvirtual ,vgroup (nnvirtual-component-groups ,groups)) + t + (cons (current-buffer) 'summary))) + (t + (error "Couldn't select virtual nndoc group"))))) + +(defun gnus-summary-isearch-article (&optional regexp-p) + "Do incremental search forward on the current article. +If REGEXP-P (the prefix) is non-nil, do regexp isearch." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (gnus-eval-in-buffer-window gnus-article-buffer + ;;(goto-char (point-min)) + (isearch-forward regexp-p))) + +(defun gnus-summary-search-article-forward (regexp &optional backward) + "Search for an article containing REGEXP forward. +If BACKWARD, search backward instead." + (interactive + (list (read-string + (format "Search article %s (regexp%s): " + (if current-prefix-arg "backward" "forward") + (if gnus-last-search-regexp + (concat ", default " gnus-last-search-regexp) + ""))) + current-prefix-arg)) + (gnus-set-global-variables) + (if (string-equal regexp "") + (setq regexp (or gnus-last-search-regexp "")) + (setq gnus-last-search-regexp regexp)) + (if (gnus-summary-search-article regexp backward) + (gnus-summary-show-thread) + (error "Search failed: \"%s\"" regexp))) + +(defun gnus-summary-search-article-backward (regexp) + "Search for an article containing REGEXP backward." + (interactive + (list (read-string + (format "Search article backward (regexp%s): " + (if gnus-last-search-regexp + (concat ", default " gnus-last-search-regexp) + ""))))) + (gnus-summary-search-article-forward regexp 'backward)) + +(defun gnus-summary-search-article (regexp &optional backward) + "Search for an article containing REGEXP. +Optional argument BACKWARD means do search for backward. +`gnus-select-article-hook' is not called during the search." + ;; We have to require this here to make sure that the following + ;; dynamic binding isn't shadowed by autoloading. + (require 'gnus-async) + (let ((gnus-select-article-hook nil) ;Disable hook. + (gnus-article-display-hook nil) + (gnus-mark-article-hook nil) ;Inhibit marking as read. + (gnus-use-article-prefetch nil) + (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. + (gnus-use-trees nil) ;Inhibit updating tree buffer. + (sum (current-buffer)) + (found nil) + point) + (gnus-save-hidden-threads + (gnus-summary-select-article) + (set-buffer gnus-article-buffer) + (when backward + (forward-line -1)) + (while (not found) + (gnus-message 7 "Searching article: %d..." (cdr gnus-article-current)) + (if (if backward + (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + ;; We found the regexp. + (progn + (setq found 'found) + (beginning-of-line) + (set-window-start + (get-buffer-window (current-buffer)) + (point)) + (forward-line 1) + (set-buffer sum) + (setq point (point))) + ;; We didn't find it, so we go to the next article. + (set-buffer sum) + (setq found 'not) + (while (eq found 'not) + (if (not (if backward (gnus-summary-find-prev) + (gnus-summary-find-next))) + ;; No more articles. + (setq found t) + ;; Select the next article and adjust point. + (unless (gnus-summary-article-sparse-p + (gnus-summary-article-number)) + (setq found nil) + (gnus-summary-select-article) + (set-buffer gnus-article-buffer) + (widen) + (goto-char (if backward (point-max) (point-min)))))))) + (gnus-message 7 "")) + ;; Return whether we found the regexp. + (when (eq found 'found) + (goto-char point) + (gnus-summary-show-thread) + (gnus-summary-goto-subject gnus-current-article) + (gnus-summary-position-point) + t))) + +(defun gnus-summary-find-matching (header regexp &optional backward unread + not-case-fold) + "Return a list of all articles that match REGEXP on HEADER. +The search stars on the current article and goes forwards unless +BACKWARD is non-nil. If BACKWARD is `all', do all articles. +If UNREAD is non-nil, only unread articles will +be taken into consideration. If NOT-CASE-FOLD, case won't be folded +in the comparisons." + (let ((data (if (eq backward 'all) gnus-newsgroup-data + (gnus-data-find-list + (gnus-summary-article-number) (gnus-data-list backward)))) + (func `(lambda (h) (,(intern (concat "mail-header-" header)) h))) + (case-fold-search (not not-case-fold)) + articles d) + (unless (fboundp (intern (concat "mail-header-" header))) + (error "%s is not a valid header" header)) + (while data + (setq d (car data)) + (and (or (not unread) ; We want all articles... + (gnus-data-unread-p d)) ; Or just unreads. + (vectorp (gnus-data-header d)) ; It's not a pseudo. + (string-match regexp (funcall func (gnus-data-header d))) ; Match. + (push (gnus-data-number d) articles)) ; Success! + (setq data (cdr data))) + (nreverse articles))) + +(defun gnus-summary-execute-command (header regexp command &optional backward) + "Search forward for an article whose HEADER matches REGEXP and execute COMMAND. +If HEADER is an empty string (or nil), the match is done on the entire +article. If BACKWARD (the prefix) is non-nil, search backward instead." + (interactive + (list (let ((completion-ignore-case t)) + (completing-read + "Header name: " + (mapcar (lambda (string) (list string)) + '("Number" "Subject" "From" "Lines" "Date" + "Message-ID" "Xref" "References" "Body")) + nil 'require-match)) + (read-string "Regexp: ") + (read-key-sequence "Command: ") + current-prefix-arg)) + (when (equal header "Body") + (setq header "")) + (gnus-set-global-variables) + ;; Hidden thread subtrees must be searched as well. + (gnus-summary-show-all-threads) + ;; We don't want to change current point nor window configuration. + (save-excursion + (save-window-excursion + (gnus-message 6 "Executing %s..." (key-description command)) + ;; We'd like to execute COMMAND interactively so as to give arguments. + (gnus-execute header regexp + `(call-interactively ',(key-binding command)) + backward) + (gnus-message 6 "Executing %s...done" (key-description command))))) + +(defun gnus-summary-beginning-of-article () + "Scroll the article back to the beginning." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (gnus-eval-in-buffer-window gnus-article-buffer + (widen) + (goto-char (point-min)) + (when gnus-page-broken + (gnus-narrow-to-page)))) + +(defun gnus-summary-end-of-article () + "Scroll to the end of the article." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (gnus-eval-in-buffer-window gnus-article-buffer + (widen) + (goto-char (point-max)) + (recenter -3) + (when gnus-page-broken + (gnus-narrow-to-page)))) + +(defun gnus-summary-print-article (&optional filename) + "Generate and print a PostScript image of the article buffer. + +If the optional argument FILENAME is nil, send the image to the printer. +If FILENAME is a string, save the PostScript image in a file with that +name. If FILENAME is a number, prompt the user for the name of the file +to save in." + (interactive (list (ps-print-preprint current-prefix-arg))) + (gnus-summary-select-article) + (gnus-eval-in-buffer-window gnus-article-buffer + (let ((buffer (generate-new-buffer " *print*"))) + (unwind-protect + (progn + (copy-to-buffer buffer (point-min) (point-max)) + (set-buffer buffer) + (gnus-article-delete-invisible-text) + (run-hooks 'gnus-ps-print-hook) + (ps-print-buffer-with-faces filename)) + (kill-buffer buffer))))) + +(defun gnus-summary-show-article (&optional arg) + "Force re-fetching of the current article. +If ARG (the prefix) is non-nil, show the raw article without any +article massaging functions being run." + (interactive "P") + (gnus-set-global-variables) + (if (not arg) + ;; Select the article the normal way. + (gnus-summary-select-article nil 'force) + ;; Bind the article treatment functions to nil. + (let ((gnus-have-all-headers t) + gnus-article-display-hook + gnus-article-prepare-hook + gnus-break-pages + gnus-show-mime + gnus-visual) + (gnus-summary-select-article nil 'force))) + (gnus-summary-goto-subject gnus-current-article) + (gnus-summary-position-point)) + +(defun gnus-summary-verbose-headers (&optional arg) + "Toggle permanent full header display. +If ARG is a positive number, turn header display on. +If ARG is a negative number, turn header display off." + (interactive "P") + (gnus-set-global-variables) + (setq gnus-show-all-headers + (cond ((or (not (numberp arg)) + (zerop arg)) + (not gnus-show-all-headers)) + ((natnump arg) + t))) + (gnus-summary-show-article)) + +(defun gnus-summary-toggle-header (&optional arg) + "Show the headers if they are hidden, or hide them if they are shown. +If ARG is a positive number, show the entire header. +If ARG is a negative number, hide the unwanted header lines." + (interactive "P") + (gnus-set-global-variables) + (save-excursion + (set-buffer gnus-article-buffer) + (let* ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (hidden (text-property-any + (goto-char (point-min)) (search-forward "\n\n") + 'invisible t)) + e) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (point-min) (1- (point)))) + (goto-char (point-min)) + (save-excursion + (set-buffer gnus-original-article-buffer) + (goto-char (point-min)) + (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) + (insert-buffer-substring gnus-original-article-buffer 1 e) + (let ((article-inhibit-hiding t)) + (run-hooks 'gnus-article-display-hook)) + (when (or (not hidden) (and (numberp arg) (< arg 0))) + (gnus-article-hide-headers))))) + +(defun gnus-summary-show-all-headers () + "Make all header lines visible." + (interactive) + (gnus-set-global-variables) + (gnus-article-show-all-headers)) + +(defun gnus-summary-toggle-mime (&optional arg) + "Toggle MIME processing. +If ARG is a positive number, turn MIME processing on." + (interactive "P") + (gnus-set-global-variables) + (setq gnus-show-mime + (if (null arg) (not gnus-show-mime) + (> (prefix-numeric-value arg) 0))) + (gnus-summary-select-article t 'force)) + +(defun gnus-summary-caesar-message (&optional arg) + "Caesar rotate the current article by 13. +The numerical prefix specifies how many places to rotate each letter +forward." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-select-article) + (let ((mail-header-separator "")) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (let ((start (window-start)) + buffer-read-only) + (message-caesar-buffer-body arg) + (set-window-start (get-buffer-window (current-buffer)) start)))))) + +(defun gnus-summary-stop-page-breaking () + "Stop page breaking in the current article." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-eval-in-buffer-window gnus-article-buffer + (widen) + (when (gnus-visual-p 'page-marker) + (let ((buffer-read-only nil)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next))))) + +(defun gnus-summary-move-article (&optional n to-newsgroup + select-method action) + "Move the current article to a different newsgroup. +If N is a positive number, move the N next articles. +If N is a negative number, move the N previous articles. +If N is nil and any articles have been marked with the process mark, +move those articles instead. +If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. +If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but +re-spool using this method. + +For this function to work, both the current newsgroup and the +newsgroup that you want to move to have to support the `request-move' +and `request-accept' functions." + (interactive "P") + (unless action + (setq action 'move)) + (gnus-set-global-variables) + ;; Disable marking as read. + (let (gnus-mark-article-hook) + (save-window-excursion + (gnus-summary-select-article))) + ;; Check whether the source group supports the required functions. + (cond ((and (eq action 'move) + (not (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name))) + (error "The current group does not support article moving")) + ((and (eq action 'crosspost) + (not (gnus-check-backend-function + 'request-replace-article gnus-newsgroup-name))) + (error "The current group does not support article editing"))) + (let ((articles (gnus-summary-work-articles n)) + (prefix (gnus-group-real-prefix gnus-newsgroup-name)) + (names '((move "Move" "Moving") + (copy "Copy" "Copying") + (crosspost "Crosspost" "Crossposting"))) + (copy-buf (save-excursion + (nnheader-set-temp-buffer " *copy article*"))) + art-group to-method new-xref article to-groups) + (unless (assq action names) + (error "Unknown action %s" action)) + ;; Read the newsgroup name. + (when (and (not to-newsgroup) + (not select-method)) + (setq to-newsgroup + (gnus-read-move-group-name + (cadr (assq action names)) + (symbol-value (intern (format "gnus-current-%s-group" action))) + articles prefix)) + (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) + (setq to-method (or select-method + (gnus-group-name-to-method to-newsgroup))) + ;; Check the method we are to move this article to... + (unless (gnus-check-backend-function + 'request-accept-article (car to-method)) + (error "%s does not support article copying" (car to-method))) + (unless (gnus-check-server to-method) + (error "Can't open server %s" (car to-method))) + (gnus-message 6 "%s to %s: %s..." + (caddr (assq action names)) + (or (car select-method) to-newsgroup) articles) + (while articles + (setq article (pop articles)) + (setq + art-group + (cond + ;; Move the article. + ((eq action 'move) + ;; Remove this article from future suppression. + (gnus-dup-unsuppress-article article) + (gnus-request-move-article + article ; Article to move + gnus-newsgroup-name ; From newsgroup + (nth 1 (gnus-find-method-for-group + gnus-newsgroup-name)) ; Server + (list 'gnus-request-accept-article + to-newsgroup (list 'quote select-method) + (not articles)) ; Accept form + (not articles))) ; Only save nov last time + ;; Copy the article. + ((eq action 'copy) + (save-excursion + (set-buffer copy-buf) + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (gnus-request-accept-article + to-newsgroup select-method (not articles)))) + ;; Crosspost the article. + ((eq action 'crosspost) + (let ((xref (message-tokenize-header + (mail-header-xref (gnus-summary-article-header article)) + " "))) + (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) + ":" article)) + (unless xref + (setq xref (list (system-name)))) + (setq new-xref + (concat + (mapconcat 'identity + (delete "Xref:" (delete new-xref xref)) + " ") + " " new-xref)) + (save-excursion + (set-buffer copy-buf) + ;; First put the article in the destination group. + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (when (consp (setq art-group + (gnus-request-accept-article + to-newsgroup select-method (not articles)))) + (setq new-xref (concat new-xref " " (car art-group) + ":" (cdr art-group))) + ;; Now we have the new Xrefs header, so we insert + ;; it and replace the new article. + (nnheader-replace-header "Xref" new-xref) + (gnus-request-replace-article + (cdr art-group) to-newsgroup (current-buffer)) + art-group)))))) + (cond + ((not art-group) + (gnus-message 1 "Couldn't %s article %s" + (cadr (assq action names)) article)) + ((and (eq art-group 'junk) + (eq action 'move)) + (gnus-summary-mark-article article gnus-canceled-mark) + (gnus-message 4 "Deleted article %s" article)) + (t + (let* ((entry + (or + (gnus-gethash (car art-group) gnus-newsrc-hashtb) + (gnus-gethash + (gnus-group-prefixed-name + (car art-group) + (or select-method + (gnus-find-method-for-group to-newsgroup))) + gnus-newsrc-hashtb))) + (info (nth 2 entry)) + (to-group (gnus-info-group info))) + ;; Update the group that has been moved to. + (when (and info + (memq action '(move copy))) + (unless (member to-group to-groups) + (push to-group to-groups)) + + (unless (memq article gnus-newsgroup-unreads) + (gnus-info-set-read + info (gnus-add-to-range (gnus-info-read info) + (list (cdr art-group))))) + + ;; Copy any marks over to the new group. + (let ((marks gnus-article-mark-lists) + (to-article (cdr art-group))) + + ;; See whether the article is to be put in the cache. + (when gnus-use-cache + (gnus-cache-possibly-enter-article + to-group to-article + (let ((header (copy-sequence + (gnus-summary-article-header article)))) + (mail-header-set-number header to-article) + header) + (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-unreads))) + + (when (and (equal to-group gnus-newsgroup-name) + (not (memq article gnus-newsgroup-unreads))) + ;; Mark this article as read in this group. + (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) + (setcdr (gnus-active to-group) to-article) + (setcdr gnus-newsgroup-active to-article)) + + (while marks + (when (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + ;; If the other group is the same as this group, + ;; then we have to add the mark to the list. + (when (equal to-group gnus-newsgroup-name) + (set (intern (format "gnus-newsgroup-%s" (caar marks))) + (cons to-article + (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))))) + ;; Copy the marks to other group. + (gnus-add-marked-articles + to-group (cdar marks) (list to-article) info)) + (setq marks (cdr marks))) + + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (gnus-get-info to-group)) + ")")))) + + ;; Update the Xref header in this article to point to + ;; the new crossposted article we have just created. + (when (eq action 'crosspost) + (save-excursion + (set-buffer copy-buf) + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (nnheader-replace-header "Xref" new-xref) + (gnus-request-replace-article + article gnus-newsgroup-name (current-buffer))))) + + (gnus-summary-goto-subject article) + (when (eq action 'move) + (gnus-summary-mark-article article gnus-canceled-mark)))) + (gnus-summary-remove-process-mark article)) + ;; Re-activate all groups that have been moved to. + (while to-groups + (save-excursion + (set-buffer gnus-group-buffer) + (when (gnus-group-goto-group (car to-groups) t) + (gnus-group-get-new-news-this-group 1 t)) + (pop to-groups))) + + (gnus-kill-buffer copy-buf) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary))) + +(defun gnus-summary-copy-article (&optional n to-newsgroup select-method) + "Move the current article to a different newsgroup. +If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. +If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but +re-spool using this method." + (interactive "P") + (gnus-summary-move-article n to-newsgroup select-method 'copy)) + +(defun gnus-summary-crosspost-article (&optional n) + "Crosspost the current article to some other group." + (interactive "P") + (gnus-summary-move-article n nil nil 'crosspost)) + +(defcustom gnus-summary-respool-default-method nil + "Default method for respooling an article. +If nil, use to the current newsgroup method." + :type `(choice (gnus-select-method :value (nnml "")) + (const nil)) + :group 'gnus-summary-mail) + +(defun gnus-summary-respool-article (&optional n method) + "Respool the current article. +The article will be squeezed through the mail spooling process again, +which means that it will be put in some mail newsgroup or other +depending on `nnmail-split-methods'. +If N is a positive number, respool the N next articles. +If N is a negative number, respool the N previous articles. +If N is nil and any articles have been marked with the process mark, +respool those articles instead. + +Respooling can be done both from mail groups and \"real\" newsgroups. +In the former case, the articles in question will be moved from the +current group into whatever groups they are destined to. In the +latter case, they will be copied into the relevant groups." + (interactive + (list current-prefix-arg + (let* ((methods (gnus-methods-using 'respool)) + (methname + (symbol-name (or gnus-summary-respool-default-method + (car (gnus-find-method-for-group + gnus-newsgroup-name))))) + (method + (gnus-completing-read + methname "What backend do you want to use when respooling?" + methods nil t nil 'gnus-mail-method-history)) + ms) + (cond + ((zerop (length (setq ms (gnus-servers-using-backend + (intern method))))) + (list (intern method) "")) + ((= 1 (length ms)) + (car ms)) + (t + (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms))) + (cdr (assoc (completing-read "Server name: " ms-alist nil t) + ms-alist)))))))) + (gnus-set-global-variables) + (unless method + (error "No method given for respooling")) + (if (assoc (symbol-name + (car (gnus-find-method-for-group gnus-newsgroup-name))) + (gnus-methods-using 'respool)) + (gnus-summary-move-article n nil method) + (gnus-summary-copy-article n nil method))) + +(defun gnus-summary-import-article (file) + "Import a random file into a mail newsgroup." + (interactive "fImport file: ") + (gnus-set-global-variables) + (let ((group gnus-newsgroup-name) + (now (current-time)) + atts lines) + (unless (gnus-check-backend-function 'request-accept-article group) + (error "%s does not support article importing" group)) + (or (file-readable-p file) + (not (file-regular-p file)) + (error "Can't read %s" file)) + (save-excursion + (set-buffer (get-buffer-create " *import file*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-file-contents file) + (goto-char (point-min)) + (unless (nnheader-article-p) + ;; This doesn't look like an article, so we fudge some headers. + (setq atts (file-attributes file) + lines (count-lines (point-min) (point-max))) + (insert "From: " (read-string "From: ") "\n" + "Subject: " (read-string "Subject: ") "\n" + "Date: " (timezone-make-date-arpa-standard + (current-time-string (nth 5 atts)) + (current-time-zone now) + (current-time-zone now)) + "\n" + "Message-ID: " (message-make-message-id) "\n" + "Lines: " (int-to-string lines) "\n" + "Chars: " (int-to-string (nth 7 atts)) "\n\n")) + (gnus-request-accept-article group nil t) + (kill-buffer (current-buffer))))) + +(defun gnus-summary-article-posted-p () + "Say whether the current (mail) article is available from `gnus-select-method' as well. +This will be the case if the article has both been mailed and posted." + (interactive) + (let ((id (mail-header-references (gnus-summary-article-header))) + (gnus-override-method + (or gnus-refer-article-method gnus-select-method))) + (if (gnus-request-head id "") + (gnus-message 2 "The current message was found on %s" + gnus-override-method) + (gnus-message 2 "The current message couldn't be found on %s" + gnus-override-method) + nil))) + +(defun gnus-summary-expire-articles (&optional now) + "Expire all articles that are marked as expirable in the current group." + (interactive) + (gnus-set-global-variables) + (when (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name) + ;; This backend supports expiry. + (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) + (expirable (if total + (progn + ;; We need to update the info for + ;; this group for `gnus-list-of-read-articles' + ;; to give us the right answer. + (run-hooks 'gnus-exit-group-hook) + (gnus-summary-update-info) + (gnus-list-of-read-articles gnus-newsgroup-name)) + (setq gnus-newsgroup-expirable + (sort gnus-newsgroup-expirable '<)))) + (expiry-wait (if now 'immediate + (gnus-group-find-parameter + gnus-newsgroup-name 'expiry-wait))) + es) + (when expirable + ;; There are expirable articles in this group, so we run them + ;; through the expiry process. + (gnus-message 6 "Expiring articles...") + ;; The list of articles that weren't expired is returned. + (if expiry-wait + (let ((nnmail-expiry-wait-function nil) + (nnmail-expiry-wait expiry-wait)) + (setq es (gnus-request-expire-articles + expirable gnus-newsgroup-name))) + (setq es (gnus-request-expire-articles + expirable gnus-newsgroup-name))) + (unless total + (setq gnus-newsgroup-expirable es)) + ;; We go through the old list of expirable, and mark all + ;; really expired articles as nonexistent. + (unless (eq es expirable) ;If nothing was expired, we don't mark. + (let ((gnus-use-cache nil)) + (while expirable + (unless (memq (car expirable) es) + (when (gnus-data-find (car expirable)) + (gnus-summary-mark-article + (car expirable) gnus-canceled-mark))) + (setq expirable (cdr expirable))))) + (gnus-message 6 "Expiring articles...done"))))) + +(defun gnus-summary-expire-articles-now () + "Expunge all expirable articles in the current group. +This means that *all* articles that are marked as expirable will be +deleted forever, right now." + (interactive) + (gnus-set-global-variables) + (or gnus-expert-user + (gnus-yes-or-no-p + "Are you really, really, really sure you want to delete all these messages? ") + (error "Phew!")) + (gnus-summary-expire-articles t)) + +;; Suggested by Jack Vinson . +(defun gnus-summary-delete-article (&optional n) + "Delete the N next (mail) articles. +This command actually deletes articles. This is not a marking +command. The article will disappear forever from your life, never to +return. +If N is negative, delete backwards. +If N is nil and articles have been marked with the process mark, +delete these instead." + (interactive "P") + (gnus-set-global-variables) + (unless (gnus-check-backend-function 'request-expire-articles + gnus-newsgroup-name) + (error "The current newsgroup does not support article deletion")) + ;; Compute the list of articles to delete. + (let ((articles (gnus-summary-work-articles n)) + not-deleted) + (if (and gnus-novice-user + (not (gnus-yes-or-no-p + (format "Do you really want to delete %s forever? " + (if (> (length articles) 1) + (format "these %s articles" (length articles)) + "this article"))))) + () + ;; Delete the articles. + (setq not-deleted (gnus-request-expire-articles + articles gnus-newsgroup-name 'force)) + (while articles + (gnus-summary-remove-process-mark (car articles)) + ;; The backend might not have been able to delete the article + ;; after all. + (unless (memq (car articles) not-deleted) + (gnus-summary-mark-article (car articles) gnus-canceled-mark)) + (setq articles (cdr articles))) + (when not-deleted + (gnus-message 4 "Couldn't delete articles %s" not-deleted))) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + not-deleted)) + +(defun gnus-summary-edit-article (&optional force) + "Edit the current article. +This will have permanent effect only in mail groups. +If FORCE is non-nil, allow editing of articles even in read-only +groups." + (interactive "P") + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables) + (when (and (not force) + (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing")) + ;; Select article if needed. + (unless (eq (gnus-summary-article-number) + gnus-current-article) + (gnus-summary-select-article t)) + (gnus-article-date-original) + (gnus-article-edit-article + `(lambda (no-highlight) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))) + +(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) + +(defun gnus-summary-edit-article-done (&optional references read-only buffer + no-highlight) + "Make edits to the current article permanent." + (interactive) + ;; Replace the article. + (if (and (not read-only) + (not (gnus-request-replace-article + (cdr gnus-article-current) (car gnus-article-current) + (current-buffer)))) + (error "Couldn't replace article") + ;; Update the summary buffer. + (if (and references + (equal (message-tokenize-header references " ") + (message-tokenize-header + (or (message-fetch-field "references") "") " "))) + ;; We only have to update this line. + (save-excursion + (save-restriction + (message-narrow-to-head) + (let ((head (buffer-string)) + header) + (nnheader-temp-write nil + (insert (format "211 %d Article retrieved.\n" + (cdr gnus-article-current))) + (insert head) + (insert ".\n") + (let ((nntp-server-buffer (current-buffer))) + (setq header (car (gnus-get-newsgroup-headers + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-newsgroup-dependencies) + t)))) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-data-set-header + (gnus-data-find (cdr gnus-article-current)) + header) + (gnus-summary-update-article-line + (cdr gnus-article-current) header)))))) + ;; Update threads. + (set-buffer (or buffer gnus-summary-buffer)) + (gnus-summary-update-article (cdr gnus-article-current))) + ;; Prettify the article buffer again. + (unless no-highlight + (save-excursion + (set-buffer gnus-article-buffer) + (run-hooks 'gnus-article-display-hook) + (set-buffer gnus-original-article-buffer) + (gnus-request-article + (cdr gnus-article-current) + (car gnus-article-current) (current-buffer)))) + ;; Prettify the summary buffer line. + (when (gnus-visual-p 'summary-highlight 'highlight) + (run-hooks 'gnus-visual-mark-article-hook)))) + +(defun gnus-summary-edit-wash (key) + "Perform editing command in the article buffer." + (interactive + (list + (progn + (message "%s" (concat (this-command-keys) "- ")) + (read-char)))) + (message "") + (gnus-summary-edit-article) + (execute-kbd-macro (concat (this-command-keys) key)) + (gnus-article-edit-done)) + +;;; Respooling + +(defun gnus-summary-respool-query (&optional silent) + "Query where the respool algorithm would put this article." + (interactive) + (gnus-set-global-variables) + (let (gnus-mark-article-hook) + (gnus-summary-select-article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (save-restriction + (message-narrow-to-head) + (let ((groups (nnmail-article-group 'identity))) + (unless silent + (if groups + (message "This message would go to %s" + (mapconcat 'car groups ", ")) + (message "This message would go to no groups")) + groups)))))) + +;; Summary marking commands. + +(defun gnus-summary-kill-same-subject-and-select (&optional unmark) + "Mark articles which has the same subject as read, and then select the next. +If UNMARK is positive, remove any kind of mark. +If UNMARK is negative, tick articles." + (interactive "P") + (gnus-set-global-variables) + (when unmark + (setq unmark (prefix-numeric-value unmark))) + (let ((count + (gnus-summary-mark-same-subject + (gnus-summary-article-subject) unmark))) + ;; Select next unread article. If auto-select-same mode, should + ;; select the first unread article. + (gnus-summary-next-article t (and gnus-auto-select-same + (gnus-summary-article-subject))) + (gnus-message 7 "%d article%s marked as %s" + count (if (= count 1) " is" "s are") + (if unmark "unread" "read")))) + +(defun gnus-summary-kill-same-subject (&optional unmark) + "Mark articles which has the same subject as read. +If UNMARK is positive, remove any kind of mark. +If UNMARK is negative, tick articles." + (interactive "P") + (gnus-set-global-variables) + (when unmark + (setq unmark (prefix-numeric-value unmark))) + (let ((count + (gnus-summary-mark-same-subject + (gnus-summary-article-subject) unmark))) + ;; If marked as read, go to next unread subject. + (when (null unmark) + ;; Go to next unread subject. + (gnus-summary-next-subject 1 t)) + (gnus-message 7 "%d articles are marked as %s" + count (if unmark "unread" "read")))) + +(defun gnus-summary-mark-same-subject (subject &optional unmark) + "Mark articles with same SUBJECT as read, and return marked number. +If optional argument UNMARK is positive, remove any kinds of marks. +If optional argument UNMARK is negative, mark articles as unread instead." + (let ((count 1)) + (save-excursion + (cond + ((null unmark) ; Mark as read. + (while (and + (progn + (gnus-summary-mark-article-as-read gnus-killed-mark) + (gnus-summary-show-thread) t) + (gnus-summary-find-subject subject)) + (setq count (1+ count)))) + ((> unmark 0) ; Tick. + (while (and + (progn + (gnus-summary-mark-article-as-unread gnus-ticked-mark) + (gnus-summary-show-thread) t) + (gnus-summary-find-subject subject)) + (setq count (1+ count)))) + (t ; Mark as unread. + (while (and + (progn + (gnus-summary-mark-article-as-unread gnus-unread-mark) + (gnus-summary-show-thread) t) + (gnus-summary-find-subject subject)) + (setq count (1+ count))))) + (gnus-set-mode-line 'summary) + ;; Return the number of marked articles. + count))) + +(defun gnus-summary-mark-as-processable (n &optional unmark) + "Set the process mark on the next N articles. +If N is negative, mark backward instead. If UNMARK is non-nil, remove +the process mark instead. The difference between N and the actual +number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (n (abs n))) + (while (and + (> n 0) + (if unmark + (gnus-summary-remove-process-mark + (gnus-summary-article-number)) + (gnus-summary-set-process-mark (gnus-summary-article-number))) + (zerop (gnus-summary-next-subject (if backward -1 1) nil t))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more articles")) + (gnus-summary-recenter) + (gnus-summary-position-point) + n)) + +(defun gnus-summary-unmark-as-processable (n) + "Remove the process mark from the next N articles. +If N is negative, unmark backward instead. The difference between N and +the actual number of articles unmarked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-mark-as-processable n t)) + +(defun gnus-summary-unmark-all-processable () + "Remove the process mark from all articles." + (interactive) + (gnus-set-global-variables) + (save-excursion + (while gnus-newsgroup-processable + (gnus-summary-remove-process-mark (car gnus-newsgroup-processable)))) + (gnus-summary-position-point)) + +(defun gnus-summary-mark-as-expirable (n) + "Mark N articles forward as expirable. +If N is negative, mark backward instead. The difference between N and +the actual number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-mark-forward n gnus-expirable-mark)) + +(defun gnus-summary-mark-article-as-replied (article) + "Mark ARTICLE replied and update the summary line." + (push article gnus-newsgroup-replied) + (let ((buffer-read-only nil)) + (when (gnus-summary-goto-subject article) + (gnus-summary-update-secondary-mark article)))) + +(defun gnus-summary-set-bookmark (article) + "Set a bookmark in current article." + (interactive (gnus-summary-article-number)) + (gnus-set-global-variables) + (when (or (not (get-buffer gnus-article-buffer)) + (not gnus-current-article) + (not gnus-article-current) + (not (equal gnus-newsgroup-name (car gnus-article-current)))) + (error "No current article selected")) + ;; Remove old bookmark, if one exists. + (let ((old (assq article gnus-newsgroup-bookmarks))) + (when old + (setq gnus-newsgroup-bookmarks + (delq old gnus-newsgroup-bookmarks)))) + ;; Set the new bookmark, which is on the form + ;; (article-number . line-number-in-body). + (push + (cons article + (save-excursion + (set-buffer gnus-article-buffer) + (count-lines + (min (point) + (save-excursion + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (point))) + (point)))) + gnus-newsgroup-bookmarks) + (gnus-message 6 "A bookmark has been added to the current article.")) + +(defun gnus-summary-remove-bookmark (article) + "Remove the bookmark from the current article." + (interactive (gnus-summary-article-number)) + (gnus-set-global-variables) + ;; Remove old bookmark, if one exists. + (let ((old (assq article gnus-newsgroup-bookmarks))) + (if old + (progn + (setq gnus-newsgroup-bookmarks + (delq old gnus-newsgroup-bookmarks)) + (gnus-message 6 "Removed bookmark.")) + (gnus-message 6 "No bookmark in current article.")))) + +;; Suggested by Daniel Quinlan . +(defun gnus-summary-mark-as-dormant (n) + "Mark N articles forward as dormant. +If N is negative, mark backward instead. The difference between N and +the actual number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-mark-forward n gnus-dormant-mark)) + +(defun gnus-summary-set-process-mark (article) + "Set the process mark on ARTICLE and update the summary line." + (setq gnus-newsgroup-processable + (cons article + (delq article gnus-newsgroup-processable))) + (when (gnus-summary-goto-subject article) + (gnus-summary-show-thread) + (gnus-summary-update-secondary-mark article))) + +(defun gnus-summary-remove-process-mark (article) + "Remove the process mark from ARTICLE and update the summary line." + (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) + (when (gnus-summary-goto-subject article) + (gnus-summary-show-thread) + (gnus-summary-update-secondary-mark article))) + +(defun gnus-summary-set-saved-mark (article) + "Set the process mark on ARTICLE and update the summary line." + (push article gnus-newsgroup-saved) + (when (gnus-summary-goto-subject article) + (gnus-summary-update-secondary-mark article))) + +(defun gnus-summary-mark-forward (n &optional mark no-expire) + "Mark N articles as read forwards. +If N is negative, mark backwards instead. Mark with MARK, ?r by default. +The difference between N and the actual number of articles marked is +returned." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (gnus-summary-goto-unread + (and gnus-summary-goto-unread + (not (eq gnus-summary-goto-unread 'never)) + (not (memq mark (list gnus-unread-mark + gnus-ticked-mark gnus-dormant-mark))))) + (n (abs n)) + (mark (or mark gnus-del-mark))) + (while (and (> n 0) + (gnus-summary-mark-article nil mark no-expire) + (zerop (gnus-summary-next-subject + (if backward -1 1) + (and gnus-summary-goto-unread + (not (eq gnus-summary-goto-unread 'never))) + t))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more %sarticles" (if mark "" "unread "))) + (gnus-summary-recenter) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + n)) + +(defun gnus-summary-mark-article-as-read (mark) + "Mark the current article quickly as read with MARK." + (let ((article (gnus-summary-article-number))) + (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (push (cons article mark) gnus-newsgroup-reads) + ;; Possibly remove from cache, if that is used. + (when gnus-use-cache + (gnus-cache-enter-remove-article article)) + ;; Allow the backend to change the mark. + (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) + ;; Check for auto-expiry. + (when (and gnus-newsgroup-auto-expire + (or (= mark gnus-killed-mark) (= mark gnus-del-mark) + (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) + (= mark gnus-ancient-mark) + (= mark gnus-read-mark) (= mark gnus-souped-mark) + (= mark gnus-duplicate-mark))) + (setq mark gnus-expirable-mark) + (push article gnus-newsgroup-expirable)) + ;; Set the mark in the buffer. + (gnus-summary-update-mark mark 'unread) + t)) + +(defun gnus-summary-mark-article-as-unread (mark) + "Mark the current article quickly as unread with MARK." + (let ((article (gnus-summary-article-number))) + (if (< article 0) + (gnus-error 1 "Unmarkable article") + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) + (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) + (cond ((= mark gnus-ticked-mark) + (push article gnus-newsgroup-marked)) + ((= mark gnus-dormant-mark) + (push article gnus-newsgroup-dormant)) + (t + (push article gnus-newsgroup-unreads))) + (setq gnus-newsgroup-reads + (delq (assq article gnus-newsgroup-reads) + gnus-newsgroup-reads)) + + ;; See whether the article is to be put in the cache. + (and gnus-use-cache + (vectorp (gnus-summary-article-header article)) + (save-excursion + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) + + ;; Fix the mark. + (gnus-summary-update-mark mark 'unread)) + t)) + +(defun gnus-summary-mark-article (&optional article mark no-expire) + "Mark ARTICLE with MARK. MARK can be any character. +Four MARK strings are reserved: `? ' (unread), `?!' (ticked), +`??' (dormant) and `?E' (expirable). +If MARK is nil, then the default character `?D' is used. +If ARTICLE is nil, then the article on the current line will be +marked." + ;; The mark might be a string. + (when (stringp mark) + (setq mark (aref mark 0))) + ;; If no mark is given, then we check auto-expiring. + (and (not no-expire) + gnus-newsgroup-auto-expire + (or (not mark) + (and (gnus-characterp mark) + (or (= mark gnus-killed-mark) (= mark gnus-del-mark) + (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) + (= mark gnus-read-mark) (= mark gnus-souped-mark) + (= mark gnus-duplicate-mark)))) + (setq mark gnus-expirable-mark)) + (let* ((mark (or mark gnus-del-mark)) + (article (or article (gnus-summary-article-number)))) + (unless article + (error "No article on current line")) + (if (or (= mark gnus-unread-mark) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark)) + (gnus-mark-article-as-unread article mark) + (gnus-mark-article-as-read article mark)) + + ;; See whether the article is to be put in the cache. + (and gnus-use-cache + (not (= mark gnus-canceled-mark)) + (vectorp (gnus-summary-article-header article)) + (save-excursion + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) + + (when (gnus-summary-goto-subject article nil t) + (let ((buffer-read-only nil)) + (gnus-summary-show-thread) + ;; Fix the mark. + (gnus-summary-update-mark mark 'unread) + t)))) + +(defun gnus-summary-update-secondary-mark (article) + "Update the secondary (read, process, cache) mark." + (gnus-summary-update-mark + (cond ((memq article gnus-newsgroup-processable) + gnus-process-mark) + ((memq article gnus-newsgroup-cached) + gnus-cached-mark) + ((memq article gnus-newsgroup-replied) + gnus-replied-mark) + ((memq article gnus-newsgroup-saved) + gnus-saved-mark) + (t gnus-unread-mark)) + 'replied) + (when (gnus-visual-p 'summary-highlight 'highlight) + (run-hooks 'gnus-summary-update-hook)) + t) + +(defun gnus-summary-update-mark (mark type) + (let ((forward (cdr (assq type gnus-summary-mark-positions))) + (buffer-read-only nil)) + (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) + (when (looking-at "\r") + (incf forward)) + (when (and forward + (<= (+ forward (point)) (point-max))) + ;; Go to the right position on the line. + (goto-char (+ forward (point))) + ;; Replace the old mark with the new mark. + (subst-char-in-region (point) (1+ (point)) (following-char) mark) + ;; Optionally update the marks by some user rule. + (when (eq type 'unread) + (gnus-data-set-mark + (gnus-data-find (gnus-summary-article-number)) mark) + (gnus-summary-update-line (eq mark gnus-unread-mark)))))) + +(defun gnus-mark-article-as-read (article &optional mark) + "Enter ARTICLE in the pertinent lists and remove it from others." + ;; Make the article expirable. + (let ((mark (or mark gnus-del-mark))) + (if (= mark gnus-expirable-mark) + (push article gnus-newsgroup-expirable) + (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))) + ;; Remove from unread and marked lists. + (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (push (cons article mark) gnus-newsgroup-reads) + ;; Possibly remove from cache, if that is used. + (when gnus-use-cache + (gnus-cache-enter-remove-article article)))) + +(defun gnus-mark-article-as-unread (article &optional mark) + "Enter ARTICLE in the pertinent lists and remove it from others." + (let ((mark (or mark gnus-ticked-mark))) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) + gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant) + gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable) + gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + + ;; Unsuppress duplicates? + (when gnus-suppress-duplicates + (gnus-dup-unsuppress-article article)) + + (cond ((= mark gnus-ticked-mark) + (push article gnus-newsgroup-marked)) + ((= mark gnus-dormant-mark) + (push article gnus-newsgroup-dormant)) + (t + (push article gnus-newsgroup-unreads))) + (setq gnus-newsgroup-reads + (delq (assq article gnus-newsgroup-reads) + gnus-newsgroup-reads)))) + +(defalias 'gnus-summary-mark-as-unread-forward + 'gnus-summary-tick-article-forward) +(make-obsolete 'gnus-summary-mark-as-unread-forward + 'gnus-summary-tick-article-forward) +(defun gnus-summary-tick-article-forward (n) + "Tick N articles forwards. +If N is negative, tick backwards instead. +The difference between N and the number of articles ticked is returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-ticked-mark)) + +(defalias 'gnus-summary-mark-as-unread-backward + 'gnus-summary-tick-article-backward) +(make-obsolete 'gnus-summary-mark-as-unread-backward + 'gnus-summary-tick-article-backward) +(defun gnus-summary-tick-article-backward (n) + "Tick N articles backwards. +The difference between N and the number of articles ticked is returned." + (interactive "p") + (gnus-summary-mark-forward (- n) gnus-ticked-mark)) + +(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) +(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) +(defun gnus-summary-tick-article (&optional article clear-mark) + "Mark current article as unread. +Optional 1st argument ARTICLE specifies article number to be marked as unread. +Optional 2nd argument CLEAR-MARK remove any kinds of mark." + (interactive) + (gnus-summary-mark-article article (if clear-mark gnus-unread-mark + gnus-ticked-mark))) + +(defun gnus-summary-mark-as-read-forward (n) + "Mark N articles as read forwards. +If N is negative, mark backwards instead. +The difference between N and the actual number of articles marked is +returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-del-mark t)) + +(defun gnus-summary-mark-as-read-backward (n) + "Mark the N articles as read backwards. +The difference between N and the actual number of articles marked is +returned." + (interactive "p") + (gnus-summary-mark-forward (- n) gnus-del-mark t)) + +(defun gnus-summary-mark-as-read (&optional article mark) + "Mark current article as read. +ARTICLE specifies the article to be marked as read. +MARK specifies a string to be inserted at the beginning of the line." + (gnus-summary-mark-article article mark)) + +(defun gnus-summary-clear-mark-forward (n) + "Clear marks from N articles forward. +If N is negative, clear backward instead. +The difference between N and the number of marks cleared is returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-unread-mark)) + +(defun gnus-summary-clear-mark-backward (n) + "Clear marks from N articles backward. +The difference between N and the number of marks cleared is returned." + (interactive "p") + (gnus-summary-mark-forward (- n) gnus-unread-mark)) + +(defun gnus-summary-mark-unread-as-read () + "Intended to be used by `gnus-summary-mark-article-hook'." + (when (memq gnus-current-article gnus-newsgroup-unreads) + (gnus-summary-mark-article gnus-current-article gnus-read-mark))) + +(defun gnus-summary-mark-read-and-unread-as-read () + "Intended to be used by `gnus-summary-mark-article-hook'." + (let ((mark (gnus-summary-article-mark))) + (when (or (gnus-unread-mark-p mark) + (gnus-read-mark-p mark)) + (gnus-summary-mark-article gnus-current-article gnus-read-mark)))) + +(defun gnus-summary-mark-region-as-read (point mark all) + "Mark all unread articles between point and mark as read. +If given a prefix, mark all articles between point and mark as read, +even ticked and dormant ones." + (interactive "r\nP") + (save-excursion + (let (article) + (goto-char point) + (beginning-of-line) + (while (and + (< (point) mark) + (progn + (when (or all + (memq (setq article (gnus-summary-article-number)) + gnus-newsgroup-unreads)) + (gnus-summary-mark-article article gnus-del-mark)) + t) + (gnus-summary-find-next)))))) + +(defun gnus-summary-mark-below (score mark) + "Mark articles with score less than SCORE with MARK." + (interactive "P\ncMark: ") + (gnus-set-global-variables) + (setq score (if score + (prefix-numeric-value score) + (or gnus-summary-default-score 0))) + (save-excursion + (set-buffer gnus-summary-buffer) + (goto-char (point-min)) + (while + (progn + (and (< (gnus-summary-article-score) score) + (gnus-summary-mark-article nil mark)) + (gnus-summary-find-next))))) + +(defun gnus-summary-kill-below (&optional score) + "Mark articles with score below SCORE as read." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-mark-below score gnus-killed-mark)) + +(defun gnus-summary-clear-above (&optional score) + "Clear all marks from articles with score above SCORE." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-mark-above score gnus-unread-mark)) + +(defun gnus-summary-tick-above (&optional score) + "Tick all articles with score above SCORE." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-mark-above score gnus-ticked-mark)) + +(defun gnus-summary-mark-above (score mark) + "Mark articles with score over SCORE with MARK." + (interactive "P\ncMark: ") + (gnus-set-global-variables) + (setq score (if score + (prefix-numeric-value score) + (or gnus-summary-default-score 0))) + (save-excursion + (set-buffer gnus-summary-buffer) + (goto-char (point-min)) + (while (and (progn + (when (> (gnus-summary-article-score) score) + (gnus-summary-mark-article nil mark)) + t) + (gnus-summary-find-next))))) + +;; Suggested by Daniel Quinlan . +(defalias 'gnus-summary-show-all-expunged 'gnus-summary-limit-include-expunged) +(defun gnus-summary-limit-include-expunged (&optional no-error) + "Display all the hidden articles that were expunged for low scores." + (interactive) + (gnus-set-global-variables) + (let ((buffer-read-only nil)) + (let ((scored gnus-newsgroup-scored) + headers h) + (while scored + (unless (gnus-summary-goto-subject (caar scored)) + (and (setq h (gnus-summary-article-header (caar scored))) + (< (cdar scored) gnus-summary-expunge-below) + (push h headers))) + (setq scored (cdr scored))) + (if (not headers) + (when (not no-error) + (error "No expunged articles hidden")) + (goto-char (point-min)) + (gnus-summary-prepare-unthreaded (nreverse headers)) + (goto-char (point-min)) + (gnus-summary-position-point) + t)))) + +(defun gnus-summary-catchup (&optional all quietly to-here not-mark) + "Mark all unread articles in this newsgroup as read. +If prefix argument ALL is non-nil, ticked and dormant articles will +also be marked as read. +If QUIETLY is non-nil, no questions will be asked. +If TO-HERE is non-nil, it should be a point in the buffer. All +articles before this point will be marked as read. +Note that this function will only catch up the unread article +in the current summary buffer limitation. +The number of articles marked as read is returned." + (interactive "P") + (gnus-set-global-variables) + (prog1 + (save-excursion + (when (or quietly + (not gnus-interactive-catchup) ;Without confirmation? + gnus-expert-user + (gnus-y-or-n-p + (if all + "Mark absolutely all articles as read? " + "Mark all unread articles as read? "))) + (if (and not-mark + (not gnus-newsgroup-adaptive) + (not gnus-newsgroup-auto-expire) + (not gnus-suppress-duplicates) + (or (not gnus-use-cache) + (eq gnus-use-cache 'passive))) + (progn + (when all + (setq gnus-newsgroup-marked nil + gnus-newsgroup-dormant nil)) + (setq gnus-newsgroup-unreads nil)) + ;; We actually mark all articles as canceled, which we + ;; have to do when using auto-expiry or adaptive scoring. + (gnus-summary-show-all-threads) + (when (gnus-summary-first-subject (not all)) + (while (and + (if to-here (< (point) to-here) t) + (gnus-summary-mark-article-as-read gnus-catchup-mark) + (gnus-summary-find-next (not all))))) + (gnus-set-mode-line 'summary)) + t)) + (gnus-summary-position-point))) + +(defun gnus-summary-catchup-to-here (&optional all) + "Mark all unticked articles before the current one as read. +If ALL is non-nil, also mark ticked and dormant articles as read." + (interactive "P") + (gnus-set-global-variables) + (save-excursion + (gnus-save-hidden-threads + (let ((beg (point))) + ;; We check that there are unread articles. + (when (or all (gnus-summary-find-prev)) + (gnus-summary-catchup all t beg))))) + (gnus-summary-position-point)) + +(defun gnus-summary-catchup-all (&optional quietly) + "Mark all articles in this newsgroup as read." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-catchup t quietly)) + +(defun gnus-summary-catchup-and-exit (&optional all quietly) + "Mark all articles not marked as unread in this newsgroup as read, then exit. +If prefix argument ALL is non-nil, all articles are marked as read." + (interactive "P") + (gnus-set-global-variables) + (when (gnus-summary-catchup all quietly nil 'fast) + ;; Select next newsgroup or exit. + (if (eq gnus-auto-select-next 'quietly) + (gnus-summary-next-group nil) + (gnus-summary-exit)))) + +(defun gnus-summary-catchup-all-and-exit (&optional quietly) + "Mark all articles in this newsgroup as read, and then exit." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-catchup-and-exit t quietly)) + +;; Suggested by "Arne Eofsson" . +(defun gnus-summary-catchup-and-goto-next-group (&optional all) + "Mark all articles in this group as read and select the next group. +If given a prefix, mark all articles, unread as well as ticked, as +read." + (interactive "P") + (gnus-set-global-variables) + (save-excursion + (gnus-summary-catchup all)) + (gnus-summary-next-article t nil nil t)) + +;; Thread-based commands. + +(defun gnus-summary-articles-in-thread (&optional article) + "Return a list of all articles in the current thread. +If ARTICLE is non-nil, return all articles in the thread that starts +with that article." + (let* ((article (or article (gnus-summary-article-number))) + (data (gnus-data-find-list article)) + (top-level (gnus-data-level (car data))) + (top-subject + (cond ((null gnus-thread-operation-ignore-subject) + (gnus-simplify-subject-re + (mail-header-subject (gnus-data-header (car data))))) + ((eq gnus-thread-operation-ignore-subject 'fuzzy) + (gnus-simplify-subject-fuzzy + (mail-header-subject (gnus-data-header (car data))))) + (t nil))) + (end-point (save-excursion + (if (gnus-summary-go-to-next-thread) + (point) (point-max)))) + articles) + (while (and data + (< (gnus-data-pos (car data)) end-point)) + (when (or (not top-subject) + (string= top-subject + (if (eq gnus-thread-operation-ignore-subject 'fuzzy) + (gnus-simplify-subject-fuzzy + (mail-header-subject + (gnus-data-header (car data)))) + (gnus-simplify-subject-re + (mail-header-subject + (gnus-data-header (car data))))))) + (push (gnus-data-number (car data)) articles)) + (unless (and (setq data (cdr data)) + (> (gnus-data-level (car data)) top-level)) + (setq data nil))) + ;; Return the list of articles. + (nreverse articles))) + +(defun gnus-summary-rethread-current () + "Rethread the thread the current article is part of." + (interactive) + (gnus-set-global-variables) + (let* ((gnus-show-threads t) + (article (gnus-summary-article-number)) + (id (mail-header-id (gnus-summary-article-header))) + (gnus-newsgroup-threads (list (gnus-id-to-thread (gnus-root-id id))))) + (unless id + (error "No article on the current line")) + (gnus-rebuild-thread id) + (gnus-summary-goto-subject article))) + +(defun gnus-summary-reparent-thread () + "Make the current article child of the marked (or previous) article. + +Note that the re-threading will only work if `gnus-thread-ignore-subject' +is non-nil or the Subject: of both articles are the same." + (interactive) + (unless (not (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing")) + (unless (<= (length gnus-newsgroup-processable) 1) + (error "No more than one article may be marked")) + (save-window-excursion + (let ((gnus-article-buffer " *reparent*") + (current-article (gnus-summary-article-number)) + ;; First grab the marked article, otherwise one line up. + (parent-article (if (not (null gnus-newsgroup-processable)) + (car gnus-newsgroup-processable) + (save-excursion + (if (eq (forward-line -1) 0) + (gnus-summary-article-number) + (error "Beginning of summary buffer")))))) + (unless (not (eq current-article parent-article)) + (error "An article may not be self-referential")) + (let ((message-id (mail-header-id + (gnus-summary-article-header parent-article)))) + (unless (and message-id (not (equal message-id ""))) + (error "No message-id in desired parent")) + (gnus-summary-select-article t t nil current-article) + (set-buffer gnus-original-article-buffer) + (let ((buf (format "%s" (buffer-string)))) + (nnheader-temp-write nil + (insert buf) + (goto-char (point-min)) + (if (search-forward-regexp "^References: " nil t) + (insert message-id " " ) + (insert "References: " message-id "\n")) + (unless (gnus-request-replace-article + current-article (car gnus-article-current) + (current-buffer)) + (error "Couldn't replace article")))) + (set-buffer gnus-summary-buffer) + (gnus-summary-unmark-all-processable) + (gnus-summary-rethread-current) + (gnus-message 3 "Article %d is now the child of article %d" + current-article parent-article))))) + +(defun gnus-summary-toggle-threads (&optional arg) + "Toggle showing conversation threads. +If ARG is positive number, turn showing conversation threads on." + (interactive "P") + (gnus-set-global-variables) + (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end))) + (setq gnus-show-threads + (if (null arg) (not gnus-show-threads) + (> (prefix-numeric-value arg) 0))) + (gnus-summary-prepare) + (gnus-summary-goto-subject current) + (gnus-message 6 "Threading is now %s" (if gnus-show-threads "on" "off")) + (gnus-summary-position-point))) + +(defun gnus-summary-show-all-threads () + "Show all threads." + (interactive) + (gnus-set-global-variables) + (save-excursion + (let ((buffer-read-only nil)) + (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))) + (gnus-summary-position-point)) + +(defun gnus-summary-show-thread () + "Show thread subtrees. +Returns nil if no thread was there to be shown." + (interactive) + (gnus-set-global-variables) + (let ((buffer-read-only nil) + (orig (point)) + ;; first goto end then to beg, to have point at beg after let + (end (progn (end-of-line) (point))) + (beg (progn (beginning-of-line) (point)))) + (prog1 + ;; Any hidden lines here? + (search-forward "\r" end t) + (subst-char-in-region beg end ?\^M ?\n t) + (goto-char orig) + (gnus-summary-position-point)))) + +(defun gnus-summary-hide-all-threads () + "Hide all thread subtrees." + (interactive) + (gnus-set-global-variables) + (save-excursion + (goto-char (point-min)) + (gnus-summary-hide-thread) + (while (zerop (gnus-summary-next-thread 1 t)) + (gnus-summary-hide-thread))) + (gnus-summary-position-point)) + +(defun gnus-summary-hide-thread () + "Hide thread subtrees. +Returns nil if no threads were there to be hidden." + (interactive) + (gnus-set-global-variables) + (let ((buffer-read-only nil) + (start (point)) + (article (gnus-summary-article-number))) + (goto-char start) + ;; Go forward until either the buffer ends or the subthread + ;; ends. + (when (and (not (eobp)) + (or (zerop (gnus-summary-next-thread 1 t)) + (goto-char (point-max)))) + (prog1 + (if (and (> (point) start) + (search-backward "\n" start t)) + (progn + (subst-char-in-region start (point) ?\n ?\^M) + (gnus-summary-goto-subject article)) + (goto-char start) + nil) + ;;(gnus-summary-position-point) + )))) + +(defun gnus-summary-go-to-next-thread (&optional previous) + "Go to the same level (or less) next thread. +If PREVIOUS is non-nil, go to previous thread instead. +Return the article number moved to, or nil if moving was impossible." + (let ((level (gnus-summary-thread-level)) + (way (if previous -1 1)) + (beg (point))) + (forward-line way) + (while (and (not (eobp)) + (< level (gnus-summary-thread-level))) + (forward-line way)) + (if (eobp) + (progn + (goto-char beg) + nil) + (setq beg (point)) + (prog1 + (gnus-summary-article-number) + (goto-char beg))))) + +(defun gnus-summary-next-thread (n &optional silent) + "Go to the same level next N'th thread. +If N is negative, search backward instead. +Returns the difference between N and the number of skips actually +done. + +If SILENT, don't output messages." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (n (abs n))) + (while (and (> n 0) + (gnus-summary-go-to-next-thread backward)) + (decf n)) + (unless silent + (gnus-summary-position-point)) + (when (and (not silent) (/= 0 n)) + (gnus-message 7 "No more threads")) + n)) + +(defun gnus-summary-prev-thread (n) + "Go to the same level previous N'th thread. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-next-thread (- n))) + +(defun gnus-summary-go-down-thread () + "Go down one level in the current thread." + (let ((children (gnus-summary-article-children))) + (when children + (gnus-summary-goto-subject (car children))))) + +(defun gnus-summary-go-up-thread () + "Go up one level in the current thread." + (let ((parent (gnus-summary-article-parent))) + (when parent + (gnus-summary-goto-subject parent)))) + +(defun gnus-summary-down-thread (n) + "Go down thread N steps. +If N is negative, go up instead. +Returns the difference between N and how many steps down that were +taken." + (interactive "p") + (gnus-set-global-variables) + (let ((up (< n 0)) + (n (abs n))) + (while (and (> n 0) + (if up (gnus-summary-go-up-thread) + (gnus-summary-go-down-thread))) + (setq n (1- n))) + (gnus-summary-position-point) + (when (/= 0 n) + (gnus-message 7 "Can't go further")) + n)) + +(defun gnus-summary-up-thread (n) + "Go up thread N steps. +If N is negative, go up instead. +Returns the difference between N and how many steps down that were +taken." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-down-thread (- n))) + +(defun gnus-summary-top-thread () + "Go to the top of the thread." + (interactive) + (gnus-set-global-variables) + (while (gnus-summary-go-up-thread)) + (gnus-summary-article-number)) + +(defun gnus-summary-kill-thread (&optional unmark) + "Mark articles under current thread as read. +If the prefix argument is positive, remove any kinds of marks. +If the prefix argument is negative, tick articles instead." + (interactive "P") + (gnus-set-global-variables) + (when unmark + (setq unmark (prefix-numeric-value unmark))) + (let ((articles (gnus-summary-articles-in-thread))) + (save-excursion + ;; Expand the thread. + (gnus-summary-show-thread) + ;; Mark all the articles. + (while articles + (gnus-summary-goto-subject (car articles)) + (cond ((null unmark) + (gnus-summary-mark-article-as-read gnus-killed-mark)) + ((> unmark 0) + (gnus-summary-mark-article-as-unread gnus-unread-mark)) + (t + (gnus-summary-mark-article-as-unread gnus-ticked-mark))) + (setq articles (cdr articles)))) + ;; Hide killed subtrees. + (and (null unmark) + gnus-thread-hide-killed + (gnus-summary-hide-thread)) + ;; If marked as read, go to next unread subject. + (when (null unmark) + ;; Go to next unread subject. + (gnus-summary-next-subject 1 t))) + (gnus-set-mode-line 'summary)) + +;; Summary sorting commands + +(defun gnus-summary-sort-by-number (&optional reverse) + "Sort the summary buffer by article number. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'number reverse)) + +(defun gnus-summary-sort-by-author (&optional reverse) + "Sort the summary buffer by author name alphabetically. +If case-fold-search is non-nil, case of letters is ignored. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'author reverse)) + +(defun gnus-summary-sort-by-subject (&optional reverse) + "Sort the summary buffer by subject alphabetically. `Re:'s are ignored. +If case-fold-search is non-nil, case of letters is ignored. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'subject reverse)) + +(defun gnus-summary-sort-by-date (&optional reverse) + "Sort the summary buffer by date. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'date reverse)) + +(defun gnus-summary-sort-by-score (&optional reverse) + "Sort the summary buffer by score. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'score reverse)) + +(defun gnus-summary-sort-by-lines (&optional reverse) + "Sort the summary buffer by article length. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'lines reverse)) + +(defun gnus-summary-sort (predicate reverse) + "Sort summary buffer by PREDICATE. REVERSE means reverse order." + (gnus-set-global-variables) + (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) + (article (intern (format "gnus-article-sort-by-%s" predicate))) + (gnus-thread-sort-functions + (list + (if (not reverse) + thread + `(lambda (t1 t2) + (,thread t2 t1))))) + (gnus-article-sort-functions + (list + (if (not reverse) + article + `(lambda (t1 t2) + (,article t2 t1))))) + (buffer-read-only) + (gnus-summary-prepare-hook nil)) + ;; We do the sorting by regenerating the threads. + (gnus-summary-prepare) + ;; Hide subthreads if needed. + (when (and gnus-show-threads gnus-thread-hide-subtree) + (gnus-summary-hide-all-threads)))) + +;; Summary saving commands. + +(defun gnus-summary-save-article (&optional n not-saved) + "Save the current article using the default saver function. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead. +The variable `gnus-default-article-saver' specifies the saver function." + (interactive "P") + (gnus-set-global-variables) + (let* ((articles (gnus-summary-work-articles n)) + (save-buffer (save-excursion + (nnheader-set-temp-buffer " *Gnus Save*"))) + (num (length articles)) + header article file) + (while articles + (setq header (gnus-summary-article-header + (setq article (pop articles)))) + (if (not (vectorp header)) + ;; This is a pseudo-article. + (if (assq 'name header) + (gnus-copy-file (cdr (assq 'name header))) + (gnus-message 1 "Article %d is unsaveable" article)) + ;; This is a real article. + (save-window-excursion + (gnus-summary-select-article t nil nil article)) + (save-excursion + (set-buffer save-buffer) + (erase-buffer) + (insert-buffer-substring gnus-original-article-buffer)) + (setq file (gnus-article-save save-buffer file num)) + (gnus-summary-remove-process-mark article) + (unless not-saved + (gnus-summary-set-saved-mark article)))) + (gnus-kill-buffer save-buffer) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + n)) + +(defun gnus-summary-pipe-output (&optional arg) + "Pipe the current article to a subprocess. +If N is a positive number, pipe the N next articles. +If N is a negative number, pipe the N previous articles. +If N is nil and any articles have been marked with the process mark, +pipe those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe)) + (gnus-summary-save-article arg t)) + (gnus-configure-windows 'pipe)) + +(defun gnus-summary-save-article-mail (&optional arg) + "Append the current article to an mail file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-mail)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-article-rmail (&optional arg) + "Append the current article to an rmail file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-article-file (&optional arg) + "Append the current article to a file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-file)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-write-article-file (&optional arg) + "Write the current article to a file, deleting the previous file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-write-to-file)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-article-body-file (&optional arg) + "Append the current article body to a file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-pipe-message (program) + "Pipe the current article through PROGRAM." + (interactive "sProgram: ") + (gnus-set-global-variables) + (gnus-summary-select-article) + (let ((mail-header-separator "") + (art-buf (get-buffer gnus-article-buffer))) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (let ((start (window-start)) + buffer-read-only) + (message-pipe-buffer-body program) + (set-window-start (get-buffer-window (current-buffer)) start)))))) + +(defun gnus-get-split-value (methods) + "Return a value based on the split METHODS." + (let (split-name method result match) + (when methods + (save-excursion + (set-buffer gnus-original-article-buffer) + (save-restriction + (nnheader-narrow-to-headers) + (while methods + (goto-char (point-min)) + (setq method (pop methods)) + (setq match (car method)) + (when (cond + ((stringp match) + ;; Regular expression. + (ignore-errors + (re-search-forward match nil t))) + ((gnus-functionp match) + ;; Function. + (save-restriction + (widen) + (setq result (funcall match gnus-newsgroup-name)))) + ((consp match) + ;; Form. + (save-restriction + (widen) + (setq result (eval match))))) + (setq split-name (append (cdr method) split-name)) + (cond ((stringp result) + (push (expand-file-name + result gnus-article-save-directory) + split-name)) + ((consp result) + (setq split-name (append result split-name))))))))) + split-name)) + +(defun gnus-valid-move-group-p (group) + (and (boundp group) + (symbol-name group) + (memq 'respool + (assoc (symbol-name + (car (gnus-find-method-for-group + (symbol-name group)))) + gnus-valid-select-methods)))) + +(defun gnus-read-move-group-name (prompt default articles prefix) + "Read a group name." + (let* ((split-name (gnus-get-split-value gnus-move-split-methods)) + (minibuffer-confirm-incomplete nil) ; XEmacs + (prom + (format "%s %s to:" + prompt + (if (> (length articles) 1) + (format "these %d articles" (length articles)) + "this article"))) + (to-newsgroup + (cond + ((null split-name) + (gnus-completing-read default prom + gnus-active-hashtb + 'gnus-valid-move-group-p + nil prefix + 'gnus-group-history)) + ((= 1 (length split-name)) + (gnus-completing-read (car split-name) prom + gnus-active-hashtb + 'gnus-valid-move-group-p + nil nil + 'gnus-group-history)) + (t + (gnus-completing-read nil prom + (mapcar (lambda (el) (list el)) + (nreverse split-name)) + nil nil nil + 'gnus-group-history))))) + (when to-newsgroup + (if (or (string= to-newsgroup "") + (string= to-newsgroup prefix)) + (setq to-newsgroup default)) + (unless to-newsgroup + (error "No group name entered")) + (or (gnus-active to-newsgroup) + (gnus-activate-group to-newsgroup) + (if (gnus-y-or-n-p (format "No such group: %s. Create it? " + to-newsgroup)) + (or (and (gnus-request-create-group + to-newsgroup (gnus-group-name-to-method to-newsgroup)) + (gnus-activate-group to-newsgroup nil nil + (gnus-group-name-to-method + to-newsgroup))) + (error "Couldn't create group %s" to-newsgroup))) + (error "No such group: %s" to-newsgroup))) + to-newsgroup)) + +;; Summary extract commands + +(defun gnus-summary-insert-pseudos (pslist &optional not-view) + (let ((buffer-read-only nil) + (article (gnus-summary-article-number)) + after-article b e) + (unless (gnus-summary-goto-subject article) + (error "No such article: %d" article)) + (gnus-summary-position-point) + ;; If all commands are to be bunched up on one line, we collect + ;; them here. + (unless gnus-view-pseudos-separately + (let ((ps (setq pslist (sort pslist 'gnus-pseudos<))) + files action) + (while ps + (setq action (cdr (assq 'action (car ps)))) + (setq files (list (cdr (assq 'name (car ps))))) + (while (and ps (cdr ps) + (string= (or action "1") + (or (cdr (assq 'action (cadr ps))) "2"))) + (push (cdr (assq 'name (cadr ps))) files) + (setcdr ps (cddr ps))) + (when files + (when (not (string-match "%s" action)) + (push " " files)) + (push " " files) + (when (assq 'execute (car ps)) + (setcdr (assq 'execute (car ps)) + (funcall (if (string-match "%s" action) + 'format 'concat) + action + (mapconcat + (lambda (f) + (if (equal f " ") + f + (gnus-quote-arg-for-sh-or-csh f))) + files " "))))) + (setq ps (cdr ps))))) + (if (and gnus-view-pseudos (not not-view)) + (while pslist + (when (assq 'execute (car pslist)) + (gnus-execute-command (cdr (assq 'execute (car pslist))) + (eq gnus-view-pseudos 'not-confirm))) + (setq pslist (cdr pslist))) + (save-excursion + (while pslist + (setq after-article (or (cdr (assq 'article (car pslist))) + (gnus-summary-article-number))) + (gnus-summary-goto-subject after-article) + (forward-line 1) + (setq b (point)) + (insert " " (file-name-nondirectory + (cdr (assq 'name (car pslist)))) + ": " (or (cdr (assq 'execute (car pslist))) "") "\n") + (setq e (point)) + (forward-line -1) ; back to `b' + (gnus-add-text-properties + b (1- e) (list 'gnus-number gnus-reffed-article-number + gnus-mouse-face-prop gnus-mouse-face)) + (gnus-data-enter + after-article gnus-reffed-article-number + gnus-unread-mark b (car pslist) 0 (- e b)) + (push gnus-reffed-article-number gnus-newsgroup-unreads) + (setq gnus-reffed-article-number (1- gnus-reffed-article-number)) + (setq pslist (cdr pslist))))))) + +(defun gnus-pseudos< (p1 p2) + (let ((c1 (cdr (assq 'action p1))) + (c2 (cdr (assq 'action p2)))) + (and c1 c2 (string< c1 c2)))) + +(defun gnus-request-pseudo-article (props) + (cond ((assq 'execute props) + (gnus-execute-command (cdr (assq 'execute props))))) + (let ((gnus-current-article (gnus-summary-article-number))) + (run-hooks 'gnus-mark-article-hook))) + +(defun gnus-execute-command (command &optional automatic) + (save-excursion + (gnus-article-setup-buffer) + (set-buffer gnus-article-buffer) + (setq buffer-read-only nil) + (let ((command (if automatic command + (read-string "Command: " (cons command 0))))) + (erase-buffer) + (insert "$ " command "\n\n") + (if gnus-view-pseudo-asynchronously + (start-process "gnus-execute" (current-buffer) shell-file-name + shell-command-switch command) + (call-process shell-file-name nil t nil + shell-command-switch command))))) + +;; Summary kill commands. + +(defun gnus-summary-edit-global-kill (article) + "Edit the \"global\" kill file." + (interactive (gnus-summary-article-number)) + (gnus-set-global-variables) + (gnus-group-edit-global-kill article)) + +(defun gnus-summary-edit-local-kill () + "Edit a local kill file applied to the current newsgroup." + (interactive) + (gnus-set-global-variables) + (setq gnus-current-headers (gnus-summary-article-header)) + (gnus-set-global-variables) + (gnus-group-edit-local-kill + (gnus-summary-article-number) gnus-newsgroup-name)) + +;;; Header reading. + +(defun gnus-read-header (id &optional header) + "Read the headers of article ID and enter them into the Gnus system." + (let ((group gnus-newsgroup-name) + (gnus-override-method + (and (gnus-news-group-p gnus-newsgroup-name) + gnus-refer-article-method)) + where) + ;; First we check to see whether the header in question is already + ;; fetched. + (if (stringp id) + ;; This is a Message-ID. + (setq header (or header (gnus-id-to-header id))) + ;; This is an article number. + (setq header (or header (gnus-summary-article-header id)))) + (if (and header + (not (gnus-summary-article-sparse-p (mail-header-number header)))) + ;; We have found the header. + header + ;; We have to really fetch the header to this article. + (save-excursion + (set-buffer nntp-server-buffer) + (when (setq where (gnus-request-head id group)) + (nnheader-fold-continuation-lines) + (goto-char (point-max)) + (insert ".\n") + (goto-char (point-min)) + (insert "211 ") + (princ (cond + ((numberp id) id) + ((cdr where) (cdr where)) + (header (mail-header-number header)) + (t gnus-reffed-article-number)) + (current-buffer)) + (insert " Article retrieved.\n")) + (if (or (not where) + (not (setq header (car (gnus-get-newsgroup-headers nil t))))) + () ; Malformed head. + (unless (gnus-summary-article-sparse-p (mail-header-number header)) + (when (and (stringp id) + (not (string= (gnus-group-real-name group) + (car where)))) + ;; If we fetched by Message-ID and the article came + ;; from a different group, we fudge some bogus article + ;; numbers for this article. + (mail-header-set-number header gnus-reffed-article-number)) + (save-excursion + (set-buffer gnus-summary-buffer) + (decf gnus-reffed-article-number) + (gnus-remove-header (mail-header-number header)) + (push header gnus-newsgroup-headers) + (setq gnus-current-headers header) + (push (mail-header-number header) gnus-newsgroup-limit))) + header))))) + +(defun gnus-remove-header (number) + "Remove header NUMBER from `gnus-newsgroup-headers'." + (if (and gnus-newsgroup-headers + (= number (mail-header-number (car gnus-newsgroup-headers)))) + (pop gnus-newsgroup-headers) + (let ((headers gnus-newsgroup-headers)) + (while (and (cdr headers) + (not (= number (mail-header-number (cadr headers))))) + (pop headers)) + (when (cdr headers) + (setcdr headers (cddr headers)))))) + +;;; +;;; summary highlights +;;; + +(defun gnus-highlight-selected-summary () + ;; Added by Per Abrahamsen . + ;; Highlight selected article in summary buffer + (when gnus-summary-selected-face + (save-excursion + (let* ((beg (progn (beginning-of-line) (point))) + (end (progn (end-of-line) (point))) + ;; Fix by Mike Dugan . + (from (if (get-text-property beg gnus-mouse-face-prop) + beg + (or (next-single-property-change + beg gnus-mouse-face-prop nil end) + beg))) + (to + (if (= from end) + (- from 2) + (or (next-single-property-change + from gnus-mouse-face-prop nil end) + end)))) + ;; If no mouse-face prop on line we will have to = from = end, + ;; so we highlight the entire line instead. + (when (= (+ to 2) from) + (setq from beg) + (setq to end)) + (if gnus-newsgroup-selected-overlay + ;; Move old overlay. + (gnus-move-overlay + gnus-newsgroup-selected-overlay from to (current-buffer)) + ;; Create new overlay. + (gnus-overlay-put + (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to)) + 'face gnus-summary-selected-face)))))) + +;; New implementation by Christian Limpach . +(defun gnus-summary-highlight-line () + "Highlight current line according to `gnus-summary-highlight'." + (let* ((list gnus-summary-highlight) + (p (point)) + (end (progn (end-of-line) (point))) + ;; now find out where the line starts and leave point there. + (beg (progn (beginning-of-line) (point))) + (article (gnus-summary-article-number)) + (score (or (cdr (assq (or article gnus-current-article) + gnus-newsgroup-scored)) + gnus-summary-default-score 0)) + (mark (or (gnus-summary-article-mark) gnus-unread-mark)) + (inhibit-read-only t)) + ;; Eval the cars of the lists until we find a match. + (let ((default gnus-summary-default-score)) + (while (and list + (not (eval (caar list)))) + (setq list (cdr list)))) + (let ((face (cdar list))) + (unless (eq face (get-text-property beg 'face)) + (gnus-put-text-property + beg end 'face + (setq face (if (boundp face) (symbol-value face) face))) + (when gnus-summary-highlight-line-function + (funcall gnus-summary-highlight-line-function article face)))) + (goto-char p))) + +(defun gnus-update-read-articles (group unread &optional compute) + "Update the list of read articles in GROUP." + (let* ((active (or gnus-newsgroup-active (gnus-active group))) + (entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + (prev 1) + (unread (sort (copy-sequence unread) '<)) + read) + (if (or (not info) (not active)) + ;; There is no info on this group if it was, in fact, + ;; killed. Gnus stores no information on killed groups, so + ;; there's nothing to be done. + ;; One could store the information somewhere temporarily, + ;; perhaps... Hmmm... + () + ;; Remove any negative articles numbers. + (while (and unread (< (car unread) 0)) + (setq unread (cdr unread))) + ;; Remove any expired article numbers + (while (and unread (< (car unread) (car active))) + (setq unread (cdr unread))) + ;; Compute the ranges of read articles by looking at the list of + ;; unread articles. + (while unread + (when (/= (car unread) prev) + (push (if (= prev (1- (car unread))) prev + (cons prev (1- (car unread)))) + read)) + (setq prev (1+ (car unread))) + (setq unread (cdr unread))) + (when (<= prev (cdr active)) + (push (cons prev (cdr active)) read)) + (if compute + (if (> (length read) 1) (nreverse read) read) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-group-update-group ,group t)))) + ;; Enter this list into the group info. + (gnus-info-set-read + info (if (> (length read) 1) (nreverse read) read)) + ;; Set the number of unread articles in gnus-newsrc-hashtb. + (gnus-get-unread-articles-in-group info (gnus-active group)) + t)))) + +(defun gnus-offer-save-summaries () + "Offer to save all active summary buffers." + (save-excursion + (let ((buflist (buffer-list)) + buffers bufname) + ;; Go through all buffers and find all summaries. + (while buflist + (and (setq bufname (buffer-name (car buflist))) + (string-match "Summary" bufname) + (save-excursion + (set-buffer bufname) + ;; We check that this is, indeed, a summary buffer. + (and (eq major-mode 'gnus-summary-mode) + ;; Also make sure this isn't bogus. + gnus-newsgroup-prepared + ;; Also make sure that this isn't a dead summary buffer. + (not gnus-dead-summary-mode))) + (push bufname buffers)) + (setq buflist (cdr buflist))) + ;; Go through all these summary buffers and offer to save them. + (when buffers + (map-y-or-n-p + "Update summary buffer %s? " + (lambda (buf) (switch-to-buffer buf) (gnus-summary-exit)) + buffers))))) + +(gnus-ems-redefine) + +(provide 'gnus-sum) + +(run-hooks 'gnus-sum-load-hook) + +;;; gnus-sum.el ends here diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el new file mode 100644 index 0000000..b802979 --- /dev/null +++ b/lisp/gnus-topic.el @@ -0,0 +1,1412 @@ +;;; gnus-topic.el --- a folding minor mode for Gnus group buffers +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Ilja Weis +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-group) +(require 'gnus-start) + +(defgroup gnus-topic nil + "Group topics." + :group 'gnus-group) + +(defvar gnus-topic-mode nil + "Minor mode for Gnus group buffers.") + +(defcustom gnus-topic-mode-hook nil + "Hook run in topic mode buffers." + :type 'hook + :group 'gnus-topic) + +(defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" + "Format of topic lines. +It works along the same lines as a normal formatting string, +with some simple extensions. + +%i Indentation based on topic level. +%n Topic name. +%v Nothing if the topic is visible, \"...\" otherwise. +%g Number of groups in the topic. +%a Number of unread articles in the groups in the topic. +%A Number of unread articles in the groups in the topic and its subtopics. +" + :type 'string + :group 'gnus-topic) + +(defcustom gnus-topic-indent-level 2 + "*How much each subtopic should be indented." + :type 'integer + :group 'gnus-topic) + +(defcustom gnus-topic-display-empty-topics t + "*If non-nil, display the topic lines even of topics that have no unread articles." + :type 'boolean + :group 'gnus-topic) + +;; Internal variables. + +(defvar gnus-topic-active-topology nil) +(defvar gnus-topic-active-alist nil) + +(defvar gnus-topology-checked-p nil + "Whether the topology has been checked in this session.") + +(defvar gnus-topic-killed-topics nil) +(defvar gnus-topic-inhibit-change-level nil) + +(defconst gnus-topic-line-format-alist + `((?n name ?s) + (?v visible ?s) + (?i indentation ?s) + (?g number-of-groups ?d) + (?a (gnus-topic-articles-in-topic entries) ?d) + (?A total-number-of-articles ?d) + (?l level ?d))) + +(defvar gnus-topic-line-format-spec nil) + +;;; Utility functions + +(defun gnus-group-topic-name () + "The name of the topic on the current line." + (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) + (and topic (symbol-name topic)))) + +(defun gnus-group-topic-level () + "The level of the topic on the current line." + (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) + +(defun gnus-group-topic-unread () + "The number of unread articles in topic on the current line." + (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) + +(defun gnus-topic-unread (topic) + "Return the number of unread articles in TOPIC." + (or (save-excursion + (and (gnus-topic-goto-topic topic) + (gnus-group-topic-unread))) + 0)) + +(defun gnus-group-topic-p () + "Return non-nil if the current line is a topic." + (gnus-group-topic-name)) + +(defun gnus-topic-visible-p () + "Return non-nil if the current topic is visible." + (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) + +(defun gnus-topic-articles-in-topic (entries) + (let ((total 0) + number) + (while entries + (when (numberp (setq number (car (pop entries)))) + (incf total number))) + total)) + +(defun gnus-group-topic (group) + "Return the topic GROUP is a member of." + (let ((alist gnus-topic-alist) + out) + (while alist + (when (member group (cdar alist)) + (setq out (caar alist) + alist nil)) + (setq alist (cdr alist))) + out)) + +(defun gnus-group-parent-topic (group) + "Return the topic GROUP is member of by looking at the group buffer." + (save-excursion + (set-buffer gnus-group-buffer) + (if (gnus-group-goto-group group) + (gnus-current-topic) + (gnus-group-topic group)))) + +(defun gnus-topic-goto-topic (topic) + "Go to TOPIC." + (when topic + (gnus-goto-char (text-property-any (point-min) (point-max) + 'gnus-topic (intern topic))))) + +(defun gnus-current-topic () + "Return the name of the current topic." + (let ((result + (or (get-text-property (point) 'gnus-topic) + (save-excursion + (and (gnus-goto-char (previous-single-property-change + (point) 'gnus-topic)) + (get-text-property (max (1- (point)) (point-min)) + 'gnus-topic)))))) + (when result + (symbol-name result)))) + +(defun gnus-current-topics () + "Return a list of all current topics, lowest in hierarchy first." + (let ((topic (gnus-current-topic)) + topics) + (while topic + (push topic topics) + (setq topic (gnus-topic-parent-topic topic))) + (nreverse topics))) + +(defun gnus-group-active-topic-p () + "Say whether the current topic comes from the active topics." + (save-excursion + (beginning-of-line) + (get-text-property (point) 'gnus-active))) + +(defun gnus-topic-find-groups (topic &optional level all lowest) + "Return entries for all visible groups in TOPIC." + (let ((groups (cdr (assoc topic gnus-topic-alist))) + info clevel unread group params visible-groups entry active) + (setq lowest (or lowest 1)) + (setq level (or level 7)) + ;; We go through the newsrc to look for matches. + (while groups + (when (setq group (pop groups)) + (setq entry (gnus-gethash group gnus-newsrc-hashtb) + info (nth 2 entry) + params (gnus-info-params info) + active (gnus-active group) + unread (or (car entry) + (and (not (equal group "dummy.group")) + active + (- (1+ (cdr active)) (car active)))) + clevel (or (gnus-info-level info) + (if (member group gnus-zombie-list) 8 9)))) + (and + unread ; nil means that the group is dead. + (<= clevel level) + (>= clevel lowest) ; Is inside the level we want. + (or all + (if (eq unread t) + gnus-group-list-inactive-groups + (> unread 0)) + (and gnus-list-groups-with-ticked-articles + (cdr (assq 'tick (gnus-info-marks info)))) + ; Has right readedness. + ;; Check for permanent visibility. + (and gnus-permanently-visible-groups + (string-match gnus-permanently-visible-groups group)) + (memq 'visible params) + (cdr (assq 'visible params))) + ;; Add this group to the list of visible groups. + (push (or entry group) visible-groups))) + (nreverse visible-groups))) + +(defun gnus-topic-previous-topic (topic) + "Return the previous topic on the same level as TOPIC." + (let ((top (cddr (gnus-topic-find-topology + (gnus-topic-parent-topic topic))))) + (unless (equal topic (caaar top)) + (while (and top (not (equal (caaadr top) topic))) + (setq top (cdr top))) + (caaar top)))) + +(defun gnus-topic-parent-topic (topic &optional topology) + "Return the parent of TOPIC." + (unless topology + (setq topology gnus-topic-topology)) + (let ((parent (car (pop topology))) + result found) + (while (and topology + (not (setq found (equal (caaar topology) topic))) + (not (setq result (gnus-topic-parent-topic + topic (car topology))))) + (setq topology (cdr topology))) + (or result (and found parent)))) + +(defun gnus-topic-next-topic (topic &optional previous) + "Return the next sibling of TOPIC." + (let ((parentt (cddr (gnus-topic-find-topology + (gnus-topic-parent-topic topic)))) + prev) + (while (and parentt + (not (equal (caaar parentt) topic))) + (setq prev (caaar parentt) + parentt (cdr parentt))) + (if previous + prev + (caaadr parentt)))) + +(defun gnus-topic-forward-topic (num) + "Go to the next topic on the same level as the current one." + (let* ((topic (gnus-current-topic)) + (way (if (< num 0) 'gnus-topic-previous-topic + 'gnus-topic-next-topic)) + (num (abs num))) + (while (and (not (zerop num)) + (setq topic (funcall way topic))) + (when (gnus-topic-goto-topic topic) + (decf num))) + (unless (zerop num) + (goto-char (point-max))) + num)) + +(defun gnus-topic-find-topology (topic &optional topology level remove) + "Return the topology of TOPIC." + (unless topology + (setq topology gnus-topic-topology) + (setq level 0)) + (let ((top topology) + result) + (if (equal (caar topology) topic) + (progn + (when remove + (delq topology remove)) + (cons level topology)) + (setq topology (cdr topology)) + (while (and topology + (not (setq result (gnus-topic-find-topology + topic (car topology) (1+ level) + (and remove top))))) + (setq topology (cdr topology))) + result))) + +(defvar gnus-tmp-topics nil) +(defun gnus-topic-list (&optional topology) + "Return a list of all topics in the topology." + (unless topology + (setq topology gnus-topic-topology + gnus-tmp-topics nil)) + (push (caar topology) gnus-tmp-topics) + (mapcar 'gnus-topic-list (cdr topology)) + gnus-tmp-topics) + +;;; Topic parameter jazz + +(defun gnus-topic-parameters (topic) + "Return the parameters for TOPIC." + (let ((top (gnus-topic-find-topology topic))) + (when top + (nth 3 (cadr top))))) + +(defun gnus-topic-set-parameters (topic parameters) + "Set the topic parameters of TOPIC to PARAMETERS." + (let ((top (gnus-topic-find-topology topic))) + (unless top + (error "No such topic: %s" topic)) + ;; We may have to extend if there is no parameters here + ;; to begin with. + (unless (nthcdr 2 (cadr top)) + (nconc (cadr top) (list nil))) + (unless (nthcdr 3 (cadr top)) + (nconc (cadr top) (list nil))) + (setcar (nthcdr 3 (cadr top)) parameters) + (gnus-dribble-enter + (format "(gnus-topic-set-parameters %S '%S)" topic parameters)))) + +(defun gnus-group-topic-parameters (group) + "Compute the group parameters for GROUP taking into account inheritance from topics." + (let ((params-list (list (gnus-group-get-parameter group))) + topics params param out) + (save-excursion + (gnus-group-goto-group group) + (setq topics (gnus-current-topics)) + (while topics + (push (gnus-topic-parameters (pop topics)) params-list)) + ;; We probably have lots of nil elements here, so + ;; we remove them. Probably faster than doing this "properly". + (setq params-list (delq nil params-list)) + ;; Now we have all the parameters, so we go through them + ;; and do inheritance in the obvious way. + (while (setq params (pop params-list)) + (while (setq param (pop params)) + (when (atom param) + (setq param (cons param t))) + ;; Override any old versions of this param. + (setq out (delq (assq (car param) out) out)) + (push param out))) + ;; Return the resulting parameter list. + out))) + +;;; General utility functions + +(defun gnus-topic-enter-dribble () + (gnus-dribble-enter + (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) + +;;; Generating group buffers + +(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) + "List all newsgroups with unread articles of level LEVEL or lower, and +use the `gnus-group-topics' to sort the groups. +If ALL is non-nil, list groups that have no unread articles. +If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." + (set-buffer gnus-group-buffer) + (let ((buffer-read-only nil) + (lowest (or lowest 1))) + + (when (or (not gnus-topic-alist) + (not gnus-topology-checked-p)) + (gnus-topic-check-topology)) + + (unless list-topic + (erase-buffer)) + + ;; List dead groups? + (when (and (>= level gnus-level-zombie) + (<= lowest gnus-level-zombie)) + (gnus-group-prepare-flat-list-dead + (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) + gnus-level-zombie ?Z + regexp)) + + (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) + (gnus-group-prepare-flat-list-dead + (setq gnus-killed-list (sort gnus-killed-list 'string<)) + gnus-level-killed ?K + regexp)) + + ;; Use topics. + (prog1 + (when (< lowest gnus-level-zombie) + (if list-topic + (let ((top (gnus-topic-find-topology list-topic))) + (gnus-topic-prepare-topic (cdr top) (car top) + (or topic-level level) all + nil lowest)) + (gnus-topic-prepare-topic gnus-topic-topology 0 + (or topic-level level) all + nil lowest))) + + (gnus-group-set-mode-line) + (setq gnus-group-list-mode (cons level all)) + (run-hooks 'gnus-group-prepare-hook)))) + +(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent + lowest) + "Insert TOPIC into the group buffer. +If SILENT, don't insert anything. Return the number of unread +articles in the topic and its subtopics." + (let* ((type (pop topicl)) + (entries (gnus-topic-find-groups (car type) list-level all lowest)) + (visiblep (and (eq (nth 1 type) 'visible) (not silent))) + (gnus-group-indentation + (make-string (* gnus-topic-indent-level level) ? )) + (beg (progn (beginning-of-line) (point))) + (topicl (reverse topicl)) + (all-entries entries) + (point-max (point-max)) + (unread 0) + (topic (car type)) + info entry end active tick) + ;; Insert any sub-topics. + (while topicl + (incf unread + (gnus-topic-prepare-topic + (pop topicl) (1+ level) list-level all + (not visiblep) lowest))) + (setq end (point)) + (goto-char beg) + ;; Insert all the groups that belong in this topic. + (while (setq entry (pop entries)) + (when visiblep + (if (stringp entry) + ;; Dead groups. + (gnus-group-insert-group-line + entry (if (member entry gnus-zombie-list) 8 9) + nil (- (1+ (cdr (setq active (gnus-active entry)))) + (car active)) + nil) + ;; Living groups. + (when (setq info (nth 2 entry)) + (gnus-group-insert-group-line + (gnus-info-group info) + (gnus-info-level info) (gnus-info-marks info) + (car entry) (gnus-info-method info))))) + (when (and (listp entry) + (numberp (car entry))) + (incf unread (car entry))) + (when (listp entry) + (setq tick t))) + (goto-char beg) + ;; Insert the topic line. + (when (and (not silent) + (or gnus-topic-display-empty-topics ;We want empty topics + (not (zerop unread)) ;Non-empty + tick ;Ticked articles + (/= point-max (point-max)))) ;Unactivated groups + (gnus-extent-start-open (point)) + (gnus-topic-insert-topic-line + (car type) visiblep + (not (eq (nth 2 type) 'hidden)) + level all-entries unread)) + (goto-char end) + unread)) + +(defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) + "Remove the current topic." + (let ((topic (gnus-group-topic-name)) + (level (gnus-group-topic-level)) + (beg (progn (beginning-of-line) (point))) + buffer-read-only) + (when topic + (while (and (zerop (forward-line 1)) + (> (or (gnus-group-topic-level) (1+ level)) level))) + (delete-region beg (point)) + ;; Do the change in this rather odd manner because it has been + ;; reported that some topics share parts of some lists, for some + ;; reason. I have been unable to determine why this is the + ;; case, but this hack seems to take care of things. + (let ((data (cadr (gnus-topic-find-topology topic)))) + (setcdr data + (list (if insert 'visible 'invisible) + (if hide 'hide nil) + (cadddr data)))) + (if total-remove + (setq gnus-topic-alist + (delq (assoc topic gnus-topic-alist) gnus-topic-alist)) + (gnus-topic-insert-topic topic in-level))))) + +(defun gnus-topic-insert-topic (topic &optional level) + "Insert TOPIC." + (gnus-group-prepare-topics + (car gnus-group-list-mode) (cdr gnus-group-list-mode) + nil nil topic level)) + +(defun gnus-topic-fold (&optional insert) + "Remove/insert the current topic." + (let ((topic (gnus-group-topic-name))) + (when topic + (save-excursion + (if (not (gnus-group-active-topic-p)) + (gnus-topic-remove-topic + (or insert (not (gnus-topic-visible-p)))) + (let ((gnus-topic-topology gnus-topic-active-topology) + (gnus-topic-alist gnus-topic-active-alist) + (gnus-group-list-mode (cons 5 t))) + (gnus-topic-remove-topic + (or insert (not (gnus-topic-visible-p))) nil nil 9) + (gnus-topic-enter-dribble))))))) + +(defun gnus-topic-insert-topic-line (name visiblep shownp level entries + &optional unread) + (let* ((visible (if visiblep "" "...")) + (indentation (make-string (* gnus-topic-indent-level level) ? )) + (total-number-of-articles unread) + (number-of-groups (length entries)) + (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) + (beginning-of-line) + ;; Insert the text. + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + (eval gnus-topic-line-format-spec)) + (list 'gnus-topic (intern name) + 'gnus-topic-level level + 'gnus-topic-unread unread + 'gnus-active active-topic + 'gnus-topic-visible visiblep)))) + +(defun gnus-topic-update-topics-containing-group (group) + "Update all topics that have GROUP as a member." + (when (and (eq major-mode 'gnus-group-mode) + gnus-topic-mode) + (save-excursion + (let ((alist gnus-topic-alist)) + ;; This is probably not entirely correct. If a topic + ;; isn't shown, then it's not updated. But the updating + ;; should be performed in any case, since the topic's + ;; parent should be updated. Pfft. + (while alist + (when (and (member group (cdar alist)) + (gnus-topic-goto-topic (caar alist))) + (gnus-topic-update-topic-line (caar alist))) + (pop alist)))))) + +(defun gnus-topic-update-topic () + "Update all parent topics to the current group." + (when (and (eq major-mode 'gnus-group-mode) + gnus-topic-mode) + (let ((group (gnus-group-group-name)) + (m (point-marker)) + (buffer-read-only nil)) + (when (and group + (gnus-get-info group) + (gnus-topic-goto-topic (gnus-current-topic))) + (gnus-topic-update-topic-line (gnus-group-topic-name)) + (goto-char m) + (set-marker m nil) + (gnus-group-position-point))))) + +(defun gnus-topic-goto-missing-group (group) + "Place point where GROUP is supposed to be inserted." + (let* ((topic (gnus-group-topic group)) + (groups (cdr (assoc topic gnus-topic-alist))) + (g (cdr (member group groups))) + (unfound t)) + ;; Try to jump to a visible group. + (while (and g (not (gnus-group-goto-group (car g) t))) + (pop g)) + ;; It wasn't visible, so we try to see where to insert it. + (when (not g) + (setq g (cdr (member group (reverse groups)))) + (while (and g unfound) + (when (gnus-group-goto-group (pop g) t) + (forward-line 1) + (setq unfound nil))) + (when (and unfound + topic + (not (gnus-topic-goto-missing-topic topic))) + (gnus-topic-insert-topic-line + topic t t (car (gnus-topic-find-topology topic)) nil 0))))) + +(defun gnus-topic-goto-missing-topic (topic) + (if (gnus-topic-goto-topic topic) + (forward-line 1) + ;; Topic not displayed. + (let* ((top (gnus-topic-find-topology + (gnus-topic-parent-topic topic))) + (tp (reverse (cddr top)))) + (while (not (equal (caaar tp) topic)) + (setq tp (cdr tp))) + (pop tp) + (while (and tp + (not (gnus-topic-goto-topic (caaar tp)))) + (pop tp)) + (if tp + (gnus-topic-forward-topic 1) + (gnus-topic-goto-missing-topic (caadr top)))) + nil)) + +(defun gnus-topic-update-topic-line (topic-name &optional reads) + (let* ((top (gnus-topic-find-topology topic-name)) + (type (cadr top)) + (children (cddr top)) + (entries (gnus-topic-find-groups + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode))) + (parent (gnus-topic-parent-topic topic-name)) + (all-entries entries) + (unread 0) + old-unread entry) + (when (gnus-topic-goto-topic (car type)) + ;; Tally all the groups that belong in this topic. + (if reads + (setq unread (- (gnus-group-topic-unread) reads)) + (while children + (incf unread (gnus-topic-unread (caar (pop children))))) + (while (setq entry (pop entries)) + (when (numberp (car entry)) + (incf unread (car entry))))) + (setq old-unread (gnus-group-topic-unread)) + ;; Insert the topic line. + (gnus-topic-insert-topic-line + (car type) (gnus-topic-visible-p) + (not (eq (nth 2 type) 'hidden)) + (gnus-group-topic-level) all-entries unread) + (gnus-delete-line)) + (when parent + (forward-line -1) + (gnus-topic-update-topic-line + parent (- old-unread (gnus-group-topic-unread)))) + unread)) + +(defun gnus-topic-group-indentation () + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (forward-line -1) + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + +;;; Initialization + +(gnus-add-shutdown 'gnus-topic-close 'gnus) + +(defun gnus-topic-close () + (setq gnus-topic-active-topology nil + gnus-topic-active-alist nil + gnus-topic-killed-topics nil + gnus-topology-checked-p nil)) + +(defun gnus-topic-check-topology () + ;; The first time we set the topology to whatever we have + ;; gotten here, which can be rather random. + (unless gnus-topic-alist + (gnus-topic-init-alist)) + + (setq gnus-topology-checked-p t) + ;; Go through the topic alist and make sure that all topics + ;; are in the topic topology. + (let ((topics (gnus-topic-list)) + (alist gnus-topic-alist) + changed) + (while alist + (unless (member (caar alist) topics) + (nconc gnus-topic-topology + (list (list (list (caar alist) 'visible)))) + (setq changed t)) + (setq alist (cdr alist))) + (when changed + (gnus-topic-enter-dribble)) + ;; Conversely, go through the topology and make sure that all + ;; topologies have alists. + (while topics + (unless (assoc (car topics) gnus-topic-alist) + (push (list (car topics)) gnus-topic-alist)) + (pop topics))) + ;; Go through all living groups and make sure that + ;; they belong to some topic. + (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry)) + gnus-topic-alist))) + (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) + (newsrc (cdr gnus-newsrc-alist)) + group) + (while newsrc + (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) + (setcdr entry (list group)) + (setq entry (cdr entry))))) + ;; Go through all topics and make sure they contain only living groups. + (let ((alist gnus-topic-alist) + topic) + (while (setq topic (pop alist)) + (while (cdr topic) + (if (and (cadr topic) + (gnus-gethash (cadr topic) gnus-newsrc-hashtb)) + (setq topic (cdr topic)) + (setcdr topic (cddr topic))))))) + +(defun gnus-topic-init-alist () + "Initialize the topic structures." + (setq gnus-topic-topology + (cons (list "Gnus" 'visible) + (mapcar (lambda (topic) + (list (list (car topic) 'visible))) + '(("misc"))))) + (setq gnus-topic-alist + (list (cons "misc" + (mapcar (lambda (info) (gnus-info-group info)) + (cdr gnus-newsrc-alist))) + (list "Gnus"))) + (gnus-topic-enter-dribble)) + +;;; Maintenance + +(defun gnus-topic-clean-alist () + "Remove bogus groups from the topic alist." + (let ((topic-alist gnus-topic-alist) + result topic) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + (while (setq topic (pop topic-alist)) + (let ((topic-name (pop topic)) + group filtered-topic) + (while (setq group (pop topic)) + (when (and (or (gnus-gethash group gnus-active-hashtb) + (gnus-info-method (gnus-get-info group))) + (not (gnus-gethash group gnus-killed-hashtb))) + (push group filtered-topic))) + (push (cons topic-name (nreverse filtered-topic)) result))) + (setq gnus-topic-alist (nreverse result)))) + +(defun gnus-topic-change-level (group level oldlevel &optional previous) + "Run when changing levels to enter/remove groups from topics." + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-goto-group (or (car (nth 2 previous)) group)) + (when (and gnus-topic-mode + gnus-topic-alist + (not gnus-topic-inhibit-change-level)) + ;; Remove the group from the topics. + (when (and (< oldlevel gnus-level-zombie) + (>= level gnus-level-zombie)) + (let (alist) + (forward-line -1) + (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist)) + (setcdr alist (gnus-delete-first group (cdr alist)))))) + ;; If the group is subscribed we enter it into the topics. + (when (and (< level gnus-level-zombie) + (>= oldlevel gnus-level-zombie)) + (let* ((prev (gnus-group-group-name)) + (gnus-topic-inhibit-change-level t) + (gnus-group-indentation + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + (yanked (list group)) + alist talist end) + ;; Then we enter the yanked groups into the topics they belong + ;; to. + (when (setq alist (assoc (save-excursion + (forward-line -1) + (or + (gnus-current-topic) + (caar gnus-topic-topology))) + gnus-topic-alist)) + (setq talist alist) + (when (stringp yanked) + (setq yanked (list yanked))) + (if (not prev) + (nconc alist yanked) + (if (not (cdr alist)) + (setcdr alist (nconc yanked (cdr alist))) + (while (and (not end) (cdr alist)) + (when (equal (cadr alist) prev) + (setcdr alist (nconc yanked (cdr alist))) + (setq end t)) + (setq alist (cdr alist))) + (unless end + (nconc talist yanked)))))) + (gnus-topic-update-topic))))) + +(defun gnus-topic-goto-next-group (group props) + "Go to group or the next group after group." + (if (not group) + (if (not (memq 'gnus-topic props)) + (goto-char (point-max)) + (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))) + (if (gnus-group-goto-group group) + t + ;; The group is no longer visible. + (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) + (after (cdr (member group (cdr list))))) + ;; First try to put point on a group after the current one. + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after))) + ;; Then try to put point on a group before point. + (unless after + (setq after (cdr (member group (reverse (cdr list))))) + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after)))) + ;; Finally, just put point on the topic. + (if (not (car list)) + (goto-char (point-min)) + (unless after + (gnus-topic-goto-topic (car list)) + (setq after nil))) + t)))) + +;;; Topic-active functions + +(defun gnus-topic-grok-active (&optional force) + "Parse all active groups and create topic structures for them." + ;; First we make sure that we have really read the active file. + (when (or force + (not gnus-topic-active-alist)) + (let (groups) + ;; Get a list of all groups available. + (mapatoms (lambda (g) (when (symbol-value g) + (push (symbol-name g) groups))) + gnus-active-hashtb) + (setq groups (sort groups 'string<)) + ;; Init the variables. + (setq gnus-topic-active-topology (list (list "" 'visible))) + (setq gnus-topic-active-alist nil) + ;; Descend the top-level hierarchy. + (gnus-topic-grok-active-1 gnus-topic-active-topology groups) + ;; Set the top-level topic names to something nice. + (setcar (car gnus-topic-active-topology) "Gnus active") + (setcar (car gnus-topic-active-alist) "Gnus active")))) + +(defun gnus-topic-grok-active-1 (topology groups) + (let* ((name (caar topology)) + (prefix (concat "^" (regexp-quote name))) + tgroups ntopology group) + (while (and groups + (string-match prefix (setq group (car groups)))) + (if (not (string-match "\\." group (match-end 0))) + ;; There are no further hierarchies here, so we just + ;; enter this group into the list belonging to this + ;; topic. + (push (pop groups) tgroups) + ;; New sub-hierarchy, so we add it to the topology. + (nconc topology (list (setq ntopology + (list (list (substring + group 0 (match-end 0)) + 'invisible))))) + ;; Descend the hierarchy. + (setq groups (gnus-topic-grok-active-1 ntopology groups)))) + ;; We remove the trailing "." from the topic name. + (setq name + (if (string-match "\\.$" name) + (substring name 0 (match-beginning 0)) + name)) + ;; Add this topic and its groups to the topic alist. + (push (cons name (nreverse tgroups)) gnus-topic-active-alist) + (setcar (car topology) name) + ;; We return the rest of the groups that didn't belong + ;; to this topic. + groups)) + +;;; Topic mode, commands and keymap. + +(defvar gnus-topic-mode-map nil) +(defvar gnus-group-topic-map nil) + +(unless gnus-topic-mode-map + (setq gnus-topic-mode-map (make-sparse-keymap)) + + ;; Override certain group mode keys. + (gnus-define-keys gnus-topic-mode-map + "=" gnus-topic-select-group + "\r" gnus-topic-select-group + " " gnus-topic-read-group + "\C-k" gnus-topic-kill-group + "\C-y" gnus-topic-yank-group + "\M-g" gnus-topic-get-new-news-this-topic + "AT" gnus-topic-list-active + "Gp" gnus-topic-edit-parameters + "#" gnus-topic-mark-topic + "\M-#" gnus-topic-unmark-topic + gnus-mouse-2 gnus-mouse-pick-topic) + + ;; Define a new submap. + (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) + "#" gnus-topic-mark-topic + "\M-#" gnus-topic-unmark-topic + "n" gnus-topic-create-topic + "m" gnus-topic-move-group + "D" gnus-topic-remove-group + "c" gnus-topic-copy-group + "h" gnus-topic-hide-topic + "s" gnus-topic-show-topic + "M" gnus-topic-move-matching + "C" gnus-topic-copy-matching + "\C-i" gnus-topic-indent + [tab] gnus-topic-indent + "r" gnus-topic-rename + "\177" gnus-topic-delete + [delete] gnus-topic-delete + "h" gnus-topic-toggle-display-empty-topics) + + (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) + "s" gnus-topic-sort-groups + "a" gnus-topic-sort-groups-by-alphabet + "u" gnus-topic-sort-groups-by-unread + "l" gnus-topic-sort-groups-by-level + "v" gnus-topic-sort-groups-by-score + "r" gnus-topic-sort-groups-by-rank + "m" gnus-topic-sort-groups-by-method)) + +(defun gnus-topic-make-menu-bar () + (unless (boundp 'gnus-topic-menu) + (easy-menu-define + gnus-topic-menu gnus-topic-mode-map "" + '("Topics" + ["Toggle topics" gnus-topic-mode t] + ("Groups" + ["Copy" gnus-topic-copy-group t] + ["Move" gnus-topic-move-group t] + ["Remove" gnus-topic-remove-group t] + ["Copy matching" gnus-topic-copy-matching t] + ["Move matching" gnus-topic-move-matching t]) + ("Topics" + ["Show" gnus-topic-show-topic t] + ["Hide" gnus-topic-hide-topic t] + ["Delete" gnus-topic-delete t] + ["Rename" gnus-topic-rename t] + ["Create" gnus-topic-create-topic t] + ["Mark" gnus-topic-mark-topic t] + ["Indent" gnus-topic-indent t] + ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] + ["Edit parameters" gnus-topic-edit-parameters t]) + ["List active" gnus-topic-list-active t])))) + +(defun gnus-topic-mode (&optional arg redisplay) + "Minor mode for topicsifying Gnus group buffers." + (interactive (list current-prefix-arg t)) + (when (eq major-mode 'gnus-group-mode) + (make-local-variable 'gnus-topic-mode) + (setq gnus-topic-mode + (if (null arg) (not gnus-topic-mode) + (> (prefix-numeric-value arg) 0))) + ;; Infest Gnus with topics. + (if (not gnus-topic-mode) + (setq gnus-goto-missing-group-function nil) + (when (gnus-visual-p 'topic-menu 'menu) + (gnus-topic-make-menu-bar)) + (gnus-set-format 'topic t) + (gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) + (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) + (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) + (set (make-local-variable 'gnus-group-prepare-function) + 'gnus-group-prepare-topics) + (set (make-local-variable 'gnus-group-get-parameter-function) + 'gnus-group-topic-parameters) + (set (make-local-variable 'gnus-group-goto-next-group-function) + 'gnus-topic-goto-next-group) + (set (make-local-variable 'gnus-group-indentation-function) + 'gnus-topic-group-indentation) + (set (make-local-variable 'gnus-group-update-group-function) + 'gnus-topic-update-topics-containing-group) + (set (make-local-variable 'gnus-group-sort-alist-function) + 'gnus-group-sort-topic) + (setq gnus-group-change-level-function 'gnus-topic-change-level) + (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) + (make-local-hook 'gnus-check-bogus-groups-hook) + (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) + (setq gnus-topology-checked-p nil) + ;; We check the topology. + (when gnus-newsrc-alist + (gnus-topic-check-topology)) + (run-hooks 'gnus-topic-mode-hook)) + ;; Remove topic infestation. + (unless gnus-topic-mode + (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) + (remove-hook 'gnus-group-change-level-function + 'gnus-topic-change-level) + (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) + (setq gnus-group-prepare-function 'gnus-group-prepare-flat) + (setq gnus-group-sort-alist-function 'gnus-group-sort-flat)) + (when redisplay + (gnus-group-list-groups)))) + +(defun gnus-topic-select-group (&optional all) + "Select this newsgroup. +No article is selected automatically. +If ALL is non-nil, already read articles become readable. +If ALL is a number, fetch this number of articles. + +If performed over a topic line, toggle folding the topic." + (interactive "P") + (if (gnus-group-topic-p) + (let ((gnus-group-list-mode + (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) + (gnus-topic-fold all)) + (gnus-group-select-group all))) + +(defun gnus-mouse-pick-topic (e) + "Select the group or topic under the mouse pointer." + (interactive "e") + (mouse-set-point e) + (gnus-topic-read-group nil)) + +(defun gnus-topic-read-group (&optional all no-article group) + "Read news in this newsgroup. +If the prefix argument ALL is non-nil, already read articles become +readable. IF ALL is a number, fetch this number of articles. If the +optional argument NO-ARTICLE is non-nil, no article will be +auto-selected upon group entry. If GROUP is non-nil, fetch that +group. + +If performed over a topic line, toggle folding the topic." + (interactive "P") + (if (gnus-group-topic-p) + (let ((gnus-group-list-mode + (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) + (gnus-topic-fold all)) + (gnus-group-read-group all no-article group))) + +(defun gnus-topic-create-topic (topic parent &optional previous full-topic) + "Create a new TOPIC under PARENT. +When used interactively, PARENT will be the topic under point." + (interactive + (list + (read-string "New topic: ") + (gnus-current-topic))) + ;; Check whether this topic already exists. + (when (gnus-topic-find-topology topic) + (error "Topic already exists")) + (unless parent + (setq parent (caar gnus-topic-topology))) + (let ((top (cdr (gnus-topic-find-topology parent))) + (full-topic (or full-topic `((,topic visible))))) + (unless top + (error "No such parent topic: %s" parent)) + (if previous + (progn + (while (and (cdr top) + (not (equal (caaadr top) previous))) + (setq top (cdr top))) + (setcdr top (cons full-topic (cdr top)))) + (nconc top (list full-topic))) + (unless (assoc topic gnus-topic-alist) + (push (list topic) gnus-topic-alist))) + (gnus-topic-enter-dribble) + (gnus-group-list-groups) + (gnus-topic-goto-topic topic)) + +(defun gnus-topic-move-group (n topic &optional copyp) + "Move the next N groups to TOPIC. +If COPYP, copy the groups instead." + (interactive + (list current-prefix-arg + (completing-read "Move to topic: " gnus-topic-alist nil t))) + (let ((groups (gnus-group-process-prefix n)) + (topicl (assoc topic gnus-topic-alist)) + (start-group (progn (forward-line 1) (gnus-group-group-name))) + (start-topic (gnus-group-topic-name)) + entry) + (mapcar + (lambda (g) + (gnus-group-remove-mark g) + (when (and + (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) + (not copyp)) + (setcdr entry (gnus-delete-first g (cdr entry)))) + (nconc topicl (list g))) + groups) + (gnus-topic-enter-dribble) + (if start-group + (gnus-group-goto-group start-group) + (gnus-topic-goto-topic start-topic)) + (gnus-group-list-groups))) + +(defun gnus-topic-remove-group (&optional arg) + "Remove the current group from the topic." + (interactive "P") + (gnus-group-iterate arg + (lambda (group) + (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) + (buffer-read-only nil)) + (when (and topicl group) + (gnus-delete-line) + (gnus-delete-first group topicl)) + (gnus-topic-update-topic) + (gnus-group-position-point))))) + +(defun gnus-topic-copy-group (n topic) + "Copy the current group to a topic." + (interactive + (list current-prefix-arg + (completing-read "Copy to topic: " gnus-topic-alist nil t))) + (gnus-topic-move-group n topic t)) + +(defun gnus-topic-kill-group (&optional n discard) + "Kill the next N groups." + (interactive "P") + (if (gnus-group-topic-p) + (let ((topic (gnus-group-topic-name))) + (push (cons + (gnus-topic-find-topology topic) + (assoc topic gnus-topic-alist)) + gnus-topic-killed-topics) + (gnus-topic-remove-topic nil t) + (gnus-topic-find-topology topic nil nil gnus-topic-topology) + (gnus-topic-enter-dribble)) + (gnus-group-kill-group n discard) + (gnus-topic-update-topic))) + +(defun gnus-topic-yank-group (&optional arg) + "Yank the last topic." + (interactive "p") + (if gnus-topic-killed-topics + (let* ((previous + (or (gnus-group-topic-name) + (gnus-topic-next-topic (gnus-current-topic)))) + (data (pop gnus-topic-killed-topics)) + (alist (cdr data)) + (item (cdar data))) + (push alist gnus-topic-alist) + (gnus-topic-create-topic + (caar item) (gnus-topic-parent-topic previous) previous + item) + (gnus-topic-enter-dribble) + (gnus-topic-goto-topic (caar item))) + (let* ((prev (gnus-group-group-name)) + (gnus-topic-inhibit-change-level t) + (gnus-group-indentation + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + yanked alist) + ;; We first yank the groups the normal way... + (setq yanked (gnus-group-yank-group arg)) + ;; Then we enter the yanked groups into the topics they belong + ;; to. + (setq alist (assoc (save-excursion + (forward-line -1) + (gnus-current-topic)) + gnus-topic-alist)) + (when (stringp yanked) + (setq yanked (list yanked))) + (if (not prev) + (nconc alist yanked) + (if (not (cdr alist)) + (setcdr alist (nconc yanked (cdr alist))) + (while (cdr alist) + (when (equal (cadr alist) prev) + (setcdr alist (nconc yanked (cdr alist))) + (setq alist nil)) + (setq alist (cdr alist)))))) + (gnus-topic-update-topic))) + +(defun gnus-topic-hide-topic () + "Hide the current topic." + (interactive) + (when (gnus-current-topic) + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-topic-remove-topic nil nil 'hidden))) + +(defun gnus-topic-show-topic () + "Show the hidden topic." + (interactive) + (when (gnus-group-topic-p) + (gnus-topic-remove-topic t nil 'shown))) + +(defun gnus-topic-mark-topic (topic &optional unmark) + "Mark all groups in the topic with the process mark." + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-mark-group) + (save-excursion + (let ((groups (gnus-topic-find-groups topic 9 t))) + (while groups + (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) + (gnus-info-group (nth 2 (pop groups))))))))) + +(defun gnus-topic-unmark-topic (topic &optional unmark) + "Remove the process mark from all groups in the topic." + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-unmark-group) + (gnus-topic-mark-topic topic t))) + +(defun gnus-topic-get-new-news-this-topic (&optional n) + "Check for new news in the current topic." + (interactive "P") + (if (not (gnus-group-topic-p)) + (gnus-group-get-new-news-this-group n) + (gnus-topic-mark-topic (gnus-group-topic-name)) + (gnus-group-get-new-news-this-group))) + +(defun gnus-topic-move-matching (regexp topic &optional copyp) + "Move all groups that match REGEXP to some topic." + (interactive + (let (topic) + (nreverse + (list + (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) + (read-string (format "Move to %s (regexp): " topic)))))) + (gnus-group-mark-regexp regexp) + (gnus-topic-move-group nil topic copyp)) + +(defun gnus-topic-copy-matching (regexp topic &optional copyp) + "Copy all groups that match REGEXP to some topic." + (interactive + (let (topic) + (nreverse + (list + (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) + (read-string (format "Copy to %s (regexp): " topic)))))) + (gnus-topic-move-matching regexp topic t)) + +(defun gnus-topic-delete (topic) + "Delete a topic." + (interactive (list (gnus-group-topic-name))) + (unless topic + (error "No topic to be deleted")) + (let ((entry (assoc topic gnus-topic-alist)) + (buffer-read-only nil)) + (when (cdr entry) + (error "Topic not empty")) + ;; Delete if visible. + (when (gnus-topic-goto-topic topic) + (gnus-delete-line)) + ;; Remove from alist. + (setq gnus-topic-alist (delq entry gnus-topic-alist)) + ;; Remove from topology. + (gnus-topic-find-topology topic nil nil 'delete) + (gnus-dribble-touch))) + +(defun gnus-topic-rename (old-name new-name) + "Rename a topic." + (interactive + (let ((topic (gnus-current-topic))) + (list topic + (read-string (format "Rename %s to: " topic))))) + (let ((top (gnus-topic-find-topology old-name)) + (entry (assoc old-name gnus-topic-alist))) + (when top + (setcar (cadr top) new-name)) + (when entry + (setcar entry new-name)) + (forward-line -1) + (gnus-dribble-touch) + (gnus-group-list-groups))) + +(defun gnus-topic-indent (&optional unindent) + "Indent a topic -- make it a sub-topic of the previous topic. +If UNINDENT, remove an indentation." + (interactive "P") + (if unindent + (gnus-topic-unindent) + (let* ((topic (gnus-current-topic)) + (parent (gnus-topic-previous-topic topic)) + (buffer-read-only nil)) + (unless parent + (error "Nothing to indent %s into" topic)) + (when topic + (gnus-topic-goto-topic topic) + (gnus-topic-kill-group) + (push (cdar gnus-topic-killed-topics) gnus-topic-alist) + (gnus-topic-create-topic + topic parent nil (cdaar gnus-topic-killed-topics)) + (pop gnus-topic-killed-topics) + (or (gnus-topic-goto-topic topic) + (gnus-topic-goto-topic parent)))))) + +(defun gnus-topic-unindent () + "Unindent a topic." + (interactive) + (let* ((topic (gnus-current-topic)) + (parent (gnus-topic-parent-topic topic)) + (grandparent (gnus-topic-parent-topic parent))) + (unless grandparent + (error "Nothing to indent %s into" topic)) + (when topic + (gnus-topic-goto-topic topic) + (gnus-topic-kill-group) + (push (cdar gnus-topic-killed-topics) gnus-topic-alist) + (gnus-topic-create-topic + topic grandparent (gnus-topic-next-topic parent) + (cdaar gnus-topic-killed-topics)) + (pop gnus-topic-killed-topics) + (gnus-topic-goto-topic topic)))) + +(defun gnus-topic-list-active (&optional force) + "List all groups that Gnus knows about in a topicsified fashion. +If FORCE, always re-read the active file." + (interactive "P") + (when force + (gnus-get-killed-groups)) + (gnus-topic-grok-active force) + (let ((gnus-topic-topology gnus-topic-active-topology) + (gnus-topic-alist gnus-topic-active-alist) + gnus-killed-list gnus-zombie-list) + (gnus-group-list-groups 9 nil 1))) + +(defun gnus-topic-toggle-display-empty-topics () + "Show/hide topics that have no unread articles." + (interactive) + (setq gnus-topic-display-empty-topics + (not gnus-topic-display-empty-topics)) + (gnus-group-list-groups) + (message "%s empty topics" + (if gnus-topic-display-empty-topics + "Showing" "Hiding"))) + +;;; Topic sorting functions + +(defun gnus-topic-edit-parameters (group) + "Edit the group parameters of GROUP. +If performed on a topic, edit the topic parameters instead." + (interactive (list (gnus-group-group-name))) + (if group + (gnus-group-edit-group-parameters group) + (if (not (gnus-group-topic-p)) + (error "Nothing to edit on the current line") + (let ((topic (gnus-group-topic-name))) + (gnus-edit-form + (gnus-topic-parameters topic) + (format "Editing the topic parameters for `%s'." + (or group topic)) + `(lambda (form) + (gnus-topic-set-parameters ,topic form))))))) + +(defun gnus-group-sort-topic (func reverse) + "Sort groups in the topics according to FUNC and REVERSE." + (let ((alist gnus-topic-alist)) + (while alist + ;; !!!Sometimes nil elements sneak into the alist, + ;; for some reason or other. + (setcar alist (delq nil (car alist))) + (setcar alist (delete "dummy.group" (car alist))) + (gnus-topic-sort-topic (pop alist) func reverse)))) + +(defun gnus-topic-sort-topic (topic func reverse) + ;; Each topic only lists the name of the group, while + ;; the sort predicates expect group infos as inputs. + ;; So we first transform the group names into infos, + ;; then sort, and then transform back into group names. + (setcdr + topic + (mapcar + (lambda (info) (gnus-info-group info)) + (sort + (mapcar + (lambda (group) (gnus-get-info group)) + (cdr topic)) + func))) + ;; Do the reversal, if necessary. + (when reverse + (setcdr topic (nreverse (cdr topic))))) + +(defun gnus-topic-sort-groups (func &optional reverse) + "Sort the current topic according to FUNC. +If REVERSE, reverse the sorting order." + (interactive (list gnus-group-sort-function current-prefix-arg)) + (let ((topic (assoc (gnus-current-topic) gnus-topic-alist))) + (gnus-topic-sort-topic + topic (gnus-make-sort-function func) reverse) + (gnus-group-list-groups))) + +(defun gnus-topic-sort-groups-by-alphabet (&optional reverse) + "Sort the current topic alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-topic-sort-groups-by-unread (&optional reverse) + "Sort the current topic by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-topic-sort-groups-by-level (&optional reverse) + "Sort the current topic by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-topic-sort-groups-by-score (&optional reverse) + "Sort the current topic by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-topic-sort-groups-by-rank (&optional reverse) + "Sort the current topic by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-topic-sort-groups-by-method (&optional reverse) + "Sort the current topic alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) + +(provide 'gnus-topic) + +;;; gnus-topic.el ends here diff --git a/lisp/gnus-undo.el b/lisp/gnus-undo.el new file mode 100644 index 0000000..b34070a --- /dev/null +++ b/lisp/gnus-undo.el @@ -0,0 +1,174 @@ +;;; gnus-undo.el --- minor mode for undoing in Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package allows arbitrary undoing in Gnus buffers. As all the +;; Gnus buffers aren't very text-oriented (what is in the buffers is +;; just some random representation of the actual data), normal Emacs +;; undoing doesn't work at all for Gnus. +;; +;; This package works by letting Gnus register functions for reversing +;; actions, and then calling these functions when the user pushes the +;; `undo' key. As with normal `undo', there it is possible to set +;; undo boundaries and so on. +;; +;; Internally, the undo sequence is represented by the +;; `gnus-undo-actions' list, where each element is a list of functions +;; to be called, in sequence, to undo some action. (An "action" is a +;; collection of functions.) +;; +;; For instance, a function for killing a group will call +;; `gnus-undo-register' with a function that un-kills the group. This +;; package will put that function into an action. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus-util) +(require 'gnus) + +(defvar gnus-undo-mode nil + "Minor mode for undoing in Gnus buffers.") + +(defvar gnus-undo-mode-hook nil + "Hook called in all `gnus-undo-mode' buffers.") + +;;; Internal variables. + +(defvar gnus-undo-actions nil) +(defvar gnus-undo-boundary t) +(defvar gnus-undo-last nil) +(defvar gnus-undo-boundary-inhibit nil) + +;;; Minor mode definition. + +(defvar gnus-undo-mode-map nil) + +(unless gnus-undo-mode-map + (setq gnus-undo-mode-map (make-sparse-keymap)) + + (gnus-define-keys gnus-undo-mode-map + "\M-\C-_" gnus-undo + "\C-_" gnus-undo + "\C-xu" gnus-undo + ;; many people are used to type `C-/' on X terminals and get `C-_'. + [(control /)] gnus-undo)) + +(defun gnus-undo-make-menu-bar () + ;; This is disabled for the time being. + (when nil + (define-key-after (current-local-map) [menu-bar file gnus-undo] + (cons "Undo" 'gnus-undo-actions) + [menu-bar file whatever]))) + +(defun gnus-undo-mode (&optional arg) + "Minor mode for providing `undo' in Gnus buffers. + +\\{gnus-undo-mode-map}" + (interactive "P") + (set (make-local-variable 'gnus-undo-mode) + (if (null arg) (not gnus-undo-mode) + (> (prefix-numeric-value arg) 0))) + (set (make-local-variable 'gnus-undo-actions) nil) + (set (make-local-variable 'gnus-undo-boundary) t) + (when gnus-undo-mode + ;; Set up the menu. + (when (gnus-visual-p 'undo-menu 'menu) + (gnus-undo-make-menu-bar)) + (gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) + (make-local-hook 'post-command-hook) + (add-hook 'post-command-hook 'gnus-undo-boundary nil t) + (run-hooks 'gnus-undo-mode-hook))) + +;;; Interface functions. + +(defun gnus-disable-undo (&optional buffer) + "Disable undoing in the current buffer." + (interactive) + (save-excursion + (when buffer + (set-buffer buffer)) + (gnus-undo-mode -1))) + +(defun gnus-undo-boundary () + "Set Gnus undo boundary." + (if gnus-undo-boundary-inhibit + (setq gnus-undo-boundary-inhibit nil) + (setq gnus-undo-boundary t))) + +(defun gnus-undo-force-boundary () + "Set Gnus undo boundary." + (setq gnus-undo-boundary-inhibit nil + gnus-undo-boundary t)) + +(defun gnus-undo-register (form) + "Register FORMS as something to be performed to undo a change. +FORMS may use backtick quote syntax." + (when gnus-undo-mode + (gnus-undo-register-1 + `(lambda () + ,form)))) + +(put 'gnus-undo-register 'lisp-indent-function 0) +(put 'gnus-undo-register 'edebug-form-spec '(body)) + +(defun gnus-undo-register-1 (function) + "Register FUNCTION as something to be performed to undo a change." + (when gnus-undo-mode + (cond + ;; We are on a boundary, so we create a new action. + (gnus-undo-boundary + (push (list function) gnus-undo-actions) + (setq gnus-undo-boundary nil)) + ;; Prepend the function to an old action. + (gnus-undo-actions + (setcar gnus-undo-actions (cons function (car gnus-undo-actions)))) + ;; Initialize list. + (t + (setq gnus-undo-actions (list (list function))))) + (setq gnus-undo-boundary-inhibit t))) + +(defun gnus-undo (n) + "Undo some previous changes in Gnus buffers. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (interactive "p") + (unless gnus-undo-mode + (error "Undoing is not enabled in this buffer")) + (message "%s" last-command) + (when (or (not (eq last-command 'gnus-undo)) + (not gnus-undo-last)) + (setq gnus-undo-last gnus-undo-actions)) + (let ((action (pop gnus-undo-last))) + (unless action + (error "Nothing further to undo")) + (setq gnus-undo-actions (delq action gnus-undo-actions)) + (setq gnus-undo-boundary t) + (while action + (funcall (pop action))))) + +(provide 'gnus-undo) + +;;; gnus-undo.el ends here diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el new file mode 100644 index 0000000..638fb59 --- /dev/null +++ b/lisp/gnus-util.el @@ -0,0 +1,841 @@ +;;; gnus-util.el --- utility functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Nothing in this file depends on any other parts of Gnus -- all +;; functions and macros in this file are utility functions that are +;; used by Gnus and may be used by any other package without loading +;; Gnus first. + +;;; Code: + +(require 'custom) +(eval-when-compile (require 'cl)) +(require 'nnheader) +(require 'timezone) +(require 'message) + +(eval-and-compile + (autoload 'nnmail-date-to-time "nnmail")) + +(defun gnus-boundp (variable) + "Return non-nil if VARIABLE is bound and non-nil." + (and (boundp variable) + (symbol-value variable))) + +(defmacro gnus-eval-in-buffer-window (buffer &rest forms) + "Pop to BUFFER, evaluate FORMS, and then return to the original window." + (let ((tempvar (make-symbol "GnusStartBufferWindow")) + (w (make-symbol "w")) + (buf (make-symbol "buf"))) + `(let* ((,tempvar (selected-window)) + (,buf ,buffer) + (,w (get-buffer-window ,buf 'visible))) + (unwind-protect + (progn + (if ,w + (progn + (select-window ,w) + (set-buffer (window-buffer ,w))) + (pop-to-buffer ,buf)) + ,@forms) + (select-window ,tempvar))))) + +(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) +(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) + +(defmacro gnus-intern-safe (string hashtable) + "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." + `(let ((symbol (intern ,string ,hashtable))) + (or (boundp symbol) + (set symbol nil)) + symbol)) + +;; modified by MORIOKA Tomohiko +;; function `substring' might cut on a middle of multi-octet +;; character. +(defun gnus-truncate-string (str width) + (substring str 0 width)) + +;; Added by Geoffrey T. Dairiki . A safe way +;; to limit the length of a string. This function is necessary since +;; `(substr "abc" 0 30)' pukes with "Args out of range". +(defsubst gnus-limit-string (str width) + (if (> (length str) width) + (substring str 0 width) + str)) + +(defsubst gnus-functionp (form) + "Return non-nil if FORM is funcallable." + (or (and (symbolp form) (fboundp form)) + (and (listp form) (eq (car form) 'lambda)) + (byte-code-function-p form))) + +(defsubst gnus-goto-char (point) + (and point (goto-char point))) + +(defmacro gnus-buffer-exists-p (buffer) + `(let ((buffer ,buffer)) + (when buffer + (funcall (if (stringp buffer) 'get-buffer 'buffer-name) + buffer)))) + +(defmacro gnus-kill-buffer (buffer) + `(let ((buf ,buffer)) + (when (gnus-buffer-exists-p buf) + (kill-buffer buf)))) + +(if (fboundp 'point-at-bol) + (fset 'gnus-point-at-bol 'point-at-bol) + (defun gnus-point-at-bol () + "Return point at the beginning of the line." + (let ((p (point))) + (beginning-of-line) + (prog1 + (point) + (goto-char p))))) + +(if (fboundp 'point-at-eol) + (fset 'gnus-point-at-eol 'point-at-eol) + (defun gnus-point-at-eol () + "Return point at the end of the line." + (let ((p (point))) + (end-of-line) + (prog1 + (point) + (goto-char p))))) + +(defun gnus-delete-first (elt list) + "Delete by side effect the first occurrence of ELT as a member of LIST." + (if (equal (car list) elt) + (cdr list) + (let ((total list)) + (while (and (cdr list) + (not (equal (cadr list) elt))) + (setq list (cdr list))) + (when (cdr list) + (setcdr list (cddr list))) + total))) + +;; Delete the current line (and the next N lines). +(defmacro gnus-delete-line (&optional n) + `(delete-region (progn (beginning-of-line) (point)) + (progn (forward-line ,(or n 1)) (point)))) + +(defun gnus-byte-code (func) + "Return a form that can be `eval'ed based on FUNC." + (let ((fval (symbol-function func))) + (if (byte-code-function-p fval) + (let ((flist (append fval nil))) + (setcar flist 'byte-code) + flist) + (cons 'progn (cddr fval))))) + +(defun gnus-extract-address-components (from) + (let (name address) + ;; First find the address - the thing with the @ in it. This may + ;; not be accurate in mail addresses, but does the trick most of + ;; the time in news messages. + (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) + (setq address (substring from (match-beginning 0) (match-end 0)))) + ;; Then we check whether the "name

" format is used. + (and address + ;; Fix by MORIOKA Tomohiko + ;; Linear white space is not required. + (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) + (and (setq name (substring from 0 (match-beginning 0))) + ;; Strip any quotes from the name. + (string-match "\".*\"" name) + (setq name (substring name 1 (1- (match-end 0)))))) + ;; If not, then "address (name)" is used. + (or name + (and (string-match "(.+)" from) + (setq name (substring from (1+ (match-beginning 0)) + (1- (match-end 0))))) + (and (string-match "()" from) + (setq name address)) + ;; Fix by MORIOKA Tomohiko . + ;; XOVER might not support folded From headers. + (and (string-match "(.*" from) + (setq name (substring from (1+ (match-beginning 0)) + (match-end 0))))) + ;; Fix by Hallvard B Furuseth . + (list (or name from) (or address from)))) + +(defun gnus-fetch-field (field) + "Return the value of the header FIELD of current article." + (save-excursion + (save-restriction + (let ((case-fold-search t) + (inhibit-point-motion-hooks t)) + (nnheader-narrow-to-headers) + (message-fetch-field field))))) + +(defun gnus-goto-colon () + (beginning-of-line) + (search-forward ":" (gnus-point-at-eol) t)) + +(defun gnus-remove-text-with-property (prop) + "Delete all text in the current buffer with text property PROP." + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (while (get-text-property (point) prop) + (delete-char 1)) + (goto-char (next-single-property-change (point) prop nil (point-max)))))) + +(defun gnus-newsgroup-directory-form (newsgroup) + "Make hierarchical directory name from NEWSGROUP name." + (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) + (len (length newsgroup)) + idx) + ;; If this is a foreign group, we don't want to translate the + ;; entire name. + (if (setq idx (string-match ":" newsgroup)) + (aset newsgroup idx ?/) + (setq idx 0)) + ;; Replace all occurrences of `.' with `/'. + (while (< idx len) + (when (= (aref newsgroup idx) ?.) + (aset newsgroup idx ?/)) + (setq idx (1+ idx))) + newsgroup)) + +(defun gnus-newsgroup-savable-name (group) + ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) + ;; with dots. + (nnheader-replace-chars-in-string group ?/ ?.)) + +(defun gnus-string> (s1 s2) + (not (or (string< s1 s2) + (string= s1 s2)))) + +;;; Time functions. + +(defun gnus-days-between (date1 date2) + ;; Return the number of days between date1 and date2. + (- (gnus-day-number date1) (gnus-day-number date2))) + +(defun gnus-day-number (date) + (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) + (timezone-parse-date date)))) + (timezone-absolute-from-gregorian + (nth 1 dat) (nth 2 dat) (car dat)))) + +(defun gnus-time-to-day (time) + "Convert TIME to day number." + (let ((tim (decode-time time))) + (timezone-absolute-from-gregorian + (nth 4 tim) (nth 3 tim) (nth 5 tim)))) + +(defun gnus-encode-date (date) + "Convert DATE to internal time." + (let* ((parse (timezone-parse-date date)) + (date (mapcar (lambda (d) (and d (string-to-int d))) parse)) + (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3))))) + (encode-time (caddr time) (cadr time) (car time) + (caddr date) (cadr date) (car date) + (* 60 (timezone-zone-to-minute (nth 4 date)))))) + +(defun gnus-time-minus (t1 t2) + "Subtract two internal times." + (let ((borrow (< (cadr t1) (cadr t2)))) + (list (- (car t1) (car t2) (if borrow 1 0)) + (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) + +(defun gnus-time-less (t1 t2) + "Say whether time T1 is less than time T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(defun gnus-file-newer-than (file date) + (let ((fdate (nth 5 (file-attributes file)))) + (or (> (car fdate) (car date)) + (and (= (car fdate) (car date)) + (> (nth 1 fdate) (nth 1 date)))))) + +;;; Keymap macros. + +(defmacro gnus-local-set-keys (&rest plist) + "Set the keys in PLIST in the current keymap." + `(gnus-define-keys-1 (current-local-map) ',plist)) + +(defmacro gnus-define-keys (keymap &rest plist) + "Define all keys in PLIST in KEYMAP." + `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) + +(defmacro gnus-define-keys-safe (keymap &rest plist) + "Define all keys in PLIST in KEYMAP without overwriting previous definitions." + `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) + +(put 'gnus-define-keys 'lisp-indent-function 1) +(put 'gnus-define-keys-safe 'lisp-indent-function 1) +(put 'gnus-local-set-keys 'lisp-indent-function 1) + +(defmacro gnus-define-keymap (keymap &rest plist) + "Define all keys in PLIST in KEYMAP." + `(gnus-define-keys-1 ,keymap (quote ,plist))) + +(put 'gnus-define-keymap 'lisp-indent-function 1) + +(defun gnus-define-keys-1 (keymap plist &optional safe) + (when (null keymap) + (error "Can't set keys in a null keymap")) + (cond ((symbolp keymap) + (setq keymap (symbol-value keymap))) + ((keymapp keymap)) + ((listp keymap) + (set (car keymap) nil) + (define-prefix-command (car keymap)) + (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap)) + (setq keymap (symbol-value (car keymap))))) + (let (key) + (while plist + (when (symbolp (setq key (pop plist))) + (setq key (symbol-value key))) + (if (or (not safe) + (eq (lookup-key keymap key) 'undefined)) + (define-key keymap key (pop plist)) + (pop plist))))) + +(defun gnus-completing-read (default prompt &rest args) + ;; Like `completing-read', except that DEFAULT is the default argument. + (let* ((prompt (if default + (concat prompt " (default " default ") ") + (concat prompt " "))) + (answer (apply 'completing-read prompt args))) + (if (or (null answer) (zerop (length answer))) + default + answer))) + +;; Two silly functions to ensure that all `y-or-n-p' questions clear +;; the echo area. +(defun gnus-y-or-n-p (prompt) + (prog1 + (y-or-n-p prompt) + (message ""))) + +(defun gnus-yes-or-no-p (prompt) + (prog1 + (yes-or-no-p prompt) + (message ""))) + +;; I suspect there's a better way, but I haven't taken the time to do +;; it yet. -erik selberg@cs.washington.edu +(defun gnus-dd-mmm (messy-date) + "Return a string like DD-MMM from a big messy string" + (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) + (if (not datevec) + "??-???" + (format "%2s-%s" + (condition-case () + ;; Make sure leading zeroes are stripped. + (number-to-string (string-to-number (aref datevec 2))) + (error "??")) + (capitalize + (or (car + (nth (1- (string-to-number (aref datevec 1))) + timezone-months-assoc)) + "???")))))) + +(defmacro gnus-date-get-time (date) + "Convert DATE string to Emacs time. +Cache the result as a text property stored in DATE." + ;; Either return the cached value... + `(let ((d ,date)) + (if (equal "" d) + '(0 0) + (or (get-text-property 0 'gnus-time d) + ;; or compute the value... + (let ((time (nnmail-date-to-time d))) + ;; and store it back in the string. + (put-text-property 0 1 'gnus-time time d) + time))))) + +(defsubst gnus-time-iso8601 (time) + "Return a string of TIME in YYMMDDTHHMMSS format." + (format-time-string "%Y%m%dT%H%M%S" time)) + +(defun gnus-date-iso8601 (header) + "Convert the date field in HEADER to YYMMDDTHHMMSS" + (condition-case () + (gnus-time-iso8601 (gnus-date-get-time header)) + (error ""))) + +(defun gnus-mode-string-quote (string) + "Quote all \"%\"'s in STRING." + (save-excursion + (gnus-set-work-buffer) + (insert string) + (goto-char (point-min)) + (while (search-forward "%" nil t) + (insert "%")) + (buffer-string))) + +;; Make a hash table (default and minimum size is 256). +;; Optional argument HASHSIZE specifies the table size. +(defun gnus-make-hashtable (&optional hashsize) + (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0)) + +;; Make a number that is suitable for hashing; bigger than MIN and +;; equal to some 2^x. Many machines (such as sparcs) do not have a +;; hardware modulo operation, so they implement it in software. On +;; many sparcs over 50% of the time to intern is spent in the modulo. +;; Yes, it's slower than actually computing the hash from the string! +;; So we use powers of 2 so people can optimize the modulo to a mask. +(defun gnus-create-hash-size (min) + (let ((i 1)) + (while (< i min) + (setq i (* 2 i))) + i)) + +(defcustom gnus-verbose 7 + "*Integer that says how verbose Gnus should be. +The higher the number, the more messages Gnus will flash to say what +it's doing. At zero, Gnus will be totally mute; at five, Gnus will +display most important messages; and at ten, Gnus will keep on +jabbering all the time." + :group 'gnus-start + :type 'integer) + +;; Show message if message has a lower level than `gnus-verbose'. +;; Guideline for numbers: +;; 1 - error messages, 3 - non-serious error messages, 5 - messages +;; for things that take a long time, 7 - not very important messages +;; on stuff, 9 - messages inside loops. +(defun gnus-message (level &rest args) + (if (<= level gnus-verbose) + (apply 'message args) + ;; We have to do this format thingy here even if the result isn't + ;; shown - the return value has to be the same as the return value + ;; from `message'. + (apply 'format args))) + +(defun gnus-error (level &rest args) + "Beep an error if LEVEL is equal to or less than `gnus-verbose'." + (when (<= (floor level) gnus-verbose) + (apply 'message args) + (ding) + (let (duration) + (when (and (floatp level) + (not (zerop (setq duration (* 10 (- level (floor level))))))) + (sit-for duration)))) + nil) + +(defun gnus-split-references (references) + "Return a list of Message-IDs in REFERENCES." + (let ((beg 0) + ids) + (while (string-match "<[^>]+>" references beg) + (push (substring references (match-beginning 0) (setq beg (match-end 0))) + ids)) + (nreverse ids))) + +(defun gnus-parent-id (references &optional n) + "Return the last Message-ID in REFERENCES. +If N, return the Nth ancestor instead." + (when references + (let ((ids (inline (gnus-split-references references)))) + (while (nthcdr (or n 1) ids) + (setq ids (cdr ids))) + (car ids)))) + +(defsubst gnus-buffer-live-p (buffer) + "Say whether BUFFER is alive or not." + (and buffer + (get-buffer buffer) + (buffer-name (get-buffer buffer)))) + +(defun gnus-horizontal-recenter () + "Recenter the current buffer horizontally." + (if (< (current-column) (/ (window-width) 2)) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0) + (let* ((orig (point)) + (end (window-end (get-buffer-window (current-buffer) t))) + (max 0)) + ;; Find the longest line currently displayed in the window. + (goto-char (window-start)) + (while (and (not (eobp)) + (< (point) end)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (goto-char orig) + ;; Scroll horizontally to center (sort of) the point. + (if (> max (window-width)) + (set-window-hscroll + (get-buffer-window (current-buffer) t) + (min (- (current-column) (/ (window-width) 3)) + (+ 2 (- max (window-width))))) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) + max))) + +(defun gnus-read-event-char () + "Get the next event." + (let ((event (read-event))) + ;; should be gnus-characterp, but this can't be called in XEmacs anyway + (cons (and (numberp event) event) event))) + +(defun gnus-sortable-date (date) + "Make sortable string by string-lessp from DATE. +Timezone package is used." + (condition-case () + (progn + (setq date (inline (timezone-fix-time + date nil + (aref (inline (timezone-parse-date date)) 4)))) + (inline + (timezone-make-sortable-date + (aref date 0) (aref date 1) (aref date 2) + (inline + (timezone-make-time-string + (aref date 3) (aref date 4) (aref date 5)))))) + (error ""))) + +(defun gnus-copy-file (file &optional to) + "Copy FILE to TO." + (interactive + (list (read-file-name "Copy file: " default-directory) + (read-file-name "Copy file to: " default-directory))) + (unless to + (setq to (read-file-name "Copy file to: " default-directory))) + (when (file-directory-p to) + (setq to (concat (file-name-as-directory to) + (file-name-nondirectory file)))) + (copy-file file to)) + +(defun gnus-kill-all-overlays () + "Delete all overlays in the current buffer." + (unless gnus-xemacs + (let* ((overlayss (overlay-lists)) + (buffer-read-only nil) + (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) + (while overlays + (delete-overlay (pop overlays)))))) + +(defvar gnus-work-buffer " *gnus work*") + +(defun gnus-set-work-buffer () + "Put point in the empty Gnus work buffer." + (if (get-buffer gnus-work-buffer) + (progn + (set-buffer gnus-work-buffer) + (erase-buffer)) + (set-buffer (get-buffer-create gnus-work-buffer)) + (kill-all-local-variables) + (buffer-disable-undo (current-buffer)))) + +(defmacro gnus-group-real-name (group) + "Find the real name of a foreign newsgroup." + `(let ((gname ,group)) + (if (string-match "^[^:]+:" gname) + (substring gname (match-end 0)) + gname))) + +(defun gnus-make-sort-function (funs) + "Return a composite sort condition based on the functions in FUNC." + (cond + ((not (listp funs)) funs) + ((null funs) funs) + ((cdr funs) + `(lambda (t1 t2) + ,(gnus-make-sort-function-1 (reverse funs)))) + (t + (car funs)))) + +(defun gnus-make-sort-function-1 (funs) + "Return a composite sort condition based on the functions in FUNC." + (if (cdr funs) + `(or (,(car funs) t1 t2) + (and (not (,(car funs) t2 t1)) + ,(gnus-make-sort-function-1 (cdr funs)))) + `(,(car funs) t1 t2))) + +(defun gnus-turn-off-edit-menu (type) + "Turn off edit menu in `gnus-TYPE-mode-map'." + (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) + [menu-bar edit] 'undefined)) + +(defun gnus-prin1 (form) + "Use `prin1' on FORM in the current buffer. +Bind `print-quoted' to t while printing." + (let ((print-quoted t) + print-level print-length) + (prin1 form (current-buffer)))) + +(defun gnus-prin1-to-string (form) + "The same as `prin1', but but `print-quoted' to t." + (let ((print-quoted t)) + (prin1-to-string form))) + +(defun gnus-make-directory (directory) + "Make DIRECTORY (and all its parents) if it doesn't exist." + (when (and directory + (not (file-exists-p directory))) + (make-directory directory t)) + t) + +(defun gnus-write-buffer (file) + "Write the current buffer's contents to FILE." + ;; Make sure the directory exists. + (gnus-make-directory (file-name-directory file)) + ;; Write the buffer. + (write-region (point-min) (point-max) file nil 'quietly)) + +(defmacro gnus-delete-assq (key list) + `(let ((listval (eval ,list))) + (setq ,list (delq (assq ,key listval) listval)))) + +(defmacro gnus-delete-assoc (key list) + `(let ((listval ,list)) + (setq ,list (delq (assoc ,key listval) listval)))) + +(defun gnus-delete-file (file) + "Delete FILE if it exists." + (when (file-exists-p file) + (delete-file file))) + +(defun gnus-strip-whitespace (string) + "Return STRING stripped of all whitespace." + (while (string-match "[\r\n\t ]+" string) + (setq string (replace-match "" t t string))) + string) + +(defun gnus-put-text-property-excluding-newlines (beg end prop val) + "The same as `put-text-property', but don't put this prop on any newlines in the region." + (save-match-data + (save-excursion + (save-restriction + (goto-char beg) + (while (re-search-forward "[ \t]*\n" end 'move) + (put-text-property beg (match-beginning 0) prop val) + (setq beg (point))) + (put-text-property beg (point) prop val))))) + +;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 +;;; The primary idea here is to try to protect internal datastructures +;;; from becoming corrupted when the user hits C-g, or if a hook or +;;; similar blows up. Often in Gnus multiple tables/lists need to be +;;; updated at the same time, or information can be lost. + +(defvar gnus-atomic-be-safe t + "If t, certain operations will be protected from interruption by C-g.") + +(defmacro gnus-atomic-progn (&rest forms) + "Evaluate FORMS atomically, which means to protect the evaluation +from being interrupted by the user. An error from the forms themselves +will return without finishing the operation. Since interrupts from +the user are disabled, it is recommended that only the most minimal +operations are performed by FORMS. If you wish to assign many +complicated values atomically, compute the results into temporary +variables and then do only the assignment atomically." + `(let ((inhibit-quit gnus-atomic-be-safe)) + ,@forms)) + +(put 'gnus-atomic-progn 'lisp-indent-function 0) + +(defmacro gnus-atomic-progn-assign (protect &rest forms) + "Evaluate FORMS, but insure that the variables listed in PROTECT +are not changed if anything in FORMS signals an error or otherwise +non-locally exits. The variables listed in PROTECT are updated atomically. +It is safe to use gnus-atomic-progn-assign with long computations. + +Note that if any of the symbols in PROTECT were unbound, they will be +set to nil on a sucessful assignment. In case of an error or other +non-local exit, it will still be unbound." + (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol + (concat (symbol-name x) + "-tmp")) + x)) + protect)) + (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x))) + temp-sym-map)) + (temp-sym-let (mapcar (lambda (x) (list (car x) + `(and (boundp ',(cadr x)) + ,(cadr x)))) + temp-sym-map)) + (sym-temp-let sym-temp-map) + (temp-sym-assign (apply 'append temp-sym-map)) + (sym-temp-assign (apply 'append sym-temp-map)) + (result (make-symbol "result-tmp"))) + `(let (,@temp-sym-let + ,result) + (let ,sym-temp-let + (setq ,result (progn ,@forms)) + (setq ,@temp-sym-assign)) + (let ((inhibit-quit gnus-atomic-be-safe)) + (setq ,@sym-temp-assign)) + ,result))) + +(put 'gnus-atomic-progn-assign 'lisp-indent-function 1) +;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body)) + +(defmacro gnus-atomic-setq (&rest pairs) + "Similar to setq, except that the real symbols are only assigned when +there are no errors. And when the real symbols are assigned, they are +done so atomically. If other variables might be changed via side-effect, +see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq +with potentially long computations." + (let ((tpairs pairs) + syms) + (while tpairs + (push (car tpairs) syms) + (setq tpairs (cddr tpairs))) + `(gnus-atomic-progn-assign ,syms + (setq ,@pairs)))) + +;(put 'gnus-atomic-setq 'edebug-form-spec '(body)) + + +;;; Functions for saving to babyl/mail files. + +(defvar rmail-default-rmail-file) +(defun gnus-output-to-rmail (filename &optional ask) + "Append the current article to an Rmail file named FILENAME." + (require 'rmail) + ;; Most of these codes are borrowed from rmailout.el. + (setq filename (expand-file-name filename)) + (setq rmail-default-rmail-file filename) + (let ((artbuf (current-buffer)) + (tmpbuf (get-buffer-create " *Gnus-output*"))) + (save-excursion + (or (get-file-buffer filename) + (file-exists-p filename) + (if (or (not ask) + (gnus-yes-or-no-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (save-excursion + (set-buffer file-buffer) + (rmail-insert-rmail-file-header) + (let ((require-final-newline nil)) + (gnus-write-buffer filename))) + (kill-buffer file-buffer)) + (error "Output file does not exist"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-buffer-substring artbuf) + (gnus-convert-article-to-rmail) + ;; Decide whether to append to a file or to an Emacs buffer. + (let ((outbuf (get-file-buffer filename))) + (if (not outbuf) + (append-to-file (point-min) (point-max) filename) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil) + (msg (and (boundp 'rmail-current-message) + (symbol-value 'rmail-current-message)))) + ;; If MSG is non-nil, buffer is in RMAIL mode. + (when msg + (widen) + (narrow-to-region (point-max) (point-max))) + (insert-buffer-substring tmpbuf) + (when msg + (goto-char (point-min)) + (widen) + (search-backward "\^_") + (narrow-to-region (point) (point-max)) + (goto-char (1+ (point-min))) + (rmail-count-new-messages t) + (rmail-show-message msg)))))) + (kill-buffer tmpbuf))) + +(defun gnus-output-to-mail (filename &optional ask) + "Append the current article to a mail file named FILENAME." + (setq filename (expand-file-name filename)) + (let ((artbuf (current-buffer)) + (tmpbuf (get-buffer-create " *Gnus-output*"))) + (save-excursion + ;; Create the file, if it doesn't exist. + (when (and (not (get-file-buffer filename)) + (not (file-exists-p filename))) + (if (or (not ask) + (gnus-y-or-n-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (save-excursion + (set-buffer file-buffer) + (let ((require-final-newline nil)) + (gnus-write-buffer filename))) + (kill-buffer file-buffer)) + (error "Output file does not exist"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-buffer-substring artbuf) + (goto-char (point-min)) + (if (looking-at "From ") + (forward-line 1) + (insert "From nobody " (current-time-string) "\n")) + (let (case-fold-search) + (while (re-search-forward "^From " nil t) + (beginning-of-line) + (insert ">"))) + ;; Decide whether to append to a file or to an Emacs buffer. + (let ((outbuf (get-file-buffer filename))) + (if (not outbuf) + (let ((buffer-read-only nil)) + (save-excursion + (goto-char (point-max)) + (forward-char -2) + (unless (looking-at "\n\n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n")) + (goto-char (point-max)) + (append-to-file (point-min) (point-max) filename))) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (unless (eobp) + (insert "\n")) + (insert "\n") + (insert-buffer-substring tmpbuf))))) + (kill-buffer tmpbuf))) + +(defun gnus-convert-article-to-rmail () + "Convert article in current buffer to Rmail message format." + (let ((buffer-read-only nil)) + ;; Convert article directly into Babyl format. + (goto-char (point-min)) + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (while (search-forward "\n\^_" nil t) ;single char + (replace-match "\n^_" t t)) ;2 chars: "^" and "_" + (goto-char (point-max)) + (insert "\^_"))) + +(defun gnus-map-function (funs arg) + "Applies the result of the first function in FUNS to the second, and so on. +ARG is passed to the first function." + (let ((myfuns funs) + (myarg arg)) + (while myfuns + (setq arg (funcall (pop myfuns) arg))) + arg)) + +(provide 'gnus-util) + +;;; gnus-util.el ends here diff --git a/lisp/gnus-uu.el b/lisp/gnus-uu.el new file mode 100644 index 0000000..48c502d --- /dev/null +++ b/lisp/gnus-uu.el @@ -0,0 +1,2040 @@ +;;; gnus-uu.el --- extract (uu)encoded files in Gnus +;; Copyright (C) 1985,86,87,93,94,95,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Created: 2 Oct 1993 +;; Keyword: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-art) +(require 'message) +(require 'gnus-msg) + +(defgroup gnus-extract nil + "Extracting encoded files." + :prefix "gnus-uu-" + :group 'gnus) + +(defgroup gnus-extract-view nil + "Viewwing extracted files." + :group 'gnus-extract) + +(defgroup gnus-extract-archive nil + "Extracting encoded archives." + :group 'gnus-extract) + +(defgroup gnus-extract-post nil + "Extracting encoded archives." + :prefix "gnus-uu-post" + :group 'gnus-extract) + +;; Default viewing action rules + +(defcustom gnus-uu-default-view-rules + '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g") + ("\\.pas$" "cat %s | sed s/\r//g") + ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") + ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv") + ("\\.tga$" "tgatoppm %s | xv -") + ("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$" + "sox -v .5 %s -t .au -u - > /dev/audio") + ("\\.au$" "cat %s > /dev/audio") + ("\\.midi?$" "playmidi -f") + ("\\.mod$" "str32") + ("\\.ps$" "ghostview") + ("\\.dvi$" "xdvi") + ("\\.html$" "xmosaic") + ("\\.mpe?g$" "mpeg_play") + ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") + ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" + "gnus-uu-archive")) + "Default actions to be taken when the user asks to view a file. +To change the behaviour, you can either edit this variable or set +`gnus-uu-user-view-rules' to something useful. + +For example: + +To make gnus-uu use 'xli' to display JPEG and GIF files, put the +following in your .emacs file: + + (setq gnus-uu-user-view-rules '((\"jpg$\\\\|gif$\" \"xli\"))) + +Both these variables are lists of lists with two string elements. The +first string is a regular expression. If the file name matches this +regular expression, the command in the second string is executed with +the file as an argument. + +If the command string contains \"%s\", the file name will be inserted +at that point in the command string. If there's no \"%s\" in the +command string, the file name will be appended to the command string +before executing. + +There are several user variables to tailor the behaviour of gnus-uu to +your needs. First we have `gnus-uu-user-view-rules', which is the +variable gnus-uu first consults when trying to decide how to view a +file. If this variable contains no matches, gnus-uu examines the +default rule variable provided in this package. If gnus-uu finds no +match here, it uses `gnus-uu-user-view-rules-end' to try to make a +match." + :group 'gnus-extract-view + :type '(repeat (group regexp (string :tag "Command")))) + +(defcustom gnus-uu-user-view-rules nil + "What actions are to be taken to view a file. +See the documentation on the `gnus-uu-default-view-rules' variable for +details." + :group 'gnus-extract-view + :type '(repeat (group regexp (string :tag "Command")))) + +(defcustom gnus-uu-user-view-rules-end + '(("" "file")) + "What actions are to be taken if no rule matched the file name. +See the documentation on the `gnus-uu-default-view-rules' variable for +details." + :group 'gnus-extract-view + :type '(repeat (group regexp (string :tag "Command")))) + +;; Default unpacking commands + +(defcustom gnus-uu-default-archive-rules + '(("\\.tar$" "tar xf") + ("\\.zip$" "unzip -o") + ("\\.ar$" "ar x") + ("\\.arj$" "unarj x") + ("\\.zoo$" "zoo -e") + ("\\.\\(lzh\\|lha\\)$" "lha x") + ("\\.Z$" "uncompress") + ("\\.gz$" "gunzip") + ("\\.arc$" "arc -x")) + "See `gnus-uu-user-archive-rules'." + :group 'gnus-extract-archive + :type '(repeat (group regexp (string :tag "Command")))) + +(defvar gnus-uu-destructive-archivers + (list "uncompress" "gunzip")) + +(defcustom gnus-uu-user-archive-rules nil + "A list that can be set to override the default archive unpacking commands. +To use, for instance, 'untar' to unpack tar files and 'zip -x' to +unpack zip files, say the following: + (setq gnus-uu-user-archive-rules + '((\"\\\\.tar$\" \"untar\") + (\"\\\\.zip$\" \"zip -x\")))" + :group 'gnus-extract-archive + :type '(repeat (group regexp (string :tag "Command")))) + +(defcustom gnus-uu-ignore-files-by-name nil + "*A regular expression saying what files should not be viewed based on name. +If, for instance, you want gnus-uu to ignore all .au and .wav files, +you could say something like + + (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\") + +Note that this variable can be used in conjunction with the +`gnus-uu-ignore-files-by-type' variable." + :group 'gnus-extract + :type '(choice (const :tag "off" nil) + (regexp :format "%v"))) + +(defcustom gnus-uu-ignore-files-by-type nil + "*A regular expression saying what files that shouldn't be viewed, based on MIME file type. +If, for instance, you want gnus-uu to ignore all audio files and all mpegs, +you could say something like + + (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\") + +Note that this variable can be used in conjunction with the +`gnus-uu-ignore-files-by-name' variable." + :group 'gnus-extract + :type '(choice (const :tag "off" nil) + (regexp :format "%v"))) + +;; Pseudo-MIME support + +(defconst gnus-uu-ext-to-mime-list + '(("\\.gif$" "image/gif") + ("\\.jpe?g$" "image/jpeg") + ("\\.tiff?$" "image/tiff") + ("\\.xwd$" "image/xwd") + ("\\.pbm$" "image/pbm") + ("\\.pgm$" "image/pgm") + ("\\.ppm$" "image/ppm") + ("\\.xbm$" "image/xbm") + ("\\.pcx$" "image/pcx") + ("\\.tga$" "image/tga") + ("\\.ps$" "image/postscript") + ("\\.fli$" "video/fli") + ("\\.wav$" "audio/wav") + ("\\.aiff$" "audio/aiff") + ("\\.hcom$" "audio/hcom") + ("\\.voc$" "audio/voc") + ("\\.smp$" "audio/smp") + ("\\.mod$" "audio/mod") + ("\\.dvi$" "image/dvi") + ("\\.mpe?g$" "video/mpeg") + ("\\.au$" "audio/basic") + ("\\.\\(te?xt\\|doc\\|c\\|h\\)$" "text/plain") + ("\\.\\(c\\|h\\)$" "text/source") + ("read.*me" "text/plain") + ("\\.html$" "text/html") + ("\\.bat$" "text/bat") + ("\\.[1-6]$" "text/man") + ("\\.flc$" "video/flc") + ("\\.rle$" "video/rle") + ("\\.pfx$" "video/pfx") + ("\\.avi$" "video/avi") + ("\\.sme$" "video/sme") + ("\\.rpza$" "video/prza") + ("\\.dl$" "video/dl") + ("\\.qt$" "video/qt") + ("\\.rsrc$" "video/rsrc") + ("\\..*$" "unknown/unknown"))) + +;; Various variables users may set + +(defcustom gnus-uu-tmp-dir "/tmp/" + "*Variable saying where gnus-uu is to do its work. +Default is \"/tmp/\"." + :group 'gnus-extract + :type 'directory) + +(defcustom gnus-uu-do-not-unpack-archives nil + "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. +Default is nil." + :group 'gnus-extract-archive + :type 'boolean) + +(defcustom gnus-uu-ignore-default-view-rules nil + "*Non-nil means that gnus-uu will ignore the default viewing rules. +Only the user viewing rules will be consulted. Default is nil." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-uu-grabbed-file-functions nil + "Functions run on each file after successful decoding. +They will be called with the name of the file as the argument. +Likely functions you can use in this list are `gnus-uu-grab-view' +and `gnus-uu-grab-move'." + :group 'gnus-extract + :options '(gnus-uu-grab-view gnus-uu-grab-move) + :type 'hook) + +(defcustom gnus-uu-ignore-default-archive-rules nil + "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. +Only the user unpacking commands will be consulted. Default is nil." + :group 'gnus-extract-archive + :type 'boolean) + +(defcustom gnus-uu-kill-carriage-return t + "*Non-nil means that gnus-uu will strip all carriage returns from articles. +Default is t." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-view-with-metamail nil + "*Non-nil means that files will be viewed with metamail. +The gnus-uu viewing functions will be ignored and gnus-uu will try +to guess at a content-type based on file name suffixes. Default +it nil." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-unmark-articles-not-decoded nil + "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. +Default is nil." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-correct-stripped-uucode nil + "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. +Default is nil." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-save-in-digest nil + "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. +If this variable is nil, gnus-uu will just save everything in a +file without any embellishments. The digesting almost conforms to RFC1153 - +no easy way to specify any meaningful volume and issue numbers were found, +so I simply dropped them." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-digest-headers + '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" + "^Summary:" "^References:") + "List of regexps to match headers included in digested messages. +The headers will be included in the sequence they are matched." + :group 'gnus-extract + :type '(repeat regexp)) + +(defcustom gnus-uu-save-separate-articles nil + "*Non-nil means that gnus-uu will save articles in separate files." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-be-dangerous 'ask + "*Specifies what to do if unusual situations arise during decoding. +If nil, be as conservative as possible. If t, ignore things that +didn't work, and overwrite existing files. Otherwise, ask each time." + :group 'gnus-extract + :type '(choice (const :tag "conservative" nil) + (const :tag "ask" ask) + (const :tag "liberal" t))) + +;; Internal variables + +(defvar gnus-uu-saved-article-name nil) + +(defconst gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") +(defconst gnus-uu-end-string "^end[ \t]*$") + +(defconst gnus-uu-body-line "^M") +(let ((i 61)) + (while (> (setq i (1- i)) 0) + (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]"))) + (setq gnus-uu-body-line (concat gnus-uu-body-line ".?$"))) + +;"^M.............................................................?$" + +(defconst gnus-uu-shar-begin-string "^#! */bin/sh") + +(defvar gnus-uu-shar-file-name nil) +(defconst gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") + +(defconst gnus-uu-postscript-begin-string "^%!PS-") +(defconst gnus-uu-postscript-end-string "^%%EOF$") + +(defvar gnus-uu-file-name nil) +(defconst gnus-uu-uudecode-process nil) +(defvar gnus-uu-binhex-article-name nil) + +(defvar gnus-uu-work-dir nil) + +(defconst gnus-uu-output-buffer-name " *Gnus UU Output*") + +(defvar gnus-uu-default-dir gnus-article-save-directory) +(defvar gnus-uu-digest-from-subject nil) + +;; Keymaps + +(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) + "p" gnus-summary-mark-as-processable + "u" gnus-summary-unmark-as-processable + "U" gnus-summary-unmark-all-processable + "v" gnus-uu-mark-over + "s" gnus-uu-mark-series + "r" gnus-uu-mark-region + "R" gnus-uu-mark-by-regexp + "t" gnus-uu-mark-thread + "T" gnus-uu-unmark-thread + "a" gnus-uu-mark-all + "b" gnus-uu-mark-buffer + "S" gnus-uu-mark-sparse + "k" gnus-summary-kill-process-mark + "y" gnus-summary-yank-process-mark + "w" gnus-summary-save-process-mark + "i" gnus-uu-invert-processable) + +(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) + ;;"x" gnus-uu-extract-any + ;;"m" gnus-uu-extract-mime + "u" gnus-uu-decode-uu + "U" gnus-uu-decode-uu-and-save + "s" gnus-uu-decode-unshar + "S" gnus-uu-decode-unshar-and-save + "o" gnus-uu-decode-save + "O" gnus-uu-decode-save + "b" gnus-uu-decode-binhex + "B" gnus-uu-decode-binhex + "p" gnus-uu-decode-postscript + "P" gnus-uu-decode-postscript-and-save) + +(gnus-define-keys + (gnus-uu-extract-view-map "v" gnus-uu-extract-map) + "u" gnus-uu-decode-uu-view + "U" gnus-uu-decode-uu-and-save-view + "s" gnus-uu-decode-unshar-view + "S" gnus-uu-decode-unshar-and-save-view + "o" gnus-uu-decode-save-view + "O" gnus-uu-decode-save-view + "b" gnus-uu-decode-binhex-view + "B" gnus-uu-decode-binhex-view + "p" gnus-uu-decode-postscript-view + "P" gnus-uu-decode-postscript-and-save-view) + + +;; Commands. + +(defun gnus-uu-decode-uu (&optional n) + "Uudecodes the current article." + (interactive "P") + (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n)) + +(defun gnus-uu-decode-uu-and-save (n dir) + "Decodes and saves the resulting file." + (interactive + (list current-prefix-arg + (file-name-as-directory + (read-file-name "Uudecode and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t)))) + (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir nil nil t)) + +(defun gnus-uu-decode-unshar (&optional n) + "Unshars the current article." + (interactive "P") + (gnus-uu-decode-with-method 'gnus-uu-unshar-article n nil nil 'scan t)) + +(defun gnus-uu-decode-unshar-and-save (n dir) + "Unshars and saves the current article." + (interactive + (list current-prefix-arg + (file-name-as-directory + (read-file-name "Unshar and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t)))) + (gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir nil 'scan t)) + +(defun gnus-uu-decode-save (n file) + "Saves the current article." + (interactive + (list current-prefix-arg + (read-file-name + (if gnus-uu-save-separate-articles + "Save articles is dir: " + "Save articles in file: ") + gnus-uu-default-dir + gnus-uu-default-dir))) + (setq gnus-uu-saved-article-name file) + (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t)) + +(defun gnus-uu-decode-binhex (n dir) + "Unbinhexes the current article." + (interactive + (list current-prefix-arg + (file-name-as-directory + (read-file-name "Unbinhex and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir)))) + (setq gnus-uu-binhex-article-name + (make-temp-name (concat gnus-uu-work-dir "binhex"))) + (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir)) + +(defun gnus-uu-decode-uu-view (&optional n) + "Uudecodes and views the current article." + (interactive "P") + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-uu n))) + +(defun gnus-uu-decode-uu-and-save-view (n dir) + "Decodes, views and saves the resulting file." + (interactive + (list current-prefix-arg + (read-file-name "Uudecode, view and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t))) + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-uu-and-save n dir))) + +(defun gnus-uu-decode-unshar-view (&optional n) + "Unshars and views the current article." + (interactive "P") + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-unshar n))) + +(defun gnus-uu-decode-unshar-and-save-view (n dir) + "Unshars and saves the current article." + (interactive + (list current-prefix-arg + (read-file-name "Unshar, view and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t))) + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-unshar-and-save n dir))) + +(defun gnus-uu-decode-save-view (n file) + "Saves and views the current article." + (interactive + (list current-prefix-arg + (read-file-name (if gnus-uu-save-separate-articles + "Save articles is dir: " + "Save articles in file: ") + gnus-uu-default-dir gnus-uu-default-dir))) + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-save n file))) + +(defun gnus-uu-decode-binhex-view (n file) + "Unbinhexes and views the current article." + (interactive + (list current-prefix-arg + (read-file-name "Unbinhex, view and save in dir: " + gnus-uu-default-dir gnus-uu-default-dir))) + (setq gnus-uu-binhex-article-name + (make-temp-name (concat gnus-uu-work-dir "binhex"))) + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-binhex n file))) + + +;; Digest and forward articles + +(defun gnus-uu-digest-mail-forward (&optional n post) + "Digests and forwards all articles in this series." + (interactive "P") + (let ((gnus-uu-save-in-digest t) + (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) + buf subject from newsgroups) + (gnus-setup-message 'forward + (setq gnus-uu-digest-from-subject nil) + (gnus-uu-decode-save n file) + (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) + (gnus-add-current-to-buffer-list) + (erase-buffer) + (insert-file file) + (let ((fs gnus-uu-digest-from-subject)) + (when fs + (setq from (caar fs) + subject (gnus-simplify-subject-fuzzy (cdar fs)) + fs (cdr fs)) + (while (and fs (or from subject)) + (when from + (unless (string= from (caar fs)) + (setq from nil))) + (when subject + (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) + (setq fs (cdr fs)))) + (unless subject + (setq subject "Digested Articles")) + (unless from + (setq from + (if (gnus-news-group-p gnus-newsgroup-name) + gnus-newsgroup-name + "Various")))) + (goto-char (point-min)) + (when (re-search-forward "^Subject: ") + (delete-region (point) (gnus-point-at-eol)) + (insert subject)) + (goto-char (point-min)) + (when (re-search-forward "^From: ") + (delete-region (point) (gnus-point-at-eol)) + (insert from)) + (message-forward post)) + (delete-file file) + (kill-buffer buf) + (setq gnus-uu-digest-from-subject nil))) + +(defun gnus-uu-digest-post-forward (&optional n) + "Digest and forward to a newsgroup." + (interactive "P") + (gnus-uu-digest-mail-forward n t)) + +;; Process marking. + +(defun gnus-uu-mark-by-regexp (regexp &optional unmark) + "Ask for a regular expression and set the process mark on all articles that match." + (interactive (list (read-from-minibuffer "Mark (regexp): "))) + (gnus-set-global-variables) + (let ((articles (gnus-uu-find-articles-matching regexp))) + (while articles + (if unmark + (gnus-summary-remove-process-mark (pop articles)) + (gnus-summary-set-process-mark (pop articles)))) + (message "")) + (gnus-summary-position-point)) + +(defun gnus-uu-unmark-by-regexp (regexp &optional unmark) + "Ask for a regular expression and remove the process mark on all articles that match." + (interactive (list (read-from-minibuffer "Mark (regexp): "))) + (gnus-uu-mark-by-regexp regexp t)) + +(defun gnus-uu-mark-series () + "Mark the current series with the process mark." + (interactive) + (gnus-set-global-variables) + (let ((articles (gnus-uu-find-articles-matching))) + (while articles + (gnus-summary-set-process-mark (car articles)) + (setq articles (cdr articles))) + (message "")) + (gnus-summary-position-point)) + +(defun gnus-uu-mark-region (beg end &optional unmark) + "Set the process mark on all articles between point and mark." + (interactive "r") + (gnus-set-global-variables) + (save-excursion + (goto-char beg) + (while (< (point) end) + (if unmark + (gnus-summary-remove-process-mark (gnus-summary-article-number)) + (gnus-summary-set-process-mark (gnus-summary-article-number))) + (forward-line 1))) + (gnus-summary-position-point)) + +(defun gnus-uu-unmark-region (beg end) + "Remove the process mark from all articles between point and mark." + (interactive "r") + (gnus-uu-mark-region beg end t)) + +(defun gnus-uu-mark-buffer () + "Set the process mark on all articles in the buffer." + (interactive) + (gnus-uu-mark-region (point-min) (point-max))) + +(defun gnus-uu-unmark-buffer () + "Remove the process mark on all articles in the buffer." + (interactive) + (gnus-uu-mark-region (point-min) (point-max) t)) + +(defun gnus-uu-mark-thread () + "Marks all articles downwards in this thread." + (interactive) + (gnus-set-global-variables) + (let ((level (gnus-summary-thread-level))) + (while (and (gnus-summary-set-process-mark (gnus-summary-article-number)) + (zerop (gnus-summary-next-subject 1)) + (> (gnus-summary-thread-level) level)))) + (gnus-summary-position-point)) + +(defun gnus-uu-unmark-thread () + "Unmarks all articles downwards in this thread." + (interactive) + (gnus-set-global-variables) + (let ((level (gnus-summary-thread-level))) + (while (and (gnus-summary-remove-process-mark + (gnus-summary-article-number)) + (zerop (gnus-summary-next-subject 1)) + (> (gnus-summary-thread-level) level)))) + (gnus-summary-position-point)) + +(defun gnus-uu-invert-processable () + "Invert the list of process-marked articles." + (let ((data gnus-newsgroup-data) + d number) + (save-excursion + (while data + (if (memq (setq number (gnus-data-number (pop data))) + gnus-newsgroup-processable) + (gnus-summary-remove-process-mark number) + (gnus-summary-set-process-mark number))))) + (gnus-summary-position-point)) + +(defun gnus-uu-mark-over (&optional score) + "Mark all articles with a score over SCORE (the prefix.)" + (interactive "P") + (let ((score (gnus-score-default score)) + (data gnus-newsgroup-data)) + (save-excursion + (while data + (when (> (or (cdr (assq (gnus-data-number (car data)) + gnus-newsgroup-scored)) + gnus-summary-default-score 0) + score) + (gnus-summary-set-process-mark (caar data))) + (setq data (cdr data)))) + (gnus-summary-position-point))) + +(defun gnus-uu-mark-sparse () + "Mark all series that have some articles marked." + (interactive) + (gnus-set-global-variables) + (let ((marked (nreverse gnus-newsgroup-processable)) + subject articles total headers) + (unless marked + (error "No articles marked with the process mark")) + (setq gnus-newsgroup-processable nil) + (save-excursion + (while marked + (and (vectorp (setq headers + (gnus-summary-article-header (car marked)))) + (setq subject (mail-header-subject headers) + articles (gnus-uu-find-articles-matching + (gnus-uu-reginize-string subject)) + total (nconc total articles))) + (while articles + (gnus-summary-set-process-mark (car articles)) + (setcdr marked (delq (car articles) (cdr marked))) + (setq articles (cdr articles))) + (setq marked (cdr marked))) + (setq gnus-newsgroup-processable (nreverse total))) + (gnus-summary-position-point))) + +(defun gnus-uu-mark-all () + "Mark all articles in \"series\" order." + (interactive) + (gnus-set-global-variables) + (setq gnus-newsgroup-processable nil) + (save-excursion + (let ((data gnus-newsgroup-data) + number) + (while data + (when (and (not (memq (setq number (gnus-data-number (car data))) + gnus-newsgroup-processable)) + (vectorp (gnus-data-header (car data)))) + (gnus-summary-goto-subject number) + (gnus-uu-mark-series)) + (setq data (cdr data))))) + (gnus-summary-position-point)) + +;; All PostScript functions written by Erik Selberg . + +(defun gnus-uu-decode-postscript (&optional n) + "Gets postscript of the current article." + (interactive "P") + (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n)) + +(defun gnus-uu-decode-postscript-view (&optional n) + "Gets and views the current article." + (interactive "P") + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-postscript n))) + +(defun gnus-uu-decode-postscript-and-save (n dir) + "Extracts postscript and saves the current article." + (interactive + (list current-prefix-arg + (file-name-as-directory + (read-file-name "Save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t)))) + (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article + n dir nil nil t)) + +(defun gnus-uu-decode-postscript-and-save-view (n dir) + "Decodes, views and saves the resulting file." + (interactive + (list current-prefix-arg + (read-file-name "Where do you want to save the file(s)? " + gnus-uu-default-dir + gnus-uu-default-dir t))) + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) + (gnus-uu-decode-postscript-and-save n dir))) + + +;; Internal functions. + +(defun gnus-uu-decode-with-method (method n &optional save not-insert + scan cdir) + (gnus-uu-initialize scan) + (when save + (setq gnus-uu-default-dir save)) + ;; Create the directory we save to. + (when (and scan cdir save + (not (file-exists-p save))) + (make-directory save t)) + (let ((articles (gnus-uu-get-list-of-articles n)) + files) + (setq files (gnus-uu-grab-articles articles method t)) + (let ((gnus-current-article (car articles))) + (when scan + (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) + (when save + (gnus-uu-save-files files save)) + (when (eq gnus-uu-do-not-unpack-archives nil) + (setq files (gnus-uu-unpack-files files))) + (setq files (nreverse (gnus-uu-get-actions files))) + (or not-insert (not gnus-insert-pseudo-articles) + (gnus-summary-insert-pseudos files save)))) + +(defun gnus-uu-scan-directory (dir &optional rec) + "Return a list of all files under DIR." + (let ((files (directory-files dir t)) + out file) + (while (setq file (pop files)) + (unless (member (file-name-nondirectory file) '("." "..")) + (push (list (cons 'name file) + (cons 'article gnus-current-article)) + out) + (when (file-directory-p file) + (setq out (nconc (gnus-uu-scan-directory file t) out))))) + (if rec + out + (nreverse out)))) + +(defun gnus-uu-save-files (files dir) + "Save FILES in DIR." + (let ((len (length files)) + (reg (concat "^" (regexp-quote gnus-uu-work-dir))) + to-file file fromdir) + (while (setq file (cdr (assq 'name (pop files)))) + (when (file-exists-p file) + (string-match reg file) + (setq fromdir (substring file (match-end 0))) + (if (file-directory-p file) + (gnus-make-directory (concat dir fromdir)) + (setq to-file (concat dir fromdir)) + (when (or (not (file-exists-p to-file)) + (eq gnus-uu-be-dangerous t) + (and gnus-uu-be-dangerous + (gnus-y-or-n-p (format "%s exists; overwrite? " + to-file)))) + (copy-file file to-file t t))))) + (gnus-message 5 "Saved %d file%s" len (if (= len 1) "" "s")))) + +;; Functions for saving and possibly digesting articles without +;; any decoding. + +;; Function called by gnus-uu-grab-articles to treat each article. +(defun gnus-uu-save-article (buffer in-state) + (cond + (gnus-uu-save-separate-articles + (save-excursion + (set-buffer buffer) + (gnus-write-buffer + (concat gnus-uu-saved-article-name gnus-current-article)) + (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) + ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name + 'begin 'end)) + ((eq in-state 'last) (list 'end)) + (t (list 'middle))))) + ((not gnus-uu-save-in-digest) + (save-excursion + (set-buffer buffer) + (write-region (point-min) (point-max) gnus-uu-saved-article-name t) + (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) + ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name + 'begin 'end)) + ((eq in-state 'last) (list 'end)) + (t (list 'middle))))) + (t + (let ((header (gnus-summary-article-header))) + (push (cons (mail-header-from header) + (mail-header-subject header)) + gnus-uu-digest-from-subject)) + (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) + (delim (concat "^" (make-string 30 ?-) "$")) + beg subj headers headline sorthead body end-string state) + (if (or (eq in-state 'first) + (eq in-state 'first-and-last)) + (progn + (setq state (list 'begin)) + (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) + (erase-buffer)) + (save-excursion + (set-buffer (get-buffer-create "*gnus-uu-pre*")) + (erase-buffer) + (insert (format + "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" + (current-time-string) name name)))) + (when (not (eq in-state 'end)) + (setq state (list 'middle)))) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-body*")) + (goto-char (setq beg (point-max))) + (save-excursion + (save-restriction + (set-buffer buffer) + (let (buffer-read-only) + (gnus-set-text-properties (point-min) (point-max) nil) + ;; These two are necessary for XEmacs 19.12 fascism. + (put-text-property (point-min) (point-max) 'invisible nil) + (put-text-property (point-min) (point-max) 'intangible nil)) + (goto-char (point-min)) + (re-search-forward "\n\n") + ;; Quote all 30-dash lines. + (save-excursion + (while (re-search-forward delim nil t) + (beginning-of-line) + (delete-char 1) + (insert " "))) + (setq body (buffer-substring (1- (point)) (point-max))) + (narrow-to-region (point-min) (point)) + (if (not (setq headers gnus-uu-digest-headers)) + (setq sorthead (buffer-substring (point-min) (point-max))) + (while headers + (setq headline (car headers)) + (setq headers (cdr headers)) + (goto-char (point-min)) + (while (re-search-forward headline nil t) + (setq sorthead + (concat sorthead + (buffer-substring + (match-beginning 0) + (or (and (re-search-forward "^[^ \t]" nil t) + (1- (point))) + (progn (forward-line 1) (point))))))))) + (widen))) + (insert sorthead) (goto-char (point-max)) + (insert body) (goto-char (point-max)) + (insert (concat "\n" (make-string 30 ?-) "\n\n")) + (goto-char beg) + (when (re-search-forward "^Subject: \\(.*\\)$" nil t) + (setq subj (buffer-substring (match-beginning 1) (match-end 1))) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-pre*")) + (insert (format " %s\n" subj))))) + (when (or (eq in-state 'last) + (eq in-state 'first-and-last)) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-pre*")) + (insert (format "\n\n%s\n\n" (make-string 70 ?-))) + (gnus-write-buffer gnus-uu-saved-article-name)) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-body*")) + (goto-char (point-max)) + (insert + (concat (setq end-string (format "End of %s Digest" name)) + "\n")) + (insert (concat (make-string (length end-string) ?*) "\n")) + (write-region + (point-min) (point-max) gnus-uu-saved-article-name t)) + (kill-buffer (get-buffer "*gnus-uu-pre*")) + (kill-buffer (get-buffer "*gnus-uu-body*")) + (push 'end state)) + (if (memq 'begin state) + (cons gnus-uu-saved-article-name state) + state))))) + +;; Binhex treatment - not very advanced. + +(defconst gnus-uu-binhex-body-line + "^[^:]...............................................................$") +(defconst gnus-uu-binhex-begin-line + "^:...............................................................$") +(defconst gnus-uu-binhex-end-line + ":$") + +(defun gnus-uu-binhex-article (buffer in-state) + (let (state start-char) + (save-excursion + (set-buffer buffer) + (widen) + (goto-char (point-min)) + (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) + (when (not (re-search-forward gnus-uu-binhex-body-line nil t)) + (setq state (list 'wrong-type)))) + + (if (memq 'wrong-type state) + () + (beginning-of-line) + (setq start-char (point)) + (if (looking-at gnus-uu-binhex-begin-line) + (progn + (setq state (list 'begin)) + (write-region 1 1 gnus-uu-binhex-article-name)) + (setq state (list 'middle))) + (goto-char (point-max)) + (re-search-backward (concat gnus-uu-binhex-body-line "\\|" + gnus-uu-binhex-end-line) + nil t) + (when (looking-at gnus-uu-binhex-end-line) + (setq state (if (memq 'begin state) + (cons 'end state) + (list 'end)))) + (beginning-of-line) + (forward-line 1) + (when (file-exists-p gnus-uu-binhex-article-name) + (append-to-file start-char (point) gnus-uu-binhex-article-name)))) + (if (memq 'begin state) + (cons gnus-uu-binhex-article-name state) + state))) + +;; PostScript + +(defun gnus-uu-decode-postscript-article (process-buffer in-state) + (let ((state (list 'ok)) + start-char end-char file-name) + (save-excursion + (set-buffer process-buffer) + (goto-char (point-min)) + (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) + (setq state (list 'wrong-type)) + (beginning-of-line) + (setq start-char (point)) + (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) + (setq state (list 'wrong-type)) + (setq end-char (point)) + (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (insert-buffer-substring process-buffer start-char end-char) + (setq file-name (concat gnus-uu-work-dir + (cdr gnus-article-current) ".ps")) + (write-region (point-min) (point-max) file-name) + (setq state (list file-name 'begin 'end))))) + state)) + + +;; Find actions. + +(defun gnus-uu-get-actions (files) + (let ((ofiles files) + action name) + (while files + (setq name (cdr (assq 'name (car files)))) + (and + (setq action (gnus-uu-get-action name)) + (setcar files (nconc (list (if (string= action "gnus-uu-archive") + (cons 'action "file") + (cons 'action action)) + (cons 'execute (gnus-uu-command + action name))) + (car files)))) + (setq files (cdr files))) + ofiles)) + +(defun gnus-uu-get-action (file-name) + (let (action) + (setq action + (gnus-uu-choose-action + file-name + (append + gnus-uu-user-view-rules + (if gnus-uu-ignore-default-view-rules + nil + gnus-uu-default-view-rules) + gnus-uu-user-view-rules-end))) + (when (and (not (string= (or action "") "gnus-uu-archive")) + gnus-uu-view-with-metamail) + (when (setq action + (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)) + (setq action (format "metamail -d -b -c \"%s\"" action)))) + action)) + + +;; Functions for treating subjects and collecting series. + +(defun gnus-uu-reginize-string (string) + ;; Takes a string and puts a \ in front of every special character; + ;; ignores any leading "version numbers" thingies that they use in + ;; the comp.binaries groups, and either replaces anything that looks + ;; like "2/3" with "[0-9]+/[0-9]+" or, if it can't find something + ;; like that, replaces the last two numbers with "[0-9]+". This, in + ;; my experience, should get most postings of a series. + (let ((count 2) + (vernum "v[0-9]+[a-z][0-9]+:") + beg) + (save-excursion + (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert (regexp-quote string)) + (setq beg 1) + + (setq case-fold-search nil) + (goto-char (point-min)) + (when (looking-at vernum) + (replace-match vernum t t) + (setq beg (length vernum))) + + (goto-char beg) + (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t) + (replace-match " [0-9]+/[0-9]+") + + (goto-char beg) + (if (re-search-forward "[0-9]+[ \t]*of[ \t]*[0-9]+" nil t) + (replace-match "[0-9]+ of [0-9]+") + + (end-of-line) + (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" + nil t) + (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) + + (goto-char beg) + (while (re-search-forward "[ \t]+" nil t) + (replace-match "[ \t]*" t t)) + + (buffer-substring 1 (point-max))))) + +(defun gnus-uu-get-list-of-articles (n) + ;; If N is non-nil, the article numbers of the N next articles + ;; will be returned. + ;; If any articles have been marked as processable, they will be + ;; returned. + ;; Failing that, articles that have subjects that are part of the + ;; same "series" as the current will be returned. + (let (articles) + (cond + (n + (setq n (prefix-numeric-value n)) + (let ((backward (< n 0)) + (n (abs n))) + (save-excursion + (while (and (> n 0) + (push (gnus-summary-article-number) + articles) + (gnus-summary-search-forward nil nil backward)) + (setq n (1- n)))) + (nreverse articles))) + (gnus-newsgroup-processable + (reverse gnus-newsgroup-processable)) + (t + (gnus-uu-find-articles-matching))))) + +(defun gnus-uu-string< (l1 l2) + (string< (car l1) (car l2))) + +(defun gnus-uu-find-articles-matching + (&optional subject only-unread do-not-translate) + ;; Finds all articles that matches the regexp SUBJECT. If it is + ;; nil, the current article name will be used. If ONLY-UNREAD is + ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is + ;; non-nil, article names are not equalized before sorting. + (let ((subject (or subject + (gnus-uu-reginize-string (gnus-summary-article-subject)))) + list-of-subjects) + (save-excursion + (if (not subject) + () + ;; Collect all subjects matching subject. + (let ((case-fold-search t) + (data gnus-newsgroup-data) + subj mark d) + (while data + (setq d (pop data)) + (and (not (gnus-data-pseudo-p d)) + (or (not only-unread) + (= (setq mark (gnus-data-mark d)) + gnus-unread-mark) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark)) + (setq subj (mail-header-subject (gnus-data-header d))) + (string-match subject subj) + (push (cons subj (gnus-data-number d)) + list-of-subjects)))) + + ;; Expand numbers, sort, and return the list of article + ;; numbers. + (mapcar (lambda (sub) (cdr sub)) + (sort (gnus-uu-expand-numbers + list-of-subjects + (not do-not-translate)) + 'gnus-uu-string<)))))) + +(defun gnus-uu-expand-numbers (string-list &optional translate) + ;; Takes a list of strings and "expands" all numbers in all the + ;; strings. That is, this function makes all numbers equal length by + ;; prepending lots of zeroes before each number. This is to ease later + ;; sorting to find out what sequence the articles are supposed to be + ;; decoded in. Returns the list of expanded strings. + (let ((out-list string-list) + string) + (save-excursion + (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (buffer-disable-undo (current-buffer)) + (while string-list + (erase-buffer) + (insert (caar string-list)) + ;; Translate multiple spaces to one space. + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " ")) + ;; Translate all characters to "a". + (goto-char (point-min)) + (when translate + (while (re-search-forward "[A-Za-z]" nil t) + (replace-match "a" t t))) + ;; Expand numbers. + (goto-char (point-min)) + (while (re-search-forward "[0-9]+" nil t) + (replace-match + (format "%06d" + (string-to-int (buffer-substring + (match-beginning 0) (match-end 0)))))) + (setq string (buffer-substring 1 (point-max))) + (setcar (car string-list) string) + (setq string-list (cdr string-list)))) + out-list)) + + +;; `gnus-uu-grab-articles' is the general multi-article treatment +;; function. It takes a list of articles to be grabbed and a function +;; to apply to each article. +;; +;; The function to be called should take two parameters. The first +;; parameter is the article buffer. The function should leave the +;; result, if any, in this buffer. Most treatment functions will just +;; generate files... +;; +;; The second parameter is the state of the list of articles, and can +;; have four values: `first', `middle', `last' and `first-and-last'. +;; +;; The function should return a list. The list may contain the +;; following symbols: +;; `error' if an error occurred +;; `begin' if the beginning of an encoded file has been received +;; If the list returned contains a `begin', the first element of +;; the list *must* be a string with the file name of the decoded +;; file. +;; `end' if the end of an encoded file has been received +;; `middle' if the article was a body part of an encoded file +;; `wrong-type' if the article was not a part of an encoded file +;; `ok', which can be used everything is ok + +(defvar gnus-uu-has-been-grabbed nil) + +(defun gnus-uu-unmark-list-of-grabbed (&optional dont-unmark-last-article) + (let (art) + (if (not (and gnus-uu-has-been-grabbed + gnus-uu-unmark-articles-not-decoded)) + () + (when dont-unmark-last-article + (setq art (car gnus-uu-has-been-grabbed)) + (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) + (while gnus-uu-has-been-grabbed + (gnus-summary-tick-article (car gnus-uu-has-been-grabbed) t) + (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) + (when dont-unmark-last-article + (setq gnus-uu-has-been-grabbed (list art)))))) + +;; This function takes a list of articles and a function to apply to +;; each article grabbed. +;; +;; This function returns a list of files decoded if the grabbing and +;; the process-function has been successful and nil otherwise. +(defun gnus-uu-grab-articles (articles process-function + &optional sloppy limit no-errors) + (let ((state 'first) + has-been-begin article result-file result-files process-state + gnus-summary-display-article-function + gnus-article-display-hook gnus-article-prepare-hook + article-series files) + + (while (and articles + (not (memq 'error process-state)) + (or sloppy + (not (memq 'end process-state)))) + + (setq article (pop articles)) + (push article article-series) + + (unless articles + (if (eq state 'first) + (setq state 'first-and-last) + (setq state 'last))) + + (let ((part (gnus-uu-part-number article))) + (gnus-message 6 "Getting article %d%s..." + article (if (string= part "") "" (concat ", " part)))) + (gnus-summary-display-article article) + + ;; Push the article to the processing function. + (save-excursion + (set-buffer gnus-original-article-buffer) + (let ((buffer-read-only nil)) + (save-excursion + (set-buffer gnus-summary-buffer) + (setq process-state + (funcall process-function + gnus-original-article-buffer state))))) + + (gnus-summary-remove-process-mark article) + + ;; If this is the beginning of a decoded file, we push it + ;; on to a list. + (when (or (memq 'begin process-state) + (and (or (eq state 'first) + (eq state 'first-and-last)) + (memq 'ok process-state))) + (when has-been-begin + ;; If there is a `result-file' here, that means that the + ;; file was unsuccessfully decoded, so we delete it. + (when (and result-file + (file-exists-p result-file) + (not gnus-uu-be-dangerous) + (or (eq gnus-uu-be-dangerous t) + (gnus-y-or-n-p + (format "Delete unsuccessfully decoded file %s" + result-file)))) + (delete-file result-file))) + (when (memq 'begin process-state) + (setq result-file (car process-state))) + (setq has-been-begin t)) + + ;; Check whether we have decoded one complete file. + (when (memq 'end process-state) + (setq article-series nil) + (setq has-been-begin nil) + (if (stringp result-file) + (setq files (list result-file)) + (setq files result-file)) + (setq result-file (car files)) + (while files + (push (list (cons 'name (pop files)) + (cons 'article article)) + result-files)) + ;; Allow user-defined functions to be run on this file. + (when gnus-uu-grabbed-file-functions + (let ((funcs gnus-uu-grabbed-file-functions)) + (unless (listp funcs) + (setq funcs (list funcs))) + (while funcs + (funcall (pop funcs) result-file)))) + (setq result-file nil) + ;; Check whether we have decoded enough articles. + (and limit (= (length result-files) limit) + (setq articles nil))) + + ;; If this is the last article to be decoded, and + ;; we still haven't reached the end, then we delete + ;; the partially decoded file. + (and (or (eq state 'last) (eq state 'first-and-last)) + (not (memq 'end process-state)) + result-file + (file-exists-p result-file) + (not gnus-uu-be-dangerous) + (or (eq gnus-uu-be-dangerous t) + (gnus-y-or-n-p (format "Delete incomplete file %s? " result-file))) + (delete-file result-file)) + + ;; If this was a file of the wrong sort, then + (when (and (or (memq 'wrong-type process-state) + (memq 'error process-state)) + gnus-uu-unmark-articles-not-decoded) + (gnus-summary-tick-article article t)) + + ;; Set the new series state. + (if (and (not has-been-begin) + (not sloppy) + (or (memq 'end process-state) + (memq 'middle process-state))) + (progn + (setq process-state (list 'error)) + (gnus-message 2 "No begin part at the beginning") + (sleep-for 2)) + (setq state 'middle))) + + ;; When there are no result-files, then something must be wrong. + (if result-files + (message "") + (cond + ((not has-been-begin) + (gnus-message 2 "Wrong type file")) + ((memq 'error process-state) + (gnus-message 2 "An error occurred during decoding")) + ((not (or (memq 'ok process-state) + (memq 'end process-state))) + (gnus-message 2 "End of articles reached before end of file"))) + ;; Make unsuccessfully decoded articles unread. + (when gnus-uu-unmark-articles-not-decoded + (while article-series + (gnus-summary-tick-article (pop article-series) t)))) + + result-files)) + +(defun gnus-uu-grab-view (file) + "View FILE using the gnus-uu methods." + (let ((action (gnus-uu-get-action file))) + (gnus-execute-command + (if (string-match "%" action) + (format action file) + (concat action " " file)) + (eq gnus-view-pseudos 'not-confirm)))) + +(defun gnus-uu-grab-move (file) + "Move FILE to somewhere." + (when gnus-uu-default-dir + (let ((to-file (concat (file-name-as-directory gnus-uu-default-dir) + (file-name-nondirectory file)))) + (rename-file file to-file) + (unless (file-exists-p file) + (make-symbolic-link to-file file))))) + +(defun gnus-uu-part-number (article) + (let* ((header (gnus-summary-article-header article)) + (subject (and header (mail-header-subject header)))) + (if (and subject + (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+" subject)) + (match-string 0 subject) + ""))) + +(defun gnus-uu-uudecode-sentinel (process event) + (delete-process (get-process process))) + +(defun gnus-uu-uustrip-article (process-buffer in-state) + ;; Uudecodes a file asynchronously. + (save-excursion + (set-buffer process-buffer) + (let ((state (list 'wrong-type)) + process-connection-type case-fold-search buffer-read-only + files start-char) + (goto-char (point-min)) + + ;; Deal with ^M at the end of the lines. + (when gnus-uu-kill-carriage-return + (save-excursion + (while (search-forward "\r" nil t) + (delete-backward-char 1)))) + + (while (or (re-search-forward gnus-uu-begin-string nil t) + (re-search-forward gnus-uu-body-line nil t)) + (setq state (list 'ok)) + ;; Ok, we are at the first uucoded line. + (beginning-of-line) + (setq start-char (point)) + + (if (not (looking-at gnus-uu-begin-string)) + (setq state (list 'middle)) + ;; This is the beginning of a uuencoded article. + ;; We replace certain characters that could make things messy. + (setq gnus-uu-file-name + (let ((nnheader-file-name-translation-alist + '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) + (nnheader-translate-file-chars (match-string 1)))) + (replace-match (concat "begin 644 " gnus-uu-file-name) t t) + + ;; Remove any non gnus-uu-body-line right after start. + (forward-line 1) + (while (and (not (eobp)) + (not (looking-at gnus-uu-body-line))) + (gnus-delete-line)) + + ;; If a process is running, we kill it. + (when (and gnus-uu-uudecode-process + (memq (process-status gnus-uu-uudecode-process) + '(run stop))) + (delete-process gnus-uu-uudecode-process) + (gnus-uu-unmark-list-of-grabbed t)) + + ;; Start a new uudecoding process. + (let ((cdir default-directory)) + (unwind-protect + (progn + (cd gnus-uu-work-dir) + (setq gnus-uu-uudecode-process + (start-process + "*uudecode*" + (get-buffer-create gnus-uu-output-buffer-name) + shell-file-name shell-command-switch + (format "cd %s %s uudecode" gnus-uu-work-dir + gnus-shell-command-separator)))) + (cd cdir))) + (set-process-sentinel + gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel) + (setq state (list 'begin)) + (push (concat gnus-uu-work-dir gnus-uu-file-name) files)) + + ;; We look for the end of the thing to be decoded. + (if (re-search-forward gnus-uu-end-string nil t) + (push 'end state) + (goto-char (point-max)) + (re-search-backward gnus-uu-body-line nil t)) + + (forward-line 1) + + (when gnus-uu-uudecode-process + (when (memq (process-status gnus-uu-uudecode-process) '(run stop)) + ;; Try to correct mishandled uucode. + (when gnus-uu-correct-stripped-uucode + (gnus-uu-check-correct-stripped-uucode start-char (point))) + + ;; Send the text to the process. + (condition-case nil + (process-send-region + gnus-uu-uudecode-process start-char (point)) + (error + (progn + (delete-process gnus-uu-uudecode-process) + (gnus-message 2 "gnus-uu: Couldn't uudecode") + (setq state (list 'wrong-type))))) + + (if (memq 'end state) + (progn + ;; Send an EOF, just in case. + (ignore-errors + (process-send-eof gnus-uu-uudecode-process)) + (while (memq (process-status gnus-uu-uudecode-process) + '(open run)) + (accept-process-output gnus-uu-uudecode-process 1))) + (when (or (not gnus-uu-uudecode-process) + (not (memq (process-status gnus-uu-uudecode-process) + '(run stop)))) + (setq state (list 'wrong-type))))))) + + (if (memq 'begin state) + (cons (if (= (length files) 1) (car files) files) state) + state)))) + +;; This function is used by `gnus-uu-grab-articles' to treat +;; a shared article. +(defun gnus-uu-unshar-article (process-buffer in-state) + (let ((state (list 'ok)) + start-char) + (save-excursion + (set-buffer process-buffer) + (goto-char (point-min)) + (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) + (setq state (list 'wrong-type)) + (beginning-of-line) + (setq start-char (point)) + (call-process-region + start-char (point-max) shell-file-name nil + (get-buffer-create gnus-uu-output-buffer-name) nil + shell-command-switch + (concat "cd " gnus-uu-work-dir " " + gnus-shell-command-separator " sh")))) + state)) + +;; Returns the name of what the shar file is going to unpack. +(defun gnus-uu-find-name-in-shar () + (let ((oldpoint (point)) + res) + (goto-char (point-min)) + (when (re-search-forward gnus-uu-shar-name-marker nil t) + (setq res (buffer-substring (match-beginning 1) (match-end 1)))) + (goto-char oldpoint) + res)) + +;; `gnus-uu-choose-action' chooses what action to perform given the name +;; and `gnus-uu-file-action-list'. Returns either nil if no action is +;; found, or the name of the command to run if such a rule is found. +(defun gnus-uu-choose-action (file-name file-action-list &optional no-ignore) + (let ((action-list (copy-sequence file-action-list)) + (case-fold-search t) + rule action) + (and + (unless no-ignore + (and (not + (and gnus-uu-ignore-files-by-name + (string-match gnus-uu-ignore-files-by-name file-name))) + (not + (and gnus-uu-ignore-files-by-type + (string-match gnus-uu-ignore-files-by-type + (or (gnus-uu-choose-action + file-name gnus-uu-ext-to-mime-list t) + "")))))) + (while (not (or (eq action-list ()) action)) + (setq rule (car action-list)) + (setq action-list (cdr action-list)) + (when (string-match (car rule) file-name) + (setq action (cadr rule))))) + action)) + +(defun gnus-uu-treat-archive (file-path) + ;; Unpacks an archive. Returns t if unpacking is successful. + (let ((did-unpack t) + action command dir) + (setq action (gnus-uu-choose-action + file-path (append gnus-uu-user-archive-rules + (if gnus-uu-ignore-default-archive-rules + nil + gnus-uu-default-archive-rules)))) + + (when (not action) + (error "No unpackers for the file %s" file-path)) + + (string-match "/[^/]*$" file-path) + (setq dir (substring file-path 0 (match-beginning 0))) + + (when (member action gnus-uu-destructive-archivers) + (copy-file file-path (concat file-path "~") t)) + + (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) + + (save-excursion + (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (erase-buffer)) + + (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) + + (if (= 0 (call-process shell-file-name nil + (get-buffer-create gnus-uu-output-buffer-name) + nil shell-command-switch command)) + (message "") + (gnus-message 2 "Error during unpacking of archive") + (setq did-unpack nil)) + + (when (member action gnus-uu-destructive-archivers) + (rename-file (concat file-path "~") file-path t)) + + did-unpack)) + +(defun gnus-uu-dir-files (dir) + (let ((dirs (directory-files dir t "[^/][^\\.][^\\.]?$")) + files file) + (while dirs + (if (file-directory-p (setq file (car dirs))) + (setq files (append files (gnus-uu-dir-files file))) + (push file files)) + (setq dirs (cdr dirs))) + files)) + +(defun gnus-uu-unpack-files (files &optional ignore) + ;; Go through FILES and look for files to unpack. + (let* ((totfiles (gnus-uu-ls-r gnus-uu-work-dir)) + (ofiles files) + file did-unpack) + (while files + (setq file (cdr (assq 'name (car files)))) + (when (and (not (member file ignore)) + (equal (gnus-uu-get-action (file-name-nondirectory file)) + "gnus-uu-archive")) + (push file did-unpack) + (unless (gnus-uu-treat-archive file) + (gnus-message 2 "Error during unpacking of %s" file)) + (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) + (nfiles newfiles)) + (while nfiles + (unless (member (car nfiles) totfiles) + (push (list (cons 'name (car nfiles)) + (cons 'original file)) + ofiles)) + (setq nfiles (cdr nfiles))) + (setq totfiles newfiles))) + (setq files (cdr files))) + (if did-unpack + (gnus-uu-unpack-files ofiles (append did-unpack ignore)) + ofiles))) + +(defun gnus-uu-ls-r (dir) + (let* ((files (gnus-uu-directory-files dir t)) + (ofiles files)) + (while files + (when (file-directory-p (car files)) + (setq ofiles (delete (car files) ofiles)) + (setq ofiles (append ofiles (gnus-uu-ls-r (car files))))) + (setq files (cdr files))) + ofiles)) + +;; Various stuff + +(defun gnus-uu-directory-files (dir &optional full) + (let (files out file) + (setq files (directory-files dir full)) + (while files + (setq file (car files)) + (setq files (cdr files)) + (unless (member (file-name-nondirectory file) '("." "..")) + (push file out))) + (setq out (nreverse out)) + out)) + +(defun gnus-uu-check-correct-stripped-uucode (start end) + (save-excursion + (let (found beg length) + (if (not gnus-uu-correct-stripped-uucode) + () + (goto-char start) + + (if (re-search-forward " \\|`" end t) + (progn + (goto-char start) + (while (not (eobp)) + (progn + (when (looking-at "\n") + (replace-match "")) + (forward-line 1)))) + + (while (not (eobp)) + (if (looking-at (concat gnus-uu-begin-string "\\|" + gnus-uu-end-string)) + () + (when (not found) + (beginning-of-line) + (setq beg (point)) + (end-of-line) + (setq length (- (point) beg))) + (setq found t) + (beginning-of-line) + (setq beg (point)) + (end-of-line) + (when (not (= length (- (point) beg))) + (insert (make-string (- length (- (point) beg)) ? )))) + (forward-line 1))))))) + +(defvar gnus-uu-tmp-alist nil) + +(defun gnus-uu-initialize (&optional scan) + (let (entry) + (if (and (not scan) + (when (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist)) + (if (file-exists-p (cdr entry)) + (setq gnus-uu-work-dir (cdr entry)) + (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist)) + nil))) + t + (setq gnus-uu-tmp-dir (file-name-as-directory + (expand-file-name gnus-uu-tmp-dir))) + (if (not (file-directory-p gnus-uu-tmp-dir)) + (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) + (when (not (file-writable-p gnus-uu-tmp-dir)) + (error "Temp directory %s can't be written to" + gnus-uu-tmp-dir))) + + (setq gnus-uu-work-dir + (make-temp-name (concat gnus-uu-tmp-dir "gnus"))) + (gnus-make-directory gnus-uu-work-dir) + (set-file-modes gnus-uu-work-dir 448) + (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) + (push (cons gnus-newsgroup-name gnus-uu-work-dir) + gnus-uu-tmp-alist)))) + + +;; Kills the temporary uu buffers, kills any processes, etc. +(defun gnus-uu-clean-up () + (let (buf) + (and gnus-uu-uudecode-process + (memq (process-status (or gnus-uu-uudecode-process "nevair")) + '(stop run)) + (delete-process gnus-uu-uudecode-process)) + (when (setq buf (get-buffer gnus-uu-output-buffer-name)) + (kill-buffer buf)))) + +(defun gnus-quote-arg-for-sh-or-csh (arg) + (let ((pos 0) new-pos accum) + ;; *** bug: we don't handle newline characters properly + (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) + (push (substring arg pos new-pos) accum) + (push "\\" accum) + (push (list (aref arg new-pos)) accum) + (setq pos (1+ new-pos))) + (if (= pos 0) + arg + (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))) + +;; Inputs an action and a filename and returns a full command, making sure +;; that the filename will be treated as a single argument when the shell +;; executes the command. +(defun gnus-uu-command (action file) + (let ((quoted-file (gnus-quote-arg-for-sh-or-csh file))) + (if (string-match "%s" action) + (format action quoted-file) + (concat action " " quoted-file)))) + +(defun gnus-uu-delete-work-dir (&optional dir) + "Delete recursively all files and directories under `gnus-uu-work-dir'." + (if dir + (gnus-message 7 "Deleting directory %s..." dir) + (setq dir gnus-uu-work-dir)) + (when (and dir + (file-exists-p dir)) + (let ((files (directory-files dir t nil t)) + file) + (while (setq file (pop files)) + (unless (member (file-name-nondirectory file) '("." "..")) + (if (file-directory-p file) + (gnus-uu-delete-work-dir file) + (gnus-message 9 "Deleting file %s..." file) + (delete-file file)))) + (delete-directory dir))) + (gnus-message 7 "")) + +;; Initializing + +(add-hook 'gnus-exit-group-hook 'gnus-uu-clean-up) +(add-hook 'gnus-exit-group-hook 'gnus-uu-delete-work-dir) + + + +;;; +;;; uuencoded posting +;;; + +;; Any function that is to be used as and encoding method will take two +;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" +;; and "spiral.jpg", respectively.) The function should return nil if +;; the encoding wasn't successful. +(defcustom gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode + "Function used for encoding binary files. +There are three functions supplied with gnus-uu for encoding files: +`gnus-uu-post-encode-uuencode', which does straight uuencoding; +`gnus-uu-post-encode-mime', which encodes with base64 and adds MIME +headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with +uuencode and adds MIME headers." + :group 'gnus-extract-post + :type '(radio (function-item gnus-uu-post-encode-uuencode) + (function-item gnus-uu-post-encode-mime) + (function-item gnus-uu-post-encode-mime-uuencode) + (function :tag "Other"))) + +(defcustom gnus-uu-post-include-before-composing nil + "Non-nil means that gnus-uu will ask for a file to encode before you compose the article. +If this variable is t, you can either include an encoded file with +\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article." + :group 'gnus-extract-post + :type 'boolean) + +(defcustom gnus-uu-post-length 990 + "Maximum length of an article. +The encoded file will be split into how many articles it takes to +post the entire file." + :group 'gnus-extract-post + :type 'integer) + +(defcustom gnus-uu-post-threaded nil + "Non-nil means that gnus-uu will post the encoded file in a thread. +This may not be smart, as no other decoder I have seen are able to +follow threads when collecting uuencoded articles. (Well, I have seen +one package that does that - gnus-uu, but somehow, I don't think that +counts...) The default is nil." + :group 'gnus-extract-post + :type 'boolean) + +(defcustom gnus-uu-post-separate-description t + "Non-nil means that the description will be posted in a separate article. +The first article will typically be numbered (0/x). If this variable +is nil, the description the user enters will be included at the +beginning of the first article, which will be numbered (1/x). Default +is t." + :group 'gnus-extract-post + :type 'boolean) + +(defvar gnus-uu-post-binary-separator "--binary follows this line--") +(defvar gnus-uu-post-message-id nil) +(defvar gnus-uu-post-inserted-file-name nil) +(defvar gnus-uu-winconf-post-news nil) + +(defun gnus-uu-post-news () + "Compose an article and post an encoded file." + (interactive) + (setq gnus-uu-post-inserted-file-name nil) + (setq gnus-uu-winconf-post-news (current-window-configuration)) + + (gnus-summary-post-news) + + (use-local-map (copy-keymap (current-local-map))) + (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) + (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) + (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) + (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) + + (when gnus-uu-post-include-before-composing + (save-excursion (setq gnus-uu-post-inserted-file-name + (gnus-uu-post-insert-binary))))) + +(defun gnus-uu-post-insert-binary-in-article () + "Inserts an encoded file in the buffer. +The user will be asked for a file name." + (interactive) + (save-excursion + (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary)))) + +;; Encodes with uuencode and substitutes all spaces with backticks. +(defun gnus-uu-post-encode-uuencode (path file-name) + (when (gnus-uu-post-encode-file "uuencode" path file-name) + (goto-char (point-min)) + (forward-line 1) + (while (re-search-forward " " nil t) + (replace-match "`")) + t)) + +;; Encodes with uuencode and adds MIME headers. +(defun gnus-uu-post-encode-mime-uuencode (path file-name) + (when (gnus-uu-post-encode-uuencode path file-name) + (gnus-uu-post-make-mime file-name "x-uue") + t)) + +;; Encodes with base64 and adds MIME headers +(defun gnus-uu-post-encode-mime (path file-name) + (when (gnus-uu-post-encode-file "mmencode" path file-name) + (gnus-uu-post-make-mime file-name "base64") + t)) + +;; Adds MIME headers. +(defun gnus-uu-post-make-mime (file-name encoding) + (goto-char (point-min)) + (insert (format "Content-Type: %s; name=\"%s\"\n" + (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) + file-name)) + (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) + (save-restriction + (set-buffer gnus-message-buffer) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line -1) + (narrow-to-region 1 (point)) + (unless (mail-fetch-field "mime-version") + (widen) + (insert "MIME-Version: 1.0\n")) + (widen))) + +;; Encodes a file PATH with COMMAND, leaving the result in the +;; current buffer. +(defun gnus-uu-post-encode-file (command path file-name) + (= 0 (call-process shell-file-name nil t nil shell-command-switch + (format "%s %s %s" command path file-name)))) + +(defun gnus-uu-post-news-inews () + "Posts the composed news article and encoded file. +If no file has been included, the user will be asked for a file." + (interactive) + + (let (file-name) + + (if gnus-uu-post-inserted-file-name + (setq file-name gnus-uu-post-inserted-file-name) + (setq file-name (gnus-uu-post-insert-binary))) + + (gnus-uu-post-encoded file-name gnus-uu-post-threaded)) + (setq gnus-uu-post-inserted-file-name nil) + (when gnus-uu-winconf-post-news + (set-window-configuration gnus-uu-winconf-post-news))) + +;; Asks for a file to encode, encodes it and inserts the result in +;; the current buffer. Returns the file name the user gave. +(defun gnus-uu-post-insert-binary () + (let ((uuencode-buffer-name "*uuencode buffer*") + file-path uubuf file-name) + + (setq file-path (read-file-name + "What file do you want to encode? ")) + (when (not (file-exists-p file-path)) + (error "%s: No such file" file-path)) + + (goto-char (point-max)) + (insert (format "\n%s\n" gnus-uu-post-binary-separator)) + + (when (string-match "^~/" file-path) + (setq file-path (concat "$HOME" (substring file-path 1)))) + (if (string-match "/[^/]*$" file-path) + (setq file-name (substring file-path (1+ (match-beginning 0)))) + (setq file-name file-path)) + + (unwind-protect + (if (save-excursion + (set-buffer (setq uubuf + (get-buffer-create uuencode-buffer-name))) + (erase-buffer) + (funcall gnus-uu-post-encode-method file-path file-name)) + (insert-buffer-substring uubuf) + (error "Encoding unsuccessful")) + (kill-buffer uubuf)) + file-name)) + +;; Posts the article and all of the encoded file. +(defun gnus-uu-post-encoded (file-name &optional threaded) + (let ((send-buffer-name "*uuencode send buffer*") + (encoded-buffer-name "*encoded buffer*") + (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") + (separator (concat mail-header-separator "\n\n")) + uubuf length parts header i end beg + beg-line minlen buf post-buf whole-len beg-binary end-binary) + + (setq post-buf (current-buffer)) + + (goto-char (point-min)) + (when (not (re-search-forward + (if gnus-uu-post-separate-description + (concat "^" (regexp-quote gnus-uu-post-binary-separator) + "$") + (concat "^" (regexp-quote mail-header-separator) "$")) + nil t)) + (error "Internal error: No binary/header separator")) + (beginning-of-line) + (forward-line 1) + (setq beg-binary (point)) + (setq end-binary (point-max)) + + (save-excursion + (set-buffer (setq uubuf (get-buffer-create encoded-buffer-name))) + (erase-buffer) + (insert-buffer-substring post-buf beg-binary end-binary) + (goto-char (point-min)) + (setq length (count-lines 1 (point-max))) + (setq parts (/ length gnus-uu-post-length)) + (unless (< (% length gnus-uu-post-length) 4) + (incf parts))) + + (when gnus-uu-post-separate-description + (forward-line -1)) + (delete-region (point) (point-max)) + + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") nil t) + (beginning-of-line) + (setq header (buffer-substring 1 (point))) + + (goto-char (point-min)) + (when gnus-uu-post-separate-description + (when (re-search-forward "^Subject: " nil t) + (end-of-line) + (insert (format " (0/%d)" parts))) + (save-excursion + (message-send)) + (setq gnus-uu-post-message-id (message-fetch-field "message-id"))) + + (save-excursion + (setq i 1) + (setq beg 1) + (while (not (> i parts)) + (set-buffer (get-buffer-create send-buffer-name)) + (erase-buffer) + (insert header) + (when (and threaded gnus-uu-post-message-id) + (insert "References: " gnus-uu-post-message-id "\n")) + (insert separator) + (setq whole-len + (- 62 (length (format top-string "" file-name i parts "")))) + (when (> 1 (setq minlen (/ whole-len 2))) + (setq minlen 1)) + (setq + beg-line + (format top-string + (make-string minlen ?-) + file-name i parts + (make-string + (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-))) + + (goto-char (point-min)) + (when (re-search-forward "^Subject: " nil t) + (end-of-line) + (insert (format " (%d/%d)" i parts))) + + (goto-char (point-max)) + (save-excursion + (set-buffer uubuf) + (goto-char beg) + (if (= i parts) + (goto-char (point-max)) + (forward-line gnus-uu-post-length)) + (when (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) + (forward-line -4)) + (setq end (point))) + (insert-buffer-substring uubuf beg end) + (insert beg-line "\n") + (setq beg end) + (incf i) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") nil t) + (beginning-of-line) + (forward-line 2) + (when (re-search-forward + (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") + nil t) + (replace-match "") + (forward-line 1)) + (insert beg-line) + (insert "\n") + (let (message-sent-message-via) + (save-excursion + (message-send)) + (setq gnus-uu-post-message-id + (concat (message-fetch-field "references") " " + (message-fetch-field "message-id")))))) + + (gnus-kill-buffer send-buffer-name) + (gnus-kill-buffer encoded-buffer-name) + + (when (not gnus-uu-post-separate-description) + (set-buffer-modified-p nil) + (when (fboundp 'bury-buffer) + (bury-buffer))))) + +(provide 'gnus-uu) + +;; gnus-uu.el ends here diff --git a/lisp/gnus-vm.el b/lisp/gnus-vm.el new file mode 100644 index 0000000..316b775 --- /dev/null +++ b/lisp/gnus-vm.el @@ -0,0 +1,105 @@ +;;; gnus-vm.el --- vm interface for Gnus +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. + +;; Author: Per Persson +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Major contributors: +;; Christian Limpach +;; Some code stolen from: +;; Rick Sladkey + +;;; Code: + +(require 'sendmail) +(require 'message) +(require 'gnus) +(require 'gnus-msg) + +(eval-when-compile + (autoload 'vm-mode "vm") + (autoload 'vm-save-message "vm") + (autoload 'vm-forward-message "vm") + (autoload 'vm-reply "vm") + (autoload 'vm-mail "vm")) + +(defvar gnus-vm-inhibit-window-system nil + "Inhibit loading `win-vm' if using a window-system. +Has to be set before gnus-vm is loaded.") + +(or gnus-vm-inhibit-window-system + (condition-case nil + (when window-system + (require 'win-vm)) + (error nil))) + +(when (not (featurep 'vm)) + (load "vm")) + +(defun gnus-vm-make-folder (&optional buffer) + (let ((article (or buffer (current-buffer))) + (tmp-folder (generate-new-buffer " *tmp-folder*")) + (start (point-min)) + (end (point-max))) + (set-buffer tmp-folder) + (insert-buffer-substring article start end) + (goto-char (point-min)) + (if (looking-at "^\\(From [^ ]+ \\).*$") + (replace-match (concat "\\1" (current-time-string))) + (insert "From " gnus-newsgroup-name " " + (current-time-string) "\n")) + (while (re-search-forward "\n\nFrom " nil t) + (replace-match "\n\n>From ")) + ;; insert a newline, otherwise the last line gets lost + (goto-char (point-max)) + (insert "\n") + (vm-mode) + tmp-folder)) + +(defun gnus-summary-save-article-vm (&optional arg) + "Append the current article to a vm folder. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-in-vm (&optional folder) + (interactive) + (setq folder + (gnus-read-save-file-name + "Save %s in VM folder:" folder + gnus-mail-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-mail)) + (gnus-eval-in-buffer-window gnus-original-article-buffer + (save-excursion + (save-restriction + (widen) + (let ((vm-folder (gnus-vm-make-folder))) + (vm-save-message folder) + (kill-buffer vm-folder)))))) + +(provide 'gnus-vm) + +;;; gnus-vm.el ends here. diff --git a/lisp/gnus-win.el b/lisp/gnus-win.el new file mode 100644 index 0000000..d66d0c5 --- /dev/null +++ b/lisp/gnus-win.el @@ -0,0 +1,554 @@ +;;; gnus-win.el --- window configuration functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) + +(defgroup gnus-windows nil + "Window configuration." + :group 'gnus) + +(defcustom gnus-use-full-window t + "*If non-nil, use the entire Emacs screen." + :group 'gnus-windows + :type 'boolean) + +(defvar gnus-window-configuration nil + "Obsolete variable. See `gnus-buffer-configuration'.") + +(defcustom gnus-window-min-width 2 + "*Minimum width of Gnus buffers." + :group 'gnus-windows + :type 'integer) + +(defcustom gnus-window-min-height 1 + "*Minimum height of Gnus buffers." + :group 'gnus-windows + :type 'integer) + +(defcustom gnus-always-force-window-configuration nil + "*If non-nil, always force the Gnus window configurations." + :group 'gnus-windows + :type 'boolean) + +(defvar gnus-buffer-configuration + '((group + (vertical 1.0 + (group 1.0 point) + (if gnus-carpal '(group-carpal 4)))) + (summary + (vertical 1.0 + (summary 1.0 point) + (if gnus-carpal '(summary-carpal 4)))) + (article + (cond + ((and gnus-use-picons + (eq gnus-picons-display-where 'picons)) + '(frame 1.0 + (vertical 1.0 + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + (article 1.0)) + (vertical ((height . 5) (width . 15) + (user-position . t) + (left . -1) (top . 1)) + (picons 1.0)))) + (gnus-use-trees + '(vertical 1.0 + (summary 0.25 point) + (tree 0.25) + (article 1.0))) + (t + '(vertical 1.0 + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + (article 1.0))))) + (server + (vertical 1.0 + (server 1.0 point) + (if gnus-carpal '(server-carpal 2)))) + (browse + (vertical 1.0 + (browse 1.0 point) + (if gnus-carpal '(browse-carpal 2)))) + (message + (vertical 1.0 + (message 1.0 point))) + (pick + (vertical 1.0 + (article 1.0 point))) + (info + (vertical 1.0 + (info 1.0 point))) + (summary-faq + (vertical 1.0 + (summary 0.25) + (faq 1.0 point))) + (edit-article + (vertical 1.0 + (article 1.0 point))) + (edit-form + (vertical 1.0 + (group 0.5) + (edit-form 1.0 point))) + (edit-score + (vertical 1.0 + (summary 0.25) + (edit-score 1.0 point))) + (post + (vertical 1.0 + (post 1.0 point))) + (reply + (vertical 1.0 + (article-copy 0.5) + (message 1.0 point))) + (forward + (vertical 1.0 + (message 1.0 point))) + (reply-yank + (vertical 1.0 + (message 1.0 point))) + (mail-bounce + (vertical 1.0 + (article 0.5) + (message 1.0 point))) + (pipe + (vertical 1.0 + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + ("*Shell Command Output*" 1.0))) + (bug + (vertical 1.0 + ("*Gnus Help Bug*" 0.5) + ("*Gnus Bug*" 1.0 point))) + (score-trace + (vertical 1.0 + (summary 0.5 point) + ("*Score Trace*" 1.0))) + (score-words + (vertical 1.0 + (summary 0.5 point) + ("*Score Words*" 1.0))) + (category + (vertical 1.0 + (category 1.0))) + (compose-bounce + (vertical 1.0 + (article 0.5) + (message 1.0 point)))) + "Window configuration for all possible Gnus buffers. +See the Gnus manual for an explanation of the syntax used.") + +(defvar gnus-window-to-buffer + '((group . gnus-group-buffer) + (summary . gnus-summary-buffer) + (article . gnus-article-buffer) + (server . gnus-server-buffer) + (browse . "*Gnus Browse Server*") + (edit-group . gnus-group-edit-buffer) + (edit-form . gnus-edit-form-buffer) + (edit-server . gnus-server-edit-buffer) + (group-carpal . gnus-carpal-group-buffer) + (summary-carpal . gnus-carpal-summary-buffer) + (server-carpal . gnus-carpal-server-buffer) + (browse-carpal . gnus-carpal-browse-buffer) + (edit-score . gnus-score-edit-buffer) + (message . gnus-message-buffer) + (mail . gnus-message-buffer) + (post-news . gnus-message-buffer) + (faq . gnus-faq-buffer) + (picons . "*Picons*") + (tree . gnus-tree-buffer) + (score-trace . "*Score Trace*") + (info . gnus-info-buffer) + (category . gnus-category-buffer) + (article-copy . gnus-article-copy) + (draft . gnus-draft-buffer)) + "Mapping from short symbols to buffer names or buffer variables.") + +;;; Internal variables. + +(defvar gnus-current-window-configuration nil + "The most recently set window configuration.") + +(defvar gnus-created-frames nil) + +(defun gnus-kill-gnus-frames () + "Kill all frames Gnus has created." + (while gnus-created-frames + (when (frame-live-p (car gnus-created-frames)) + ;; We slap a condition-case around this `delete-frame' to ensure + ;; against errors if we try do delete the single frame that's left. + (ignore-errors + (delete-frame (car gnus-created-frames)))) + (pop gnus-created-frames))) + +(defun gnus-window-configuration-element (list) + (while (and list + (not (assq (car list) gnus-window-configuration))) + (pop list)) + (cadr (assq (car list) gnus-window-configuration))) + +(defun gnus-windows-old-to-new (setting) + ;; First we take care of the really, really old Gnus 3 actions. + (when (symbolp setting) + (setq setting + ;; Take care of ooold GNUS 3.x values. + (cond ((eq setting 'SelectArticle) 'article) + ((memq setting '(SelectNewsgroup SelectSubject ExpandSubject)) + 'summary) + ((memq setting '(ExitNewsgroup)) 'group) + (t setting)))) + (if (or (listp setting) + (not (and gnus-window-configuration + (memq setting '(group summary article))))) + setting + (let* ((elem + (cond + ((eq setting 'group) + (gnus-window-configuration-element + '(group newsgroups ExitNewsgroup))) + ((eq setting 'summary) + (gnus-window-configuration-element + '(summary SelectNewsgroup SelectSubject ExpandSubject))) + ((eq setting 'article) + (gnus-window-configuration-element + '(article SelectArticle))))) + (total (apply '+ elem)) + (types '(group summary article)) + (pbuf (if (eq setting 'newsgroups) 'group 'summary)) + (i 0) + perc out) + (while (< i 3) + (or (not (numberp (nth i elem))) + (zerop (nth i elem)) + (progn + (setq perc (if (= i 2) + 1.0 + (/ (float (nth i elem)) total))) + (push (if (eq pbuf (nth i types)) + (list (nth i types) perc 'point) + (list (nth i types) perc)) + out))) + (incf i)) + `(vertical 1.0 ,@(nreverse out))))) + +;;;###autoload +(defun gnus-add-configuration (conf) + "Add the window configuration CONF to `gnus-buffer-configuration'." + (setq gnus-buffer-configuration + (cons conf (delq (assq (car conf) gnus-buffer-configuration) + gnus-buffer-configuration)))) + +(defvar gnus-frame-list nil) + +(defun gnus-configure-frame (split &optional window) + "Split WINDOW according to SPLIT." + (unless window + (setq window (get-buffer-window (current-buffer)))) + (select-window window) + ;; This might be an old-stylee buffer config. + (when (vectorp split) + (setq split (append split nil))) + (when (or (consp (car split)) + (vectorp (car split))) + (push 1.0 split) + (push 'vertical split)) + ;; The SPLIT might be something that is to be evaled to + ;; return a new SPLIT. + (while (and (not (assq (car split) gnus-window-to-buffer)) + (gnus-functionp (car split))) + (setq split (eval split))) + (let* ((type (car split)) + (subs (cddr split)) + (len (if (eq type 'horizontal) (window-width) (window-height))) + (total 0) + (window-min-width (or gnus-window-min-width window-min-width)) + (window-min-height (or gnus-window-min-height window-min-height)) + s result new-win rest comp-subs size sub) + (cond + ;; Nothing to do here. + ((null split)) + ;; Don't switch buffers. + ((null type) + (and (memq 'point split) window)) + ;; This is a buffer to be selected. + ((not (memq type '(frame horizontal vertical))) + (let ((buffer (cond ((stringp type) type) + (t (cdr (assq type gnus-window-to-buffer))))) + buf) + (unless buffer + (error "Illegal buffer type: %s" type)) + (unless (setq buf (get-buffer (if (symbolp buffer) + (symbol-value buffer) buffer))) + (setq buf (get-buffer-create (if (symbolp buffer) + (symbol-value buffer) buffer)))) + (switch-to-buffer buf) + ;; We return the window if it has the `point' spec. + (and (memq 'point split) window))) + ;; This is a frame split. + ((eq type 'frame) + (unless gnus-frame-list + (setq gnus-frame-list (list (window-frame + (get-buffer-window (current-buffer)))))) + (let ((i 0) + params frame fresult) + (while (< i (length subs)) + ;; Frame parameter is gotten from the sub-split. + (setq params (cadr (elt subs i))) + ;; It should be a list. + (unless (listp params) + (setq params nil)) + ;; Create a new frame? + (unless (setq frame (elt gnus-frame-list i)) + (nconc gnus-frame-list (list (setq frame (make-frame params)))) + (push frame gnus-created-frames)) + ;; Is the old frame still alive? + (unless (frame-live-p frame) + (setcar (nthcdr i gnus-frame-list) + (setq frame (make-frame params)))) + ;; Select the frame in question and do more splits there. + (select-frame frame) + (setq fresult (or (gnus-configure-frame (elt subs i)) fresult)) + (incf i)) + ;; Select the frame that has the selected buffer. + (when fresult + (select-frame (window-frame fresult))))) + ;; This is a normal split. + (t + (when (> (length subs) 0) + ;; First we have to compute the sizes of all new windows. + (while subs + (setq sub (append (pop subs) nil)) + (while (and (not (assq (car sub) gnus-window-to-buffer)) + (gnus-functionp (car sub))) + (setq sub (eval sub))) + (when sub + (push sub comp-subs) + (setq size (cadar comp-subs)) + (cond ((equal size 1.0) + (setq rest (car comp-subs)) + (setq s 0)) + ((floatp size) + (setq s (floor (* size len)))) + ((integerp size) + (setq s size)) + (t + (error "Illegal size: %s" size))) + ;; Try to make sure that we are inside the safe limits. + (cond ((zerop s)) + ((eq type 'horizontal) + (setq s (max s window-min-width))) + ((eq type 'vertical) + (setq s (max s window-min-height)))) + (setcar (cdar comp-subs) s) + (incf total s))) + ;; Take care of the "1.0" spec. + (if rest + (setcar (cdr rest) (- len total)) + (error "No 1.0 specs in %s" split)) + ;; The we do the actual splitting in a nice recursive + ;; fashion. + (setq comp-subs (nreverse comp-subs)) + (while comp-subs + (if (null (cdr comp-subs)) + (setq new-win window) + (setq new-win + (split-window window (cadar comp-subs) + (eq type 'horizontal)))) + (setq result (or (gnus-configure-frame + (car comp-subs) window) + result)) + (select-window new-win) + (setq window new-win) + (setq comp-subs (cdr comp-subs)))) + ;; Return the proper window, if any. + (when result + (select-window result)))))) + +(defvar gnus-frame-split-p nil) + +(defun gnus-configure-windows (setting &optional force) + (setq gnus-current-window-configuration setting) + (setq force (or force gnus-always-force-window-configuration)) + (setq setting (gnus-windows-old-to-new setting)) + (let ((split (if (symbolp setting) + (cadr (assq setting gnus-buffer-configuration)) + setting)) + all-visible) + + (setq gnus-frame-split-p nil) + + (unless split + (error "No such setting: %s" setting)) + + (if (and (setq all-visible (gnus-all-windows-visible-p split)) + (not force)) + ;; All the windows mentioned are already visible, so we just + ;; put point in the assigned buffer, and do not touch the + ;; winconf. + (select-window all-visible) + + ;; Either remove all windows or just remove all Gnus windows. + (let ((frame (selected-frame))) + (unwind-protect + (if gnus-use-full-window + ;; We want to remove all other windows. + (if (not gnus-frame-split-p) + ;; This is not a `frame' split, so we ignore the + ;; other frames. + (delete-other-windows) + ;; This is a `frame' split, so we delete all windows + ;; on all frames. + (gnus-delete-windows-in-gnusey-frames)) + ;; Just remove some windows. + (gnus-remove-some-windows) + (switch-to-buffer nntp-server-buffer)) + (select-frame frame))) + + (switch-to-buffer nntp-server-buffer) + (gnus-configure-frame split (get-buffer-window (current-buffer)))))) + +(defun gnus-delete-windows-in-gnusey-frames () + "Do a `delete-other-windows' in all frames that have Gnus windows." + (let ((buffers + (mapcar + (lambda (elem) + (if (symbolp (cdr elem)) + (when (and (boundp (cdr elem)) + (symbol-value (cdr elem))) + (get-buffer (symbol-value (cdr elem)))) + (when (cdr elem) + (get-buffer (cdr elem))))) + gnus-window-to-buffer))) + (mapcar + (lambda (frame) + (unless (eq (cdr (assq 'minibuffer + (frame-parameters frame))) + 'only) + (select-frame frame) + (let (do-delete) + (walk-windows + (lambda (window) + (when (memq (window-buffer window) buffers) + (setq do-delete t)))) + (when do-delete + (delete-other-windows))))) + (frame-list)))) + +(defun gnus-all-windows-visible-p (split) + "Say whether all buffers in SPLIT are currently visible. +In particular, the value returned will be the window that +should have point." + (let ((stack (list split)) + (all-visible t) + type buffer win buf) + (while (and (setq split (pop stack)) + all-visible) + ;; Be backwards compatible. + (when (vectorp split) + (setq split (append split nil))) + (when (or (consp (car split)) + (vectorp (car split))) + (push 1.0 split) + (push 'vertical split)) + ;; The SPLIT might be something that is to be evaled to + ;; return a new SPLIT. + (while (and (not (assq (car split) gnus-window-to-buffer)) + (gnus-functionp (car split))) + (setq split (eval split))) + + (setq type (elt split 0)) + (cond + ;; Nothing here. + ((null split) t) + ;; A buffer. + ((not (memq type '(horizontal vertical frame))) + (setq buffer (cond ((stringp type) type) + (t (cdr (assq type gnus-window-to-buffer))))) + (unless buffer + (error "Illegal buffer type: %s" type)) + (when (setq buf (get-buffer (if (symbolp buffer) + (symbol-value buffer) + buffer))) + (setq win (get-buffer-window buf t))) + (if win + (when (memq 'point split) + (setq all-visible win)) + (setq all-visible nil))) + (t + (when (eq type 'frame) + (setq gnus-frame-split-p t)) + (setq stack (append (cddr split) stack))))) + (unless (eq all-visible t) + all-visible))) + +(defun gnus-window-top-edge (&optional window) + (nth 1 (window-edges window))) + +(defun gnus-remove-some-windows () + (let ((buffers gnus-window-to-buffer) + buf bufs lowest-buf lowest) + (save-excursion + ;; Remove windows on all known Gnus buffers. + (while buffers + (setq buf (cdar buffers)) + (when (symbolp buf) + (setq buf (and (boundp buf) (symbol-value buf)))) + (and buf + (get-buffer-window buf) + (progn + (push buf bufs) + (pop-to-buffer buf) + (when (or (not lowest) + (< (gnus-window-top-edge) lowest)) + (setq lowest (gnus-window-top-edge)) + (setq lowest-buf buf)))) + (setq buffers (cdr buffers))) + ;; Remove windows on *all* summary buffers. + (walk-windows + (lambda (win) + (let ((buf (window-buffer win))) + (when (string-match "^\\*Summary" (buffer-name buf)) + (push buf bufs) + (pop-to-buffer buf) + (when (or (not lowest) + (< (gnus-window-top-edge) lowest)) + (setq lowest-buf buf) + (setq lowest (gnus-window-top-edge))))))) + (when lowest-buf + (pop-to-buffer lowest-buf) + (switch-to-buffer nntp-server-buffer)) + (while bufs + (when (not (eq (car bufs) lowest-buf)) + (delete-windows-on (car bufs))) + (setq bufs (cdr bufs)))))) + +(provide 'gnus-win) + +;;; gnus-win.el ends here diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el new file mode 100644 index 0000000..bb49aab --- /dev/null +++ b/lisp/gnus-xmas.el @@ -0,0 +1,797 @@ +;;; gnus-xmas.el --- Gnus functions for XEmacs +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'text-props) +(defvar menu-bar-mode (featurep 'menubar)) +(require 'messagexmas) + +(defgroup gnus-xmas nil + "XEmacsoid support for Gnus" + :group 'gnus) + +(defcustom gnus-xmas-glyph-directory nil + "*Directory where Gnus logos and icons are located. +If this variable is nil, Gnus will try to locate the directory +automatically." + :type '(choice (const :tag "autodetect" nil) + directory) + :group 'gnus-xmas) + +(defvar gnus-xmas-logo-color-alist + '((flame "#cc3300" "#ff2200") + (pine "#c0cc93" "#f8ffb8") + (moss "#a1cc93" "#d2ffb8") + (irish "#04cc90" "#05ff97") + (sky "#049acc" "#05deff") + (tin "#6886cc" "#82b6ff") + (velvet "#7c68cc" "#8c82ff") + (grape "#b264cc" "#cf7df") + (labia "#cc64c2" "#fd7dff") + (berry "#cc6485" "#ff7db5") + (neutral "#b4b4b4" "#878787") + (september "#bf9900" "#ffcc00")) + "Color alist used for the Gnus logo.") + +(defcustom gnus-xmas-logo-color-style 'moss + "Color styles used for the Gnus logo." + :type '(choice (const flame) (const pine) (const moss) + (const irish) (const sky) (const tin) + (const velvet) (const grape) (const labia) + (const berry) (const neutral) (const september)) + :group 'gnus-xmas) + +(defvar gnus-xmas-logo-colors + (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist)) + "Colors used for the Gnus logo.") + +(defcustom gnus-article-x-face-command + (if (or (featurep 'xface) + (featurep 'xpm)) + 'gnus-xmas-article-display-xface + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -") + "String or function to be executed to display an X-Face header. +If it is a string, the command will be executed in a sub-shell +asynchronously. The compressed face will be piped to this command." + :type '(choice string function)) + +;;; Internal variables. + +;; Don't warn about these undefined variables. + +(defvar gnus-group-mode-hook) +(defvar gnus-summary-mode-hook) +(defvar gnus-article-mode-hook) + +;;defined in gnus.el +(defvar gnus-active-hashtb) +(defvar gnus-article-buffer) +(defvar gnus-auto-center-summary) +(defvar gnus-buffer-list) +(defvar gnus-current-headers) +(defvar gnus-level-killed) +(defvar gnus-level-zombie) +(defvar gnus-newsgroup-bookmarks) +(defvar gnus-newsgroup-dependencies) +(defvar gnus-newsgroup-selected-overlay) +(defvar gnus-newsrc-hashtb) +(defvar gnus-read-mark) +(defvar gnus-refer-article-method) +(defvar gnus-reffed-article-number) +(defvar gnus-unread-mark) +(defvar gnus-version) +(defvar gnus-view-pseudos) +(defvar gnus-view-pseudos-separately) +(defvar gnus-visual) +(defvar gnus-zombie-list) +;;defined in gnus-msg.el +(defvar gnus-article-copy) +(defvar gnus-check-before-posting) +;;defined in gnus-vis.el +(defvar gnus-article-button-face) +(defvar gnus-article-mouse-face) +(defvar gnus-summary-selected-face) +(defvar gnus-group-reading-menu) +(defvar gnus-group-group-menu) +(defvar gnus-group-misc-menu) +(defvar gnus-summary-article-menu) +(defvar gnus-summary-thread-menu) +(defvar gnus-summary-misc-menu) +(defvar gnus-summary-post-menu) +(defvar gnus-summary-kill-menu) +(defvar gnus-article-article-menu) +(defvar gnus-article-treatment-menu) +(defvar gnus-mouse-2) +(defvar standard-display-table) +(defvar gnus-tree-minimize-window) + +(defun gnus-xmas-set-text-properties (start end props &optional buffer) + "You should NEVER use this function. It is ideologically blasphemous. +It is provided only to ease porting of broken FSF Emacs programs." + (if (stringp buffer) + nil + (map-extents (lambda (extent ignored) + (remove-text-properties + start end + (list (extent-property extent 'text-prop) nil) + buffer) + nil) + buffer start end nil nil 'text-prop) + (gnus-add-text-properties start end props buffer))) + +(defun gnus-xmas-highlight-selected-summary () + ;; Highlight selected article in summary buffer + (when gnus-summary-selected-face + (when gnus-newsgroup-selected-overlay + (delete-extent gnus-newsgroup-selected-overlay)) + (setq gnus-newsgroup-selected-overlay + (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) + (set-extent-face gnus-newsgroup-selected-overlay + gnus-summary-selected-face))) + +(defcustom gnus-xmas-force-redisplay nil + "If non-nil, force a redisplay before recentering the summary buffer. +This is ugly, but it works around a bug in `window-displayed-height'." + :type 'boolean + :group 'gnus-xmas) + +(defun gnus-xmas-switch-horizontal-scrollbar-off () + (when (featurep 'scrollbar) + (set-specifier scrollbar-height (cons (current-buffer) 0)))) + +(defun gnus-xmas-summary-recenter () + "\"Center\" point in the summary window. +If `gnus-auto-center-summary' is nil, or the article buffer isn't +displayed, no centering will be performed." + ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). + ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. + ;; Force redisplay to get properly computed window height. + (when gnus-xmas-force-redisplay + (sit-for 0)) + (when gnus-auto-center-summary + (let* ((height (if (fboundp 'window-displayed-height) + (window-displayed-height) + (- (window-height) 2))) + (top (cond ((< height 4) 0) + ((< height 7) 1) + (t 2))) + (bottom (save-excursion (goto-char (point-max)) + (forward-line (- height)) + (point))) + (window (get-buffer-window (current-buffer)))) + (when (get-buffer-window gnus-article-buffer) + ;; Only do recentering when the article buffer is displayed, + ;; Set the window start to either `bottom', which is the biggest + ;; possible valid number, or the second line from the top, + ;; whichever is the least. + (set-window-start + window (min bottom (save-excursion (forward-line (- top)) (point))))) + ;; Do horizontal recentering while we're at it. + (when (and (get-buffer-window (current-buffer) t) + (not (eq gnus-auto-center-summary 'vertical))) + (let ((selected (selected-window))) + (select-window (get-buffer-window (current-buffer) t)) + (gnus-summary-position-point) + (gnus-horizontal-recenter) + (select-window selected)))))) + +(defun gnus-xmas-summary-set-display-table () + ;; Setup the display table -- like `gnus-summary-setup-display-table', + ;; but done in an XEmacsish way. + (let ((table (make-display-table)) + (i 32)) + ;; Nix out all the control chars... + (while (>= (setq i (1- i)) 0) + (aset table i [??])) + ;; ... but not newline and cr, of course. (cr is necessary for the + ;; selective display). + (aset table ?\n nil) + (aset table ?\r nil) + ;; We nix out any glyphs over 126 below ctl-arrow. + (let ((i (if (integerp ctl-arrow) ctl-arrow 160))) + (while (>= (setq i (1- i)) 127) + (unless (aref table i) + (aset table i [??])))) + ;; Can't use `set-specifier' because of a bug in 19.14 and earlier + (add-spec-to-specifier current-display-table table (current-buffer) nil))) + +(defun gnus-xmas-add-text-properties (start end props &optional object) + (add-text-properties start end props object) + (put-text-property start end 'start-closed nil object)) + +(defun gnus-xmas-put-text-property (start end prop value &optional object) + (put-text-property start end prop value object) + (put-text-property start end 'start-closed nil object)) + +(defun gnus-xmas-extent-start-open (point) + (map-extents (lambda (extent arg) + (set-extent-property extent 'start-open t)) + nil point (min (1+ (point)) (point-max)))) + +(defun gnus-xmas-article-push-button (event) + "Check text under the mouse pointer for a callback function. +If the text under the mouse pointer has a `gnus-callback' property, +call it with the value of the `gnus-data' text property." + (interactive "e") + (set-buffer (window-buffer (event-window event))) + (let* ((pos (event-closest-point event)) + (data (get-text-property pos 'gnus-data)) + (fun (get-text-property pos 'gnus-callback))) + (when fun + (funcall fun data)))) + +(defun gnus-xmas-move-overlay (extent start end &optional buffer) + (set-extent-endpoints extent start end)) + +;; Fixed by Christopher Davis . +(defun gnus-xmas-article-add-button (from to fun &optional data) + "Create a button between FROM and TO with callback FUN and data DATA." + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay from to) + 'face gnus-article-button-face)) + (gnus-add-text-properties + from to + (nconc + (and gnus-article-mouse-face + (list 'mouse-face gnus-article-mouse-face)) + (list 'gnus-callback fun) + (and data (list 'gnus-data data)) + (list 'highlight t)))) + +(defun gnus-xmas-window-top-edge (&optional window) + (nth 1 (window-pixel-edges window))) + +(defun gnus-xmas-tree-minimize () + (when (and gnus-tree-minimize-window + (not (one-window-p))) + (let* ((window-min-height 2) + (height (1+ (count-lines (point-min) (point-max)))) + (min (max (1- window-min-height) height)) + (tot (if (numberp gnus-tree-minimize-window) + (min gnus-tree-minimize-window min) + min)) + (win (get-buffer-window (current-buffer))) + (wh (and win (1- (window-height win))))) + (when (and win + (not (eq tot wh))) + (let ((selected (selected-window))) + (select-window win) + (enlarge-window (- tot wh)) + (select-window selected)))))) + +;; Select the lowest window on the frame. +(defun gnus-xmas-appt-select-lowest-window () + (let* ((lowest-window (selected-window)) + (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges)))))) + (last-window (previous-window)) + (window-search t)) + (while window-search + (let* ((this-window (next-window)) + (next-bottom-edge (car (cdr (cdr (cdr + (window-pixel-edges + this-window))))))) + (when (< bottom-edge next-bottom-edge) + (setq bottom-edge next-bottom-edge) + (setq lowest-window this-window)) + + (select-window this-window) + (when (eq last-window this-window) + (select-window lowest-window) + (setq window-search nil)))))) + +(defmacro gnus-xmas-menu-add (type &rest menus) + `(gnus-xmas-menu-add-1 ',type ',menus)) +(put 'gnus-xmas-menu-add 'lisp-indent-function 1) + +(defun gnus-xmas-menu-add-1 (type menus) + (when (and menu-bar-mode + (gnus-visual-p (intern (format "%s-menu" type)) 'menu)) + (while menus + (easy-menu-add (symbol-value (pop menus)))))) + +(defun gnus-xmas-group-menu-add () + (gnus-xmas-menu-add group + gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu)) + +(defun gnus-xmas-summary-menu-add () + (gnus-xmas-menu-add summary + gnus-summary-misc-menu gnus-summary-kill-menu + gnus-summary-article-menu gnus-summary-thread-menu + gnus-summary-post-menu )) + +(defun gnus-xmas-article-menu-add () + (gnus-xmas-menu-add article + gnus-article-article-menu gnus-article-treatment-menu)) + +(defun gnus-xmas-score-menu-add () + (gnus-xmas-menu-add score + gnus-score-menu)) + +(defun gnus-xmas-pick-menu-add () + (gnus-xmas-menu-add pick + gnus-pick-menu)) + +(defun gnus-xmas-topic-menu-add () + (gnus-xmas-menu-add topic + gnus-topic-menu)) + +(defun gnus-xmas-binary-menu-add () + (gnus-xmas-menu-add binary + gnus-binary-menu)) + +(defun gnus-xmas-tree-menu-add () + (gnus-xmas-menu-add tree + gnus-tree-menu)) + +(defun gnus-xmas-server-menu-add () + (gnus-xmas-menu-add menu + gnus-server-server-menu gnus-server-connections-menu)) + +(defun gnus-xmas-browse-menu-add () + (gnus-xmas-menu-add browse + gnus-browse-menu)) + +(defun gnus-xmas-grouplens-menu-add () + (gnus-xmas-menu-add grouplens + gnus-grouplens-menu)) + +(defun gnus-xmas-read-event-char () + "Get the next event." + (let ((event (next-command-event))) + (sit-for 0) + ;; We junk all non-key events. Is this naughty? + (while (not (or (key-press-event-p event) + (button-press-event-p event))) + (dispatch-event event) + (setq event (next-command-event))) + (cons (and (key-press-event-p event) + (event-to-character event)) + event))) + +(defun gnus-xmas-seconds-since-epoch (date) + "Return a floating point number that says how many seconds have lapsed between Jan 1 12:00:00 1970 and DATE." + (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti))) + (timezone-parse-date date))) + (ttime (mapcar (lambda (ti) (and ti (string-to-int ti))) + (timezone-parse-time + (aref (timezone-parse-date date) 3)))) + (edate (mapcar (lambda (ti) (and ti (string-to-int ti))) + (timezone-parse-date "Jan 1 12:00:00 1970"))) + (tday (- (timezone-absolute-from-gregorian + (nth 1 tdate) (nth 2 tdate) (nth 0 tdate)) + (timezone-absolute-from-gregorian + (nth 1 edate) (nth 2 edate) (nth 0 edate))))) + (+ (nth 2 ttime) + (* (nth 1 ttime) 60) + (* (float (nth 0 ttime)) 60 60) + (* (float tday) 60 60 24)))) + +(defun gnus-xmas-define () + (setq gnus-mouse-2 [button2]) + + (unless (memq 'underline (face-list)) + (and (fboundp 'make-face) + (funcall (intern "make-face") 'underline))) + ;; Must avoid calling set-face-underline-p directly, because it + ;; is a defsubst in emacs19, and will make the .elc files non + ;; portable! + (unless (face-differs-from-default-p 'underline) + (funcall (intern "set-face-underline-p") 'underline t)) + + (cond + ((fboundp 'char-or-char-int-p) + ;; Handle both types of marks for XEmacs-20.x. + (fset 'gnus-characterp 'char-or-char-int-p)) + ;; V19 of XEmacs, probably. + (t + (fset 'gnus-characterp 'characterp))) + + (fset 'gnus-make-overlay 'make-extent) + (fset 'gnus-overlay-put 'set-extent-property) + (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) + (fset 'gnus-overlay-end 'extent-end-position) + (fset 'gnus-extent-detached-p 'extent-detached-p) + (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties) + (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) + (fset 'gnus-deactivate-mark 'ignore) + + (require 'text-props) + (if (and (<= emacs-major-version 19) + (< emacs-minor-version 14)) + (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) + + (when (fboundp 'turn-off-scroll-in-place) + (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) + + (unless (boundp 'standard-display-table) + (setq standard-display-table nil)) + + (defvar gnus-mouse-face-prop 'highlight) + + (unless (fboundp 'encode-time) + (defun encode-time (sec minute hour day month year &optional zone) + (let ((seconds + (gnus-xmas-seconds-since-epoch + (timezone-make-arpa-date + year month day (timezone-make-time-string hour minute sec) + zone)))) + (list (floor (/ seconds (expt 2 16))) + (round (mod seconds (expt 2 16))))))) + + (defun gnus-byte-code (func) + "Return a form that can be `eval'ed based on FUNC." + (let ((fval (symbol-function func))) + (if (byte-code-function-p fval) + (list 'funcall fval) + (cons 'progn (cdr (cdr fval)))))) + + (fset 'gnus-x-color-values + (if (fboundp 'x-color-values) + 'x-color-values + (lambda (color) + (color-instance-rgb-components + (make-color-instance color)))))) + +(defun gnus-xmas-redefine () + "Redefine lots of Gnus functions for XEmacs." + (fset 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table) + (fset 'gnus-visual-turn-off-edit-menu 'identity) + (fset 'gnus-summary-recenter 'gnus-xmas-summary-recenter) + (fset 'gnus-extent-start-open 'gnus-xmas-extent-start-open) + (fset 'gnus-article-push-button 'gnus-xmas-article-push-button) + (fset 'gnus-article-add-button 'gnus-xmas-article-add-button) + (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge) + (fset 'gnus-read-event-char 'gnus-xmas-read-event-char) + (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message) + (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize) + (fset 'gnus-appt-select-lowest-window + 'gnus-xmas-appt-select-lowest-window) + (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) + (fset 'gnus-character-to-event 'character-to-event) + (fset 'gnus-mode-line-buffer-identification + 'gnus-xmas-mode-line-buffer-identification) + (fset 'gnus-key-press-event-p 'key-press-event-p) + (fset 'gnus-region-active-p 'region-active-p) + + (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) + (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) + (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) + (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) + + (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add) + (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add) + (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) + (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) + (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add) + (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add) + (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) + + (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) + (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) + + (add-hook 'gnus-summary-mode-hook + 'gnus-xmas-switch-horizontal-scrollbar-off) + (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)) + + +;;; XEmacs logo and toolbar. + +(defun gnus-xmas-group-startup-message (&optional x y) + "Insert startup message in current buffer." + ;; Insert the message. + (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) + (erase-buffer) + (cond + ((and (console-on-window-system-p) + (or (featurep 'xpm) + (featurep 'xbm))) + (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory)) + (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory)) + (glyph (make-glyph + `(,@(if (featurep 'xpm) + (list + (vector 'xpm + ':file logo-xpm + ':color-symbols + `(("thing" . ,(car gnus-xmas-logo-colors)) + ("shadow" . ,(cadr gnus-xmas-logo-colors)) + ("background" . ,(face-background 'default)))))) + ,(vector 'xbm :file logo-xbm) + ,(vector 'nothing))))) + (insert " ") + (set-extent-begin-glyph (make-extent (point) (point)) glyph) + (goto-char (point-min)) + (while (not (eobp)) + (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2) + ?\ )) + (forward-line 1))) + (goto-char (point-min)) + (let* ((pheight (+ 20 (count-lines (point-min) (point-max)))) + (wheight (window-height)) + (rest (- wheight pheight))) + (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) + (t + (insert + (format " %s + _ ___ _ _ + _ ___ __ ___ __ _ ___ + __ _ ___ __ ___ + _ ___ _ + _ _ __ _ + ___ __ _ + __ _ + _ _ _ + _ _ _ + _ _ _ + __ ___ + _ _ _ _ + _ _ + _ _ + _ _ + _ + __ + +" + "")) + ;; And then hack it. + (gnus-indent-rigidly (point-min) (point-max) + (/ (max (- (window-width) (or x 46)) 0) 2)) + (goto-char (point-min)) + (forward-line 1) + (let* ((pheight (count-lines (point-min) (point-max))) + (wheight (window-height)) + (rest (- wheight pheight))) + (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))) + ;; Paint it. + (put-text-property (point-min) (point-max) 'face 'gnus-splash-face))) + (setq modeline-buffer-identification + (list (concat gnus-version ": *Group*"))) + (set-buffer-modified-p t)) + + +;;; The toolbar. + +(defcustom gnus-use-toolbar (if (featurep 'toolbar) + 'default-toolbar + nil) + "*If nil, do not use a toolbar. +If it is non-nil, it must be a toolbar. The five legal values are +`default-toolbar', `top-toolbar', `bottom-toolbar', +`right-toolbar', and `left-toolbar'." + :type '(choice (const default-toolbar) + (const top-toolbar) (const bottom-toolbar) + (const left-toolbar) (const right-toolbar) + (const :tag "no toolbar" nil)) + :group 'gnus-xmas) + +(defvar gnus-group-toolbar + '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] + [gnus-group-get-new-news-this-group + gnus-group-get-new-news-this-group t "Get new news in this group"] + [gnus-group-catchup-current + gnus-group-catchup-current t "Catchup group"] + [gnus-group-describe-group + gnus-group-describe-group t "Describe group"] + [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"] + [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"] + [gnus-group-kill-group gnus-group-kill-group t "Kill group"] + [gnus-group-exit gnus-group-exit t "Exit Gnus"] + ) + "The group buffer toolbar.") + +(defvar gnus-summary-toolbar + '([gnus-summary-prev-unread + gnus-summary-prev-page-or-article t "Page up"] + [gnus-summary-next-unread + gnus-summary-next-page t "Page down"] + [gnus-summary-post-news + gnus-summary-post-news t "Post an article"] + [gnus-summary-followup-with-original + gnus-summary-followup-with-original t + "Post a followup and yank the original"] + [gnus-summary-followup + gnus-summary-followup t "Post a followup"] + [gnus-summary-reply-with-original + gnus-summary-reply-with-original t "Mail a reply and yank the original"] + [gnus-summary-reply + gnus-summary-reply t "Mail a reply"] + [gnus-summary-caesar-message + gnus-summary-caesar-message t "Rot 13"] + [gnus-uu-decode-uu + gnus-uu-decode-uu t "Decode uuencoded articles"] + [gnus-summary-save-article-file + gnus-summary-save-article-file t "Save article in file"] + [gnus-summary-save-article + gnus-summary-save-article t "Save article"] + [gnus-uu-post-news + gnus-uu-post-news t "Post a uuencoded article"] + [gnus-summary-cancel-article + gnus-summary-cancel-article t "Cancel article"] + [gnus-summary-catchup + gnus-summary-catchup t "Catchup"] + [gnus-summary-catchup-and-exit + gnus-summary-catchup-and-exit t "Catchup and exit"] + [gnus-summary-exit gnus-summary-exit t "Exit this summary"] + ) + "The summary buffer toolbar.") + +(defvar gnus-summary-mail-toolbar + '( + [gnus-summary-prev-unread + gnus-summary-prev-unread-article t "Prev unread article"] + [gnus-summary-next-unread + gnus-summary-next-unread-article t "Next unread article"] + [gnus-summary-mail-reply gnus-summary-reply t "Reply"] +; [gnus-summary-mail-get gnus-mail-get t "Message get"] + [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] + [gnus-summary-mail-save gnus-summary-save-article t "Save"] + [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] +; [gnus-summary-mail-delete gnus-summary-delete-article t "Delete message"] + [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"] +; [gnus-summary-mail-spell gnus-mail-spell t "Spell"] +; [gnus-summary-mail-help gnus-mail-help t "Message help"] + [gnus-summary-caesar-message + gnus-summary-caesar-message t "Rot 13"] + [gnus-uu-decode-uu + gnus-uu-decode-uu t "Decode uuencoded articles"] + [gnus-summary-save-article-file + gnus-summary-save-article-file t "Save article in file"] + [gnus-summary-save-article + gnus-summary-save-article t "Save article"] + [gnus-summary-catchup + gnus-summary-catchup t "Catchup"] + [gnus-summary-catchup-and-exit + gnus-summary-catchup-and-exit t "Catchup and exit"] + [gnus-summary-exit gnus-summary-exit t "Exit this summary"] + ) + "The summary buffer mail toolbar.") + +(defun gnus-xmas-setup-group-toolbar () + (and gnus-use-toolbar + (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus") + (set-specifier (symbol-value gnus-use-toolbar) + (cons (current-buffer) gnus-group-toolbar)))) + +(defun gnus-xmas-setup-summary-toolbar () + (let ((bar (if (gnus-news-group-p gnus-newsgroup-name) + gnus-summary-toolbar gnus-summary-mail-toolbar))) + (and gnus-use-toolbar + (message-xmas-setup-toolbar bar nil "gnus") + (set-specifier (symbol-value gnus-use-toolbar) + (cons (current-buffer) bar))))) + +(defun gnus-xmas-mail-strip-quoted-names (address) + "Protect mail-strip-quoted-names from NIL input. +XEmacs compatibility workaround." + (if (null address) + nil + (mail-strip-quoted-names address))) + +(defun gnus-xmas-call-region (command &rest args) + (apply + 'call-process-region (point-min) (point-max) command t '(t nil) nil + args)) + +(defface gnus-x-face '((t (:foreground "black" :background "white"))) + "Face to show X face" + :group 'gnus-xmas) + +(defun gnus-xmas-article-display-xface (beg end) + "Display any XFace headers in the current article." + (save-excursion + (let ((xface-glyph + (cond ((featurep 'xface) + (make-glyph (vector 'xface :data + (concat "X-Face: " + (buffer-substring beg end))))) + ((featurep 'xpm) + (let ((cur (current-buffer))) + (save-excursion + (gnus-set-work-buffer) + (insert (format "%s" (buffer-substring beg end cur))) + (gnus-xmas-call-region "uncompface") + (goto-char (point-min)) + (insert "/* Width=48, Height=48 */\n") + (gnus-xmas-call-region "icontopbm") + (gnus-xmas-call-region "ppmtoxpm") + (make-glyph + (vector 'xpm :data (buffer-string)))))) + (t + (make-glyph [nothing]))))) + (set-glyph-face xface-glyph 'gnus-x-face) + (goto-char (point-min)) + (re-search-forward "^From:" nil t) + (set-extent-begin-glyph + (make-extent (point) (1+ (point))) xface-glyph)))) + +;;(defvar gnus-xmas-pointer-glyph +;; (progn +;; (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory +;; "gnus")) +;; (let ((file-xpm (expand-file-name "gnus-pointer.xpm" +;; gnus-xmas-glyph-directory)) +;; (file-xbm (expand-file-name "gnus-pointer.xbm" +;; gnus-xmas-glyph-directory))) +;; (make-pointer-glyph +;; (list (vector 'xpm ':file file-xpm) +;; (vector 'xbm ':file file-xbm)))))) + +(defvar gnus-xmas-modeline-left-extent + (let ((ext (copy-extent modeline-buffer-id-left-extent))) +; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph) + ext)) + +(defvar gnus-xmas-modeline-right-extent + (let ((ext (copy-extent modeline-buffer-id-right-extent))) +; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph) + ext)) + +(defvar gnus-xmas-modeline-glyph + (progn + (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) + (let* ((file-xpm (expand-file-name "gnus-pointer.xpm" + gnus-xmas-glyph-directory)) + (file-xbm (expand-file-name "gnus-pointer.xbm" + gnus-xmas-glyph-directory)) + (glyph (make-glyph + ;; Gag gag gag. + `( + ,@(if (featurep 'xpm) + ;; Let's try a nifty XPM + (list (vector 'xpm ':file file-xpm))) + ;; Then a not-so-nifty XBM + ,(vector 'xbm ':file file-xbm) + ;; Then the simple string + ,(vector 'string ':data "Gnus:"))))) + (set-glyph-face glyph 'modeline-buffer-id) + glyph))) + +(defun gnus-xmas-mode-line-buffer-identification (line) + (let ((line (car line)) + chop) + (cond + ;; This is some weird type of id. + ((not (stringp line)) + (list line)) + ;; This is non-standard, so we just pass it through. + ((not (string-match "^Gnus:" line)) + (list line)) + ;; We have a standard line, so we colorize and glyphize it a bit. + (t + (setq chop (match-end 0)) + (list + (if gnus-xmas-modeline-glyph + (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph) + (cons gnus-xmas-modeline-left-extent (substring line 0 chop))) + (cons gnus-xmas-modeline-right-extent (substring line chop))))))) + +(defun gnus-xmas-splash () + (when (eq (device-type) 'x) + (gnus-splash))) + +(provide 'gnus-xmas) + +;;; gnus-xmas.el ends here diff --git a/lisp/gnus.el b/lisp/gnus.el new file mode 100644 index 0000000..34e6cb9 --- /dev/null +++ b/lisp/gnus.el @@ -0,0 +1,2747 @@ +;;; gnus.el --- a newsreader for GNU Emacs +;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval '(run-hooks 'gnus-load-hook)) + +(eval-when-compile (require 'cl)) + +(require 'custom) +(require 'gnus-load) +(require 'message) + +(defgroup gnus nil + "The coffee-brewing, all singing, all dancing, kitchen sink newsreader." + :group 'news + :group 'mail) + +(defgroup gnus-start nil + "Starting your favorite newsreader." + :group 'gnus) + +(defgroup gnus-start-server nil + "Server options at startup." + :group 'gnus-start) + +;; These belong to gnus-group.el. +(defgroup gnus-group nil + "Group buffers." + :link '(custom-manual "(gnus)The Group Buffer") + :group 'gnus) + +(defgroup gnus-group-foreign nil + "Foreign groups." + :link '(custom-manual "(gnus)Foreign Groups") + :group 'gnus-group) + +(defgroup gnus-group-new nil + "Automatic subscription of new groups." + :group 'gnus-group) + +(defgroup gnus-group-levels nil + "Group levels." + :link '(custom-manual "(gnus)Group Levels") + :group 'gnus-group) + +(defgroup gnus-group-select nil + "Selecting a Group." + :link '(custom-manual "(gnus)Selecting a Group") + :group 'gnus-group) + +(defgroup gnus-group-listing nil + "Showing slices of the group list." + :link '(custom-manual "(gnus)Listing Groups") + :group 'gnus-group) + +(defgroup gnus-group-visual nil + "Sorting the group buffer." + :link '(custom-manual "(gnus)Group Buffer Format") + :group 'gnus-group + :group 'gnus-visual) + +(defgroup gnus-group-various nil + "Various group options." + :link '(custom-manual "(gnus)Scanning New Messages") + :group 'gnus-group) + +;; These belong to gnus-sum.el. +(defgroup gnus-summary nil + "Summary buffers." + :link '(custom-manual "(gnus)The Summary Buffer") + :group 'gnus) + +(defgroup gnus-summary-exit nil + "Leaving summary buffers." + :link '(custom-manual "(gnus)Exiting the Summary Buffer") + :group 'gnus-summary) + +(defgroup gnus-summary-marks nil + "Marks used in summary buffers." + :link '(custom-manual "(gnus)Marking Articles") + :group 'gnus-summary) + +(defgroup gnus-thread nil + "Ordering articles according to replies." + :link '(custom-manual "(gnus)Threading") + :group 'gnus-summary) + +(defgroup gnus-summary-format nil + "Formatting of the summary buffer." + :link '(custom-manual "(gnus)Summary Buffer Format") + :group 'gnus-summary) + +(defgroup gnus-summary-choose nil + "Choosing Articles." + :link '(custom-manual "(gnus)Choosing Articles") + :group 'gnus-summary) + +(defgroup gnus-summary-maneuvering nil + "Summary movement commands." + :link '(custom-manual "(gnus)Summary Maneuvering") + :group 'gnus-summary) + +(defgroup gnus-summary-mail nil + "Mail group commands." + :link '(custom-manual "(gnus)Mail Group Commands") + :group 'gnus-summary) + +(defgroup gnus-summary-sort nil + "Sorting the summary buffer." + :link '(custom-manual "(gnus)Sorting") + :group 'gnus-summary) + +(defgroup gnus-summary-visual nil + "Highlighting and menus in the summary buffer." + :link '(custom-manual "(gnus)Summary Highlighting") + :group 'gnus-visual + :group 'gnus-summary) + +(defgroup gnus-summary-various nil + "Various summary buffer options." + :link '(custom-manual "(gnus)Various Summary Stuff") + :group 'gnus-summary) + +(defgroup gnus-summary-pick nil + "Pick mode in the summary buffer." + :link '(custom-manual "(gnus)Pick and Read") + :prefix "gnus-pick-" + :group 'gnus-summary) + +(defgroup gnus-summary-tree nil + "Tree display of threads in the summary buffer." + :link '(custom-manual "(gnus)Tree Display") + :prefix "gnus-tree-" + :group 'gnus-summary) + +;; Belongs to gnus-uu.el +(defgroup gnus-extract-view nil + "Viewing extracted files." + :link '(custom-manual "(gnus)Viewing Files") + :group 'gnus-extract) + +;; Belongs to gnus-score.el +(defgroup gnus-score nil + "Score and kill file handling." + :group 'gnus) + +(defgroup gnus-score-kill nil + "Kill files." + :group 'gnus-score) + +(defgroup gnus-score-adapt nil + "Adaptive score files." + :group 'gnus-score) + +(defgroup gnus-score-default nil + "Default values for score files." + :group 'gnus-score) + +(defgroup gnus-score-expire nil + "Expiring score rules." + :group 'gnus-score) + +(defgroup gnus-score-decay nil + "Decaying score rules." + :group 'gnus-score) + +(defgroup gnus-score-files nil + "Score and kill file names." + :group 'gnus-score + :group 'gnus-files) + +(defgroup gnus-score-various nil + "Various scoring and killing options." + :group 'gnus-score) + +;; Other +(defgroup gnus-visual nil + "Options controling the visual fluff." + :group 'gnus + :group 'faces) + +(defgroup gnus-agent nil + "Offline support for Gnus." + :group 'gnus) + +(defgroup gnus-files nil + "Files used by Gnus." + :group 'gnus) + +(defgroup gnus-dribble-file nil + "Auto save file." + :link '(custom-manual "(gnus)Auto Save") + :group 'gnus-files) + +(defgroup gnus-newsrc nil + "Storing Gnus state." + :group 'gnus-files) + +(defgroup gnus-server nil + "Options related to newsservers and other servers used by Gnus." + :group 'gnus) + +(defgroup gnus-message '((message custom-group)) + "Composing replies and followups in Gnus." + :group 'gnus) + +(defgroup gnus-meta nil + "Meta variables controling major portions of Gnus. +In general, modifying these variables does not take affect until Gnus +is restarted, and sometimes reloaded." + :group 'gnus) + +(defgroup gnus-various nil + "Other Gnus options." + :link '(custom-manual "(gnus)Various Various") + :group 'gnus) + +(defgroup gnus-exit nil + "Exiting gnus." + :link '(custom-manual "(gnus)Exiting Gnus") + :group 'gnus) + +(defconst gnus-version-number "0.11" + "Version number for this version of Gnus.") + +(defconst gnus-version (format "Quassia Gnus v%s" gnus-version-number) + "Version string for this version of Gnus.") + +(defcustom gnus-inhibit-startup-message nil + "If non-nil, the startup message will not be displayed. +This variable is used before `.gnus.el' is loaded, so it should +be set in `.emacs' instead." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-play-startup-jingle nil + "If non-nil, play the Gnus jingle at startup." + :group 'gnus-start + :type 'boolean) + +;;; Kludges to help the transition from the old `custom.el'. + +(unless (featurep 'gnus-xmas) + (defalias 'gnus-make-overlay 'make-overlay) + (defalias 'gnus-overlay-put 'overlay-put) + (defalias 'gnus-move-overlay 'move-overlay) + (defalias 'gnus-overlay-end 'overlay-end) + (defalias 'gnus-extent-detached-p 'ignore) + (defalias 'gnus-extent-start-open 'ignore) + (defalias 'gnus-set-text-properties 'set-text-properties) + (defalias 'gnus-group-remove-excess-properties 'ignore) + (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window) + (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) + (defalias 'gnus-character-to-event 'identity) + (defalias 'gnus-add-text-properties 'add-text-properties) + (defalias 'gnus-put-text-property 'put-text-property) + (defalias 'gnus-mode-line-buffer-identification 'identity) + (defalias 'gnus-characterp 'numberp) + (defalias 'gnus-deactivate-mark 'deactivate-mark) + (defalias 'gnus-key-press-event-p 'numberp)) + +;; The XEmacs people think this is evil, so it must go. +(defun custom-face-lookup (&optional fg bg stipple bold italic underline) + "Lookup or create a face with specified attributes." + (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" + (or fg "default") + (or bg "default") + (or stipple "default") + bold italic underline)))) + (if (and (custom-facep name) + (fboundp 'make-face)) + () + (copy-face 'default name) + (when (and fg + (not (string-equal fg "default"))) + (ignore-errors + (set-face-foreground name fg))) + (when (and bg + (not (string-equal bg "default"))) + (ignore-errors + (set-face-background name bg))) + (when (and stipple + (not (string-equal stipple "default")) + (not (eq stipple 'custom:asis)) + (fboundp 'set-face-stipple)) + (set-face-stipple name stipple)) + (when (and bold + (not (eq bold 'custom:asis))) + (ignore-errors + (make-face-bold name))) + (when (and italic + (not (eq italic 'custom:asis))) + (ignore-errors + (make-face-italic name))) + (when (and underline + (not (eq underline 'custom:asis))) + (ignore-errors + (set-face-underline-p name t)))) + name)) + +;; We define these group faces here to avoid the display +;; update forced when creating new faces. + +(defface gnus-group-news-1-face + '((((class color) + (background dark)) + (:foreground "PaleTurquoise" :bold t)) + (((class color) + (background light)) + (:foreground "ForestGreen" :bold t)) + (t + ())) + "Level 1 newsgroup face.") + +(defface gnus-group-news-1-empty-face + '((((class color) + (background dark)) + (:foreground "PaleTurquoise")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + ())) + "Level 1 empty newsgroup face.") + +(defface gnus-group-news-2-face + '((((class color) + (background dark)) + (:foreground "turquoise" :bold t)) + (((class color) + (background light)) + (:foreground "CadetBlue4" :bold t)) + (t + ())) + "Level 2 newsgroup face.") + +(defface gnus-group-news-2-empty-face + '((((class color) + (background dark)) + (:foreground "turquoise")) + (((class color) + (background light)) + (:foreground "CadetBlue4")) + (t + ())) + "Level 2 empty newsgroup face.") + +(defface gnus-group-news-3-face + '((((class color) + (background dark)) + (:bold t)) + (((class color) + (background light)) + (:bold t)) + (t + ())) + "Level 3 newsgroup face.") + +(defface gnus-group-news-3-empty-face + '((((class color) + (background dark)) + ()) + (((class color) + (background light)) + ()) + (t + ())) + "Level 3 empty newsgroup face.") + +(defface gnus-group-news-low-face + '((((class color) + (background dark)) + (:foreground "DarkTurquoise" :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" :bold t)) + (t + ())) + "Low level newsgroup face.") + +(defface gnus-group-news-low-empty-face + '((((class color) + (background dark)) + (:foreground "DarkTurquoise")) + (((class color) + (background light)) + (:foreground "DarkGreen")) + (t + ())) + "Low level empty newsgroup face.") + +(defface gnus-group-mail-1-face + '((((class color) + (background dark)) + (:foreground "aquamarine1" :bold t)) + (((class color) + (background light)) + (:foreground "DeepPink3" :bold t)) + (t + (:bold t))) + "Level 1 mailgroup face.") + +(defface gnus-group-mail-1-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine1")) + (((class color) + (background light)) + (:foreground "DeepPink3")) + (t + (:italic t :bold t))) + "Level 1 empty mailgroup face.") + +(defface gnus-group-mail-2-face + '((((class color) + (background dark)) + (:foreground "aquamarine2" :bold t)) + (((class color) + (background light)) + (:foreground "HotPink3" :bold t)) + (t + (:bold t))) + "Level 2 mailgroup face.") + +(defface gnus-group-mail-2-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine2")) + (((class color) + (background light)) + (:foreground "HotPink3")) + (t + (:bold t))) + "Level 2 empty mailgroup face.") + +(defface gnus-group-mail-3-face + '((((class color) + (background dark)) + (:foreground "aquamarine3" :bold t)) + (((class color) + (background light)) + (:foreground "magenta4" :bold t)) + (t + (:bold t))) + "Level 3 mailgroup face.") + +(defface gnus-group-mail-3-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine3")) + (((class color) + (background light)) + (:foreground "magenta4")) + (t + ())) + "Level 3 empty mailgroup face.") + +(defface gnus-group-mail-low-face + '((((class color) + (background dark)) + (:foreground "aquamarine4" :bold t)) + (((class color) + (background light)) + (:foreground "DeepPink4" :bold t)) + (t + (:bold t))) + "Low level mailgroup face.") + +(defface gnus-group-mail-low-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine4")) + (((class color) + (background light)) + (:foreground "DeepPink4")) + (t + (:bold t))) + "Low level empty mailgroup face.") + +;; Summary mode faces. + +(defface gnus-summary-selected-face '((t + (:underline t))) + "Face used for selected articles.") + +(defface gnus-summary-cancelled-face + '((((class color)) + (:foreground "yellow" :background "black"))) + "Face used for cancelled articles.") + +(defface gnus-summary-high-ticked-face + '((((class color) + (background dark)) + (:foreground "pink" :bold t)) + (((class color) + (background light)) + (:foreground "firebrick" :bold t)) + (t + (:bold t))) + "Face used for high interest ticked articles.") + +(defface gnus-summary-low-ticked-face + '((((class color) + (background dark)) + (:foreground "pink" :italic t)) + (((class color) + (background light)) + (:foreground "firebrick" :italic t)) + (t + (:italic t))) + "Face used for low interest ticked articles.") + +(defface gnus-summary-normal-ticked-face + '((((class color) + (background dark)) + (:foreground "pink")) + (((class color) + (background light)) + (:foreground "firebrick")) + (t + ())) + "Face used for normal interest ticked articles.") + +(defface gnus-summary-high-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue" :bold t)) + (((class color) + (background light)) + (:foreground "RoyalBlue" :bold t)) + (t + (:bold t))) + "Face used for high interest ancient articles.") + +(defface gnus-summary-low-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue" :italic t)) + (((class color) + (background light)) + (:foreground "RoyalBlue" :italic t)) + (t + (:italic t))) + "Face used for low interest ancient articles.") + +(defface gnus-summary-normal-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue")) + (((class color) + (background light)) + (:foreground "RoyalBlue")) + (t + ())) + "Face used for normal interest ancient articles.") + +(defface gnus-summary-high-unread-face + '((t + (:bold t))) + "Face used for high interest unread articles.") + +(defface gnus-summary-low-unread-face + '((t + (:italic t))) + "Face used for low interest unread articles.") + +(defface gnus-summary-normal-unread-face + '((t + ())) + "Face used for normal interest unread articles.") + +(defface gnus-summary-high-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen" + :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" + :bold t)) + (t + (:bold t))) + "Face used for high interest read articles.") + +(defface gnus-summary-low-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen" + :italic t)) + (((class color) + (background light)) + (:foreground "DarkGreen" + :italic t)) + (t + (:italic t))) + "Face used for low interest read articles.") + +(defface gnus-summary-normal-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen")) + (((class color) + (background light)) + (:foreground "DarkGreen")) + (t + ())) + "Face used for normal interest read articles.") + + +;;; Splash screen. + +(defvar gnus-group-buffer "*Group*") + +(eval-and-compile + (autoload 'gnus-play-jingle "gnus-audio")) + +(defface gnus-splash-face + '((((class color) + (background dark)) + (:foreground "ForestGreen")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + ())) + "Level 1 newsgroup face.") + +(defun gnus-splash () + (save-excursion + (switch-to-buffer (get-buffer-create gnus-group-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (unless gnus-inhibit-startup-message + (gnus-group-startup-message) + (sit-for 0) + (when gnus-play-startup-jingle + (gnus-play-jingle)))))) + +(defun gnus-indent-rigidly (start end arg) + "Indent rigidly using only spaces and no tabs." + (save-excursion + (save-restriction + (narrow-to-region start end) + (let ((tab-width 8)) + (indent-rigidly start end arg) + ;; We translate tabs into spaces -- not everybody uses + ;; an 8-character tab. + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (replace-match " " t t)))))) + +(defvar gnus-simple-splash nil) + +(defun gnus-group-startup-message (&optional x y) + "Insert startup message in current buffer." + ;; Insert the message. + (erase-buffer) + (insert + (format " %s + _ ___ _ _ + _ ___ __ ___ __ _ ___ + __ _ ___ __ ___ + _ ___ _ + _ _ __ _ + ___ __ _ + __ _ + _ _ _ + _ _ _ + _ _ _ + __ ___ + _ _ _ _ + _ _ + _ _ + _ _ + _ + __ + +" + "")) + ;; And then hack it. + (gnus-indent-rigidly (point-min) (point-max) + (/ (max (- (window-width) (or x 46)) 0) 2)) + (goto-char (point-min)) + (forward-line 1) + (let* ((pheight (count-lines (point-min) (point-max))) + (wheight (window-height)) + (rest (- wheight pheight))) + (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))) + ;; Fontify some. + (put-text-property (point-min) (point-max) 'face 'gnus-splash-face) + (goto-char (point-min)) + (setq mode-line-buffer-identification (concat " " gnus-version)) + (setq gnus-simple-splash t) + (set-buffer-modified-p t)) + +(eval-when (load) + (let ((command (format "%s" this-command))) + (when (and (string-match "gnus" command) + (not (string-match "gnus-other-frame" command))) + (gnus-splash)))) + +;;; Do the rest. + +(require 'custom) +(require 'gnus-util) +(require 'nnheader) + +(defcustom gnus-home-directory "~/" + "Directory variable that specifies the \"home\" directory. +All other Gnus path variables are initialized from this variable." + :group 'gnus-files + :type 'directory) + +(defcustom gnus-directory (or (getenv "SAVEDIR") + (nnheader-concat gnus-home-directory "News/")) + "Directory variable from which all other Gnus file variables are derived." + :group 'gnus-files + :type 'directory) + +(defcustom gnus-default-directory nil + "*Default directory for all Gnus buffers." + :group 'gnus-files + :type '(choice (const :tag "current" nil) + directory)) + +;; Site dependent variables. These variables should be defined in +;; paths.el. + +(defvar gnus-default-nntp-server nil + "Specify a default NNTP server. +This variable should be defined in paths.el, and should never be set +by the user. +If you want to change servers, you should use `gnus-select-method'. +See the documentation to that variable.") + +;; Don't touch this variable. +(defvar gnus-nntp-service "nntp" + "NNTP service name (\"nntp\" or 119). +This is an obsolete variable, which is scarcely used. If you use an +nntp server for your newsgroup and want to change the port number +used to 899, you would say something along these lines: + + (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))") + +(defcustom gnus-nntpserver-file "/etc/nntpserver" + "A file with only the name of the nntp server in it." + :group 'gnus-files + :group 'gnus-server + :type 'file) + +;; This function is used to check both the environment variable +;; NNTPSERVER and the /etc/nntpserver file to see whether one can find +;; an nntp server name default. +(defun gnus-getenv-nntpserver () + (or (getenv "NNTPSERVER") + (and (file-readable-p gnus-nntpserver-file) + (save-excursion + (set-buffer (get-buffer-create " *gnus nntp*")) + (buffer-disable-undo (current-buffer)) + (insert-file-contents gnus-nntpserver-file) + (let ((name (buffer-string))) + (prog1 + (if (string-match "^[ \t\n]*$" name) + nil + name) + (kill-buffer (current-buffer)))))))) + +(defcustom gnus-select-method + (condition-case nil + (nconc + (list 'nntp (or (condition-case nil + (gnus-getenv-nntpserver) + (error nil)) + (when (and gnus-default-nntp-server + (not (string= gnus-default-nntp-server ""))) + gnus-default-nntp-server) + "news")) + (if (or (null gnus-nntp-service) + (equal gnus-nntp-service "nntp")) + nil + (list gnus-nntp-service))) + (error nil)) + "Default method for selecting a newsgroup. +This variable should be a list, where the first element is how the +news is to be fetched, the second is the address. + +For instance, if you want to get your news via NNTP from +\"flab.flab.edu\", you could say: + +\(setq gnus-select-method '(nntp \"flab.flab.edu\")) + +If you want to use your local spool, say: + +\(setq gnus-select-method (list 'nnspool (system-name))) + +If you use this variable, you must set `gnus-nntp-server' to nil. + +There is a lot more to know about select methods and virtual servers - +see the manual for details." + :group 'gnus-server + :type 'gnus-select-method) + +(defcustom gnus-message-archive-method + `(nnfolder + "archive" + (nnfolder-directory ,(nnheader-concat message-directory "archive")) + (nnfolder-active-file + ,(nnheader-concat message-directory "archive/active")) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t)) + "Method used for archiving messages you've sent. +This should be a mail method. + +It's probably not a very effective to change this variable once you've +run Gnus once. After doing that, you must edit this server from the +server buffer." + :group 'gnus-server + :group 'gnus-message + :type 'gnus-select-method) + +(defcustom gnus-message-archive-group nil + "*Name of the group in which to save the messages you've written. +This can either be a string; a list of strings; or an alist +of regexps/functions/forms to be evaluated to return a string (or a list +of strings). The functions are called with the name of the current +group (or nil) as a parameter. + +If you want to save your mail in one group and the news articles you +write in another group, you could say something like: + + \(setq gnus-message-archive-group + '((if (message-news-p) + \"misc-news\" + \"misc-mail\"))) + +Normally the group names returned by this variable should be +unprefixed -- which implicitly means \"store on the archive server\". +However, you may wish to store the message on some other server. In +that case, just return a fully prefixed name of the group -- +\"nnml+private:mail.misc\", for instance." + :group 'gnus-message + :type '(choice (const :tag "none" nil) + string)) + +(defcustom gnus-secondary-servers nil + "List of NNTP servers that the user can choose between interactively. +To make Gnus query you for a server, you have to give `gnus' a +non-numeric prefix - `C-u M-x gnus', in short." + :group 'gnus-server + :type '(repeat string)) + +(defcustom gnus-nntp-server nil + "*The name of the host running the NNTP server. +This variable is semi-obsolete. Use the `gnus-select-method' +variable instead." + :group 'gnus-server + :type '(choice (const :tag "disable" nil) + string)) + +(defcustom gnus-secondary-select-methods nil + "A list of secondary methods that will be used for reading news. +This is a list where each element is a complete select method (see +`gnus-select-method'). + +If, for instance, you want to read your mail with the nnml backend, +you could set this variable: + +\(setq gnus-secondary-select-methods '((nnml \"\")))" +:group 'gnus-server +:type '(repeat gnus-select-method)) + +(defvar gnus-backup-default-subscribed-newsgroups + '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus") + "Default default new newsgroups the first time Gnus is run. +Should be set in paths.el, and shouldn't be touched by the user.") + +(defcustom gnus-local-domain nil + "Local domain name without a host name. +The DOMAINNAME environment variable is used instead if it is defined. +If the `system-name' function returns the full Internet name, there is +no need to set this variable." + :group 'gnus-message + :type '(choice (const :tag "default" nil) + string)) + +(defvar gnus-local-organization nil + "String with a description of what organization (if any) the user belongs to. +Obsolete variable; use `message-user-organization' instead.") + +;; Customization variables + +(defcustom gnus-refer-article-method nil + "Preferred method for fetching an article by Message-ID. +If you are reading news from the local spool (with nnspool), fetching +articles by Message-ID is painfully slow. By setting this method to an +nntp method, you might get acceptable results. + +The value of this variable must be a valid select method as discussed +in the documentation of `gnus-select-method'." + :group 'gnus-server + :type '(choice (const :tag "default" nil) + gnus-select-method)) + +(defcustom gnus-group-faq-directory + '("/ftp@mirrors.aol.com:/pub/rtfm/usenet/" + "/ftp@sunsite.auc.dk:/pub/usenet/" + "/ftp@sunsite.doc.ic.ac.uk:/pub/usenet/news-faqs/" + "/ftp@src.doc.ic.ac.uk:/usenet/news-FAQS/" + "/ftp@ftp.seas.gwu.edu:/pub/rtfm/" + "/ftp@rtfm.mit.edu:/pub/usenet/" + "/ftp@ftp.uni-paderborn.de:/pub/FAQ/" + "/ftp@ftp.sunet.se:/pub/usenet/" + "/ftp@nctuccca.edu.tw:/USENET/FAQ/" + "/ftp@hwarang.postech.ac.kr:/pub/usenet/" + "/ftp@ftp.hk.super.net:/mirror/faqs/") + "Directory where the group FAQs are stored. +This will most commonly be on a remote machine, and the file will be +fetched by ange-ftp. + +This variable can also be a list of directories. In that case, the +first element in the list will be used by default. The others can +be used when being prompted for a site. + +Note that Gnus uses an aol machine as the default directory. If this +feels fundamentally unclean, just think of it as a way to finally get +something of value back from them. + +If the default site is too slow, try one of these: + + North America: mirrors.aol.com /pub/rtfm/usenet + ftp.seas.gwu.edu /pub/rtfm + rtfm.mit.edu /pub/usenet + Europe: ftp.uni-paderborn.de /pub/FAQ + src.doc.ic.ac.uk /usenet/news-FAQS + ftp.sunet.se /pub/usenet + sunsite.auc.dk /pub/usenet + Asia: nctuccca.edu.tw /USENET/FAQ + hwarang.postech.ac.kr /pub/usenet + ftp.hk.super.net /mirror/faqs" + :group 'gnus-group-various + :type '(choice directory + (repeat directory))) + +(defcustom gnus-use-cross-reference t + "*Non-nil means that cross referenced articles will be marked as read. +If nil, ignore cross references. If t, mark articles as read in +subscribed newsgroups. If neither t nor nil, mark as read in all +newsgroups." + :group 'gnus-server + :type '(choice (const :tag "off" nil) + (const :tag "subscribed" t) + (sexp :format "all" + :value always))) + +(defcustom gnus-process-mark ?# + "*Process mark." + :group 'gnus-group-visual + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-asynchronous nil + "*If non-nil, Gnus will supply backends with data needed for async article fetching." + :group 'gnus-asynchronous + :type 'boolean) + +(defcustom gnus-large-newsgroup 200 + "*The number of articles which indicates a large newsgroup. +If the number of articles in a newsgroup is greater than this value, +confirmation is required for selecting the newsgroup." + :group 'gnus-group-select + :type 'integer) + +(defcustom gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix))) + "*Non-nil means that the default name of a file to save articles in is the group name. +If it's nil, the directory form of the group name is used instead. + +If this variable is a list, and the list contains the element +`not-score', long file names will not be used for score files; if it +contains the element `not-save', long file names will not be used for +saving; and if it contains the element `not-kill', long file names +will not be used for kill files. + +Note that the default for this variable varies according to what system +type you're using. On `usg-unix-v' and `xenix' this variable defaults +to nil while on all other systems it defaults to t." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-kill-files-directory gnus-directory + "*Name of the directory where kill files will be stored (default \"~/News\")." + :group 'gnus-score-files + :group 'gnus-score-kill + :type 'directory) + +(defcustom gnus-save-score nil + "*If non-nil, save group scoring info." + :group 'gnus-score-various + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-use-undo t + "*If non-nil, allow undoing in Gnus group mode buffers." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-adaptive-scoring nil + "*If non-nil, use some adaptive scoring scheme. +If a list, then the values `word' and `line' are meaningful. The +former will perform adaption on individual words in the subject +header while `line' will perform adaption on several headers." + :group 'gnus-meta + :group 'gnus-score-adapt + :type '(set (const word) (const line))) + +(defcustom gnus-use-cache 'passive + "*If nil, Gnus will ignore the article cache. +If `passive', it will allow entering (and reading) articles +explicitly entered into the cache. If anything else, use the +cache to the full extent of the law." + :group 'gnus-meta + :group 'gnus-cache + :type '(choice (const :tag "off" nil) + (const :tag "passive" passive) + (const :tag "active" t))) + +(defcustom gnus-use-trees nil + "*If non-nil, display a thread tree buffer." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-grouplens nil + "*If non-nil, use GroupLens ratings." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-keep-backlog nil + "*If non-nil, Gnus will keep read articles for later re-retrieval. +If it is a number N, then Gnus will only keep the last N articles +read. If it is neither nil nor a number, Gnus will keep all read +articles. This is not a good idea." + :group 'gnus-meta + :type '(choice (const :tag "off" nil) + integer + (sexp :format "all" + :value t))) + +(defcustom gnus-use-nocem nil + "*If non-nil, Gnus will read NoCeM cancel messages." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-suppress-duplicates nil + "*If non-nil, Gnus will mark duplicate copies of the same article as read." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-demon nil + "If non-nil, Gnus might use some demons." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-scoring t + "*If non-nil, enable scoring." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-picons nil + "*If non-nil, display picons." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-summary-prepare-exit-hook + '(gnus-summary-expire-articles) + "A hook called when preparing to exit from the summary buffer. +It calls `gnus-summary-expire-articles' by default." + :group 'gnus-summary-exit + :type 'hook) + +(defcustom gnus-novice-user t + "*Non-nil means that you are a usenet novice. +If non-nil, verbose messages may be displayed and confirmations may be +required." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-expert-user nil + "*Non-nil means that you will never be asked for confirmation about anything. +And that means *anything*." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-interactive-catchup t + "*If non-nil, require your confirmation when catching up a group." + :group 'gnus-group-select + :type 'boolean) + +(defcustom gnus-interactive-exit t + "*If non-nil, require your confirmation when exiting Gnus." + :group 'gnus-exit + :type 'boolean) + +(defcustom gnus-extract-address-components 'gnus-extract-address-components + "*Function for extracting address components from a From header. +Two pre-defined function exist: `gnus-extract-address-components', +which is the default, quite fast, and too simplistic solution, and +`mail-extract-address-components', which works much better, but is +slower." + :group 'gnus-summary-format + :type '(radio (function-item gnus-extract-address-components) + (function-item mail-extract-address-components) + (function :tag "Other"))) + +(defcustom gnus-carpal nil + "*If non-nil, display clickable icons." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-shell-command-separator ";" + "String used to separate to shell commands." + :group 'gnus-files + :type 'string) + +(defcustom gnus-valid-select-methods + '(("nntp" post address prompt-address physical-address) + ("nnspool" post address) + ("nnvirtual" post-mail virtual prompt-address) + ("nnmbox" mail respool address) + ("nnml" mail respool address) + ("nnmh" mail respool address) + ("nndir" post-mail prompt-address physical-address) + ("nneething" none address prompt-address physical-address) + ("nndoc" none address prompt-address) + ("nnbabyl" mail address respool) + ("nnkiboze" post virtual) + ("nnsoup" post-mail address) + ("nndraft" post-mail) + ("nnfolder" mail respool address) + ("nngateway" none address prompt-address physical-address) + ("nnweb" none) + ("nnagent" post-mail)) + "An alist of valid select methods. +The first element of each list lists should be a string with the name +of the select method. The other elements may be the category of +this method (i. e., `post', `mail', `none' or whatever) or other +properties that this method has (like being respoolable). +If you implement a new select method, all you should have to change is +this variable. I think." + :group 'gnus-server + :type '(repeat (group (string :tag "Name") + (radio-button-choice (const :format "%v " post) + (const :format "%v " mail) + (const :format "%v " none) + (const post-mail)) + (checklist :inline t + (const :format "%v " address) + (const :format "%v " prompt-address) + (const :format "%v " physical-address) + (const :format "%v " virtual) + (const respool))))) + +(define-widget 'gnus-select-method 'list + "Widget for entering a select method." + :args `((choice :tag "Method" + ,@(mapcar (lambda (entry) + (list 'const :format "%v\n" + (intern (car entry)))) + gnus-valid-select-methods)) + (string :tag "Address") + (editable-list :inline t + (list :format "%v" + variable + (sexp :tag "Value"))))) + +(defcustom gnus-updated-mode-lines '(group article summary tree) + "List of buffers that should update their mode lines. +The list may contain the symbols `group', `article', `tree' and +`summary'. If the corresponding symbol is present, Gnus will keep +that mode line updated with information that may be pertinent. +If this variable is nil, screen refresh may be quicker." + :group 'gnus-various + :type '(set (const group) + (const article) + (const summary) + (const tree))) + +;; Added by Keinonen Kari . +(defcustom gnus-mode-non-string-length nil + "*Max length of mode-line non-string contents. +If this is nil, Gnus will take space as is needed, leaving the rest +of the modeline intact. Note that the default of nil is unlikely +to be desirable; see the manual for further details." + :group 'gnus-various + :type '(choice (const nil) + integer)) + +(defcustom gnus-auto-expirable-newsgroups nil + "*Groups in which to automatically mark read articles as expirable. +If non-nil, this should be a regexp that should match all groups in +which to perform auto-expiry. This only makes sense for mail groups." + :group 'nnmail-expire + :type '(choice (const nil) + regexp)) + +(defcustom gnus-total-expirable-newsgroups nil + "*Groups in which to perform expiry of all read articles. +Use with extreme caution. All groups that match this regexp will be +expiring - which means that all read articles will be deleted after +\(say) one week. (This only goes for mail groups and the like, of +course.)" + :group 'nnmail-expire + :type '(choice (const nil) + regexp)) + +(defcustom gnus-group-uncollapsed-levels 1 + "Number of group name elements to leave alone when making a short group name." + :group 'gnus-group-visual + :type 'integer) + +(defcustom gnus-group-use-permanent-levels nil + "*If non-nil, once you set a level, Gnus will use this level." + :group 'gnus-group-levels + :type 'boolean) + +;; Hooks. + +(defcustom gnus-load-hook nil + "A hook run while Gnus is loaded." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-apply-kill-hook '(gnus-apply-kill-file) + "A hook called to apply kill files to a group. +This hook is intended to apply a kill file to the selected newsgroup. +The function `gnus-apply-kill-file' is called by default. + +Since a general kill file is too heavy to use only for a few +newsgroups, I recommend you to use a lighter hook function. For +example, if you'd like to apply a kill file to articles which contains +a string `rmgroup' in subject in newsgroup `control', you can use the +following hook: + + (setq gnus-apply-kill-hook + (list + (lambda () + (cond ((string-match \"control\" gnus-newsgroup-name) + (gnus-kill \"Subject\" \"rmgroup\") + (gnus-expunge \"X\"))))))" + :group 'gnus-score-kill + :options '(gnus-apply-kill-file) + :type 'hook) + +(defcustom gnus-group-change-level-function nil + "Function run when a group level is changed. +It is called with three parameters -- GROUP, LEVEL and OLDLEVEL." + :group 'gnus-group-level + :type 'function) + +;;; Face thingies. + +(defcustom gnus-visual + '(summary-highlight group-highlight article-highlight + mouse-face + summary-menu group-menu article-menu + tree-highlight menu highlight + browse-menu server-menu + page-marker tree-menu binary-menu pick-menu + grouplens-menu) + "Enable visual features. +If `visual' is disabled, there will be no menus and few faces. Most of +the visual customization options below will be ignored. Gnus will use +less space and be faster as a result. + +This variable can also be a list of visual elements to switch on. For +instance, to switch off all visual things except menus, you can say: + + (setq gnus-visual '(menu)) + +Valid elements include `summary-highlight', `group-highlight', +`article-highlight', `mouse-face', `summary-menu', `group-menu', +`article-menu', `tree-highlight', `menu', `highlight', `browse-menu', +`server-menu', `page-marker', `tree-menu', `binary-menu', `pick-menu', +and `grouplens-menu'." + :group 'gnus-meta + :group 'gnus-visual + :type '(set (const summary-highlight) + (const group-highlight) + (const article-highlight) + (const mouse-face) + (const summary-menu) + (const group-menu) + (const article-menu) + (const tree-highlight) + (const menu) + (const highlight) + (const browse-menu) + (const server-menu) + (const page-marker) + (const tree-menu) + (const binary-menu) + (const pick-menu) + (const grouplens-menu))) + +(defcustom gnus-mouse-face + (condition-case () + (if (gnus-visual-p 'mouse-face 'highlight) + (if (boundp 'gnus-mouse-face) + (or gnus-mouse-face 'highlight) + 'highlight) + 'default) + (error 'highlight)) + "Face used for group or summary buffer mouse highlighting. +The line beneath the mouse pointer will be highlighted with this +face." + :group 'gnus-visual + :type 'face) + +(defcustom gnus-article-display-hook + (if (and (string-match "XEmacs" emacs-version) + (featurep 'xface)) + '(gnus-article-hide-headers-if-wanted + gnus-article-hide-boring-headers + gnus-article-treat-overstrike + gnus-article-maybe-highlight + gnus-article-display-x-face) + '(gnus-article-hide-headers-if-wanted + gnus-article-hide-boring-headers + gnus-article-treat-overstrike + gnus-article-maybe-highlight)) + "Controls how the article buffer will look. + +If you leave the list empty, the article will appear exactly as it is +stored on the disk. The list entries will hide or highlight various +parts of the article, making it easier to find the information you +want." + :group 'gnus-article-highlight + :group 'gnus-visual + :type 'hook + :options '(gnus-article-add-buttons + gnus-article-add-buttons-to-head + gnus-article-emphasize + gnus-article-fill-cited-article + gnus-article-remove-cr + gnus-article-de-quoted-unreadable + gnus-summary-stop-page-breaking + ;; gnus-summary-caesar-message + ;; gnus-summary-verbose-headers + gnus-summary-toggle-mime + gnus-article-hide + gnus-article-hide-headers + gnus-article-hide-boring-headers + gnus-article-hide-signature + gnus-article-hide-citation + gnus-article-hide-pgp + gnus-article-hide-pem + gnus-article-highlight + gnus-article-highlight-headers + gnus-article-highlight-citation + gnus-article-highlight-signature + gnus-article-date-ut + gnus-article-date-local + gnus-article-date-lapsed + gnus-article-date-original + gnus-article-remove-trailing-blank-lines + gnus-article-strip-leading-blank-lines + gnus-article-strip-multiple-blank-lines + gnus-article-strip-blank-lines + gnus-article-treat-overstrike + gnus-article-display-x-face + gnus-smiley-display)) + +(defcustom gnus-article-save-directory gnus-directory + "*Name of the directory articles will be saved in (default \"~/News\")." + :group 'gnus-article-saving + :type 'directory) + + +;;; Internal variables + +(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) +(defvar gnus-original-article-buffer " *Original Article*") +(defvar gnus-newsgroup-name nil) + +(defvar gnus-agent nil + "Whether we want to use the Gnus agent or not.") + +(defvar gnus-command-method nil + "Dynamically bound variable that says what the current backend is.") + +(defvar gnus-current-select-method nil + "The current method for selecting a newsgroup.") + +(defvar gnus-tree-buffer "*Tree*" + "Buffer where Gnus thread trees are displayed.") + +;; Dummy variable. +(defvar gnus-use-generic-from nil) + +;; Variable holding the user answers to all method prompts. +(defvar gnus-method-history nil) +(defvar gnus-group-history nil) + +;; Variable holding the user answers to all mail method prompts. +(defvar gnus-mail-method-history nil) + +;; Variable holding the user answers to all group prompts. +(defvar gnus-group-history nil) + +(defvar gnus-server-alist nil + "List of available servers.") + +(defvar gnus-predefined-server-alist + `(("cache" + (nnspool "cache" + (nnspool-spool-directory "~/News/cache/") + (nnspool-nov-directory "~/News/cache/") + (nnspool-active-file "~/News/cache/active")))) + "List of predefined (convenience) servers.") + +(defvar gnus-topic-indentation "") ;; Obsolete variable. + +(defconst gnus-article-mark-lists + '((marked . tick) (replied . reply) + (expirable . expire) (killed . killed) + (bookmarks . bookmark) (dormant . dormant) + (scored . score) (saved . save) + (cached . cache) (downloadable . download) + (unsendable . unsend))) + +(defvar gnus-headers-retrieved-by nil) +(defvar gnus-article-reply nil) +(defvar gnus-override-method nil) +(defvar gnus-article-check-size nil) +(defvar gnus-opened-servers nil) + +(defvar gnus-current-kill-article nil) + +(defvar gnus-have-read-active-file nil) + +(defconst gnus-maintainer + "bugs@gnus.org (The Gnus Bugfixing Girls + Boys)" + "The mail address of the Gnus maintainers.") + +(defvar gnus-info-nodes + '((gnus-group-mode "(gnus)The Group Buffer") + (gnus-summary-mode "(gnus)The Summary Buffer") + (gnus-article-mode "(gnus)The Article Buffer") + (mime/viewer-mode "(gnus)The Article Buffer") + (gnus-server-mode "(gnus)The Server Buffer") + (gnus-browse-mode "(gnus)Browse Foreign Server") + (gnus-tree-mode "(gnus)Tree Display")) + "Alist of major modes and related Info nodes.") + +(defvar gnus-group-buffer "*Group*") +(defvar gnus-summary-buffer "*Summary*") +(defvar gnus-article-buffer "*Article*") +(defvar gnus-server-buffer "*Server*") + +(defvar gnus-buffer-list nil + "Gnus buffers that should be killed on exit.") + +(defvar gnus-slave nil + "Whether this Gnus is a slave or not.") + +(defvar gnus-batch-mode nil + "Whether this Gnus is running in batch mode or not.") + +(defvar gnus-variable-list + '(gnus-newsrc-options gnus-newsrc-options-n + gnus-newsrc-last-checked-date + gnus-newsrc-alist gnus-server-alist + gnus-killed-list gnus-zombie-list + gnus-topic-topology gnus-topic-alist + gnus-format-specs) + "Gnus variables saved in the quick startup file.") + +(defvar gnus-newsrc-alist nil + "Assoc list of read articles. +gnus-newsrc-hashtb should be kept so that both hold the same information.") + +(defvar gnus-newsrc-hashtb nil + "Hashtable of gnus-newsrc-alist.") + +(defvar gnus-killed-list nil + "List of killed newsgroups.") + +(defvar gnus-killed-hashtb nil + "Hash table equivalent of gnus-killed-list.") + +(defvar gnus-zombie-list nil + "List of almost dead newsgroups.") + +(defvar gnus-description-hashtb nil + "Descriptions of newsgroups.") + +(defvar gnus-list-of-killed-groups nil + "List of newsgroups that have recently been killed by the user.") + +(defvar gnus-active-hashtb nil + "Hashtable of active articles.") + +(defvar gnus-moderated-hashtb nil + "Hashtable of moderated newsgroups.") + +;; Save window configuration. +(defvar gnus-prev-winconf nil) + +(defvar gnus-reffed-article-number nil) + +;;; Let the byte-compiler know that we know about this variable. +(defvar rmail-default-rmail-file) + +(defvar gnus-dead-summary nil) + +;;; End of variables. + +;; Define some autoload functions Gnus might use. +(eval-and-compile + + ;; This little mapcar goes through the list below and marks the + ;; symbols in question as autoloaded functions. + (mapcar + (lambda (package) + (let ((interactive (nth 1 (memq ':interactive package)))) + (mapcar + (lambda (function) + (let (keymap) + (when (consp function) + (setq keymap (car (memq 'keymap function))) + (setq function (car function))) + (autoload function (car package) nil interactive keymap))) + (if (eq (nth 1 package) ':interactive) + (cdddr package) + (cdr package))))) + '(("metamail" metamail-buffer) + ("info" Info-goto-node) + ("hexl" hexl-hex-string-to-integer) + ("pp" pp pp-to-string pp-eval-expression) + ("ps-print" ps-print-preprint) + ("mail-extr" mail-extract-address-components) + ("message" :interactive t + message-send-and-exit message-yank-original) + ("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time) + ("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers) + ("timezone" timezone-make-date-arpa-standard timezone-fix-time + timezone-make-sortable-date timezone-make-time-string) + ("rmailout" rmail-output) + ("rmail" rmail-insert-rmail-file-header rmail-count-new-messages + rmail-show-message) + ("gnus-audio" :interactive t gnus-audio-play) + ("gnus-xmas" gnus-xmas-splash) + ("gnus-soup" :interactive t + gnus-group-brew-soup gnus-brew-soup gnus-soup-add-article + gnus-soup-send-replies gnus-soup-save-areas gnus-soup-pack-packet) + ("nnsoup" nnsoup-pack-replies) + ("score-mode" :interactive t gnus-score-mode) + ("gnus-mh" gnus-summary-save-article-folder + gnus-Folder-save-name gnus-folder-save-name) + ("gnus-mh" :interactive t gnus-summary-save-in-folder) + ("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail + gnus-demon-add-rescan gnus-demon-add-scan-timestamps + gnus-demon-add-disconnection gnus-demon-add-handler + gnus-demon-remove-handler) + ("gnus-demon" :interactive t + gnus-demon-init gnus-demon-cancel) + ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree + gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) + ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close + gnus-nocem-unwanted-article-p) + ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info + gnus-server-server-name) + ("gnus-srvr" gnus-browse-foreign-server) + ("gnus-cite" :interactive t + gnus-article-highlight-citation gnus-article-hide-citation-maybe + gnus-article-hide-citation gnus-article-fill-cited-article + gnus-article-hide-citation-in-followups) + ("gnus-kill" gnus-kill gnus-apply-kill-file-internal + gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author + gnus-execute gnus-expunge) + ("gnus-cache" gnus-cache-possibly-enter-article gnus-cache-save-buffers + gnus-cache-possibly-remove-articles gnus-cache-request-article + gnus-cache-retrieve-headers gnus-cache-possibly-alter-active + gnus-cache-enter-remove-article gnus-cached-article-p + gnus-cache-open gnus-cache-close gnus-cache-update-article) + ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article + gnus-cache-remove-article gnus-summary-insert-cached-articles) + ("gnus-score" :interactive t + gnus-summary-increase-score gnus-summary-set-score + gnus-summary-raise-thread gnus-summary-raise-same-subject + gnus-summary-raise-score gnus-summary-raise-same-subject-and-select + gnus-summary-lower-thread gnus-summary-lower-same-subject + gnus-summary-lower-score gnus-summary-lower-same-subject-and-select + gnus-summary-current-score gnus-score-default + gnus-score-flush-cache gnus-score-close + gnus-possibly-score-headers gnus-score-followup-article + gnus-score-followup-thread) + ("gnus-score" + (gnus-summary-score-map keymap) gnus-score-save gnus-score-headers + gnus-current-score-file-nondirectory gnus-score-adaptive + gnus-score-find-trace gnus-score-file-name) + ("gnus-cus" :interactive t gnus-group-customize gnus-score-customize) + ("gnus-topic" :interactive t gnus-topic-mode) + ("gnus-topic" gnus-topic-remove-group gnus-topic-set-parameters) + ("gnus-salt" :interactive t gnus-pick-mode gnus-binary-mode) + ("gnus-uu" (gnus-uu-extract-map keymap) (gnus-uu-mark-map keymap)) + ("gnus-uu" :interactive t + gnus-uu-digest-mail-forward gnus-uu-digest-post-forward + gnus-uu-mark-series gnus-uu-mark-region gnus-uu-mark-buffer + gnus-uu-mark-by-regexp gnus-uu-mark-all + gnus-uu-mark-sparse gnus-uu-mark-thread gnus-uu-decode-uu + gnus-uu-decode-uu-and-save gnus-uu-decode-unshar + gnus-uu-decode-unshar-and-save gnus-uu-decode-save + gnus-uu-decode-binhex gnus-uu-decode-uu-view + gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view + gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view + gnus-uu-decode-binhex-view) + ("gnus-uu" gnus-uu-delete-work-dir gnus-quote-arg-for-sh-or-csh) + ("gnus-msg" (gnus-summary-send-map keymap) + gnus-article-mail gnus-copy-article-buffer gnus-extended-version) + ("gnus-msg" :interactive t + gnus-group-post-news gnus-group-mail gnus-summary-post-news + gnus-summary-followup gnus-summary-followup-with-original + gnus-summary-cancel-article gnus-summary-supersede-article + gnus-post-news gnus-summary-reply gnus-summary-reply-with-original + gnus-summary-mail-forward gnus-summary-mail-other-window + gnus-summary-resend-message gnus-summary-resend-bounced-mail + gnus-bug) + ("gnus-picon" :interactive t gnus-article-display-picons + gnus-group-display-picons gnus-picons-article-display-x-face + gnus-picons-display-x-face) + ("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p + gnus-grouplens-mode) + ("smiley" :interactive t gnus-smiley-display) + ("gnus-win" gnus-configure-windows gnus-add-configuration) + ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group + gnus-list-of-unread-articles gnus-list-of-read-articles + gnus-offer-save-summaries gnus-make-thread-indent-array + gnus-summary-exit gnus-update-read-articles) + ("gnus-group" gnus-group-insert-group-line gnus-group-quit + gnus-group-list-groups gnus-group-first-unread-group + gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc + gnus-group-setup-buffer gnus-group-get-new-news + gnus-group-make-help-group gnus-group-update-group) + ("gnus-bcklg" gnus-backlog-request-article gnus-backlog-enter-article + gnus-backlog-remove-article) + ("gnus-art" gnus-article-read-summary-keys gnus-article-save + gnus-article-prepare gnus-article-set-window-start + gnus-article-next-page gnus-article-prev-page + gnus-request-article-this-buffer gnus-article-mode + gnus-article-setup-buffer gnus-narrow-to-page + gnus-article-delete-invisible-text gnus-hack-decode-rfc1522) + ("gnus-art" :interactive t + gnus-article-hide-headers gnus-article-hide-boring-headers + gnus-article-treat-overstrike gnus-article-word-wrap + gnus-article-remove-cr gnus-article-remove-trailing-blank-lines + gnus-article-display-x-face gnus-article-de-quoted-unreadable + gnus-article-mime-decode-quoted-printable gnus-article-hide-pgp + gnus-article-hide-pem gnus-article-hide-signature + gnus-article-strip-leading-blank-lines gnus-article-date-local + gnus-article-date-original gnus-article-date-lapsed + gnus-article-show-all-headers + gnus-article-edit-mode gnus-article-edit-article + gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522) + ("gnus-int" gnus-request-type) + ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 + gnus-dribble-enter) + ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article + gnus-dup-enter-articles) + ("gnus-range" gnus-copy-sequence) + ("gnus-eform" gnus-edit-form) + ("gnus-move" :interactive t + gnus-group-move-group-to-server gnus-change-server) + ("gnus-logic" gnus-score-advanced) + ("gnus-undo" gnus-undo-mode gnus-undo-register) + ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next + gnus-async-prefetch-article gnus-async-prefetch-remove-group + gnus-async-halt-prefetch) + ("gnus-agent" gnus-open-agent gnus-agent-get-function + gnus-agent-save-groups gnus-agent-save-active gnus-agent-method-p + gnus-agent-get-undownloaded-list) + ("gnus-agent" :interactive t + gnus-unplugged gnus-agentize) + ("gnus-vm" :interactive t gnus-summary-save-in-vm + gnus-summary-save-article-vm) + ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts)))) + +;;; gnus-sum.el thingies + + +(defcustom gnus-summary-line-format "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + "*The format specification of the lines in the summary buffer. + +It works along the same lines as a normal formatting string, +with some simple extensions. + +%N Article number, left padded with spaces (string) +%S Subject (string) +%s Subject if it is at the root of a thread, and \"\" otherwise (string) +%n Name of the poster (string) +%a Extracted name of the poster (string) +%A Extracted address of the poster (string) +%F Contents of the From: header (string) +%x Contents of the Xref: header (string) +%D Date of the article (string) +%d Date of the article (string) in DD-MMM format +%M Message-id of the article (string) +%r References of the article (string) +%c Number of characters in the article (integer) +%L Number of lines in the article (integer) +%I Indentation based on thread level (a string of spaces) +%T A string with two possible values: 80 spaces if the article + is on thread level two or larger and 0 spaces on level one +%R \"A\" if this article has been replied to, \" \" otherwise (character) +%U Status of this article (character, \"R\", \"K\", \"-\" or \" \") +%[ Opening bracket (character, \"[\" or \"<\") +%] Closing bracket (character, \"]\" or \">\") +%> Spaces of length thread-level (string) +%< Spaces of length (- 20 thread-level) (string) +%i Article score (number) +%z Article zcore (character) +%t Number of articles under the current thread (number). +%e Whether the thread is empty or not (character). +%l GroupLens score (string). +%V Total thread score (number). +%P The line number (number). +%O Download mark (character). +%u User defined specifier. The next character in the format string should + be a letter. Gnus will call the function gnus-user-format-function-X, + where X is the letter following %u. The function will be passed the + current header as argument. The function should return a string, which + will be inserted into the summary just like information from any other + summary specifier. + +Text between %( and %) will be highlighted with `gnus-mouse-face' +when the mouse point is placed inside the area. There can only be one +such area. + +The %U (status), %R (replied) and %z (zcore) specs have to be handled +with care. For reasons of efficiency, Gnus will compute what column +these characters will end up in, and \"hard-code\" that. This means that +it is illegal to have these specs after a variable-length spec. Well, +you might not be arrested, but your summary buffer will look strange, +which is bad enough. + +The smart choice is to have these specs as for to the left as +possible. + +This restriction may disappear in later versions of Gnus." + :type 'string + :group 'gnus-summary-format) + +;;; +;;; Skeleton keymaps +;;; + +(defun gnus-suppress-keymap (keymap) + (suppress-keymap keymap) + (let ((keys `([delete] "\177" "\M-u"))) ;gnus-mouse-2 + (while keys + (define-key keymap (pop keys) 'undefined)))) + +(defvar gnus-article-mode-map + (let ((keymap (make-keymap))) + (gnus-suppress-keymap keymap) + keymap)) +(defvar gnus-summary-mode-map + (let ((keymap (make-keymap))) + (gnus-suppress-keymap keymap) + keymap)) +(defvar gnus-group-mode-map + (let ((keymap (make-keymap))) + (gnus-suppress-keymap keymap) + keymap)) + + + +;; Fix by Hallvard B Furuseth . +;; If you want the cursor to go somewhere else, set these two +;; functions in some startup hook to whatever you want. +(defalias 'gnus-summary-position-point 'gnus-goto-colon) +(defalias 'gnus-group-position-point 'gnus-goto-colon) + +;;; Various macros and substs. + +(defun gnus-header-from (header) + (mail-header-from header)) + +(defmacro gnus-gethash (string hashtable) + "Get hash value of STRING in HASHTABLE." + `(symbol-value (intern-soft ,string ,hashtable))) + +(defmacro gnus-sethash (string value hashtable) + "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." + `(set (intern ,string ,hashtable) ,value)) +(put 'gnus-sethash 'edebug-form-spec '(form form form)) + +(defmacro gnus-group-unread (group) + "Get the currently computed number of unread articles in GROUP." + `(car (gnus-gethash ,group gnus-newsrc-hashtb))) + +(defmacro gnus-group-entry (group) + "Get the newsrc entry for GROUP." + `(gnus-gethash ,group gnus-newsrc-hashtb)) + +(defmacro gnus-active (group) + "Get active info on GROUP." + `(gnus-gethash ,group gnus-active-hashtb)) + +(defmacro gnus-set-active (group active) + "Set GROUP's active info." + `(gnus-sethash ,group ,active gnus-active-hashtb)) + +(defun gnus-alive-p () + "Say whether Gnus is running or not." + (and gnus-group-buffer + (get-buffer gnus-group-buffer) + (save-excursion + (set-buffer gnus-group-buffer) + (eq major-mode 'gnus-group-mode)))) + +;; Info access macros. + +(defmacro gnus-info-group (info) + `(nth 0 ,info)) +(defmacro gnus-info-rank (info) + `(nth 1 ,info)) +(defmacro gnus-info-read (info) + `(nth 2 ,info)) +(defmacro gnus-info-marks (info) + `(nth 3 ,info)) +(defmacro gnus-info-method (info) + `(nth 4 ,info)) +(defmacro gnus-info-params (info) + `(nth 5 ,info)) + +(defmacro gnus-info-level (info) + `(let ((rank (gnus-info-rank ,info))) + (if (consp rank) + (car rank) + rank))) +(defmacro gnus-info-score (info) + `(let ((rank (gnus-info-rank ,info))) + (or (and (consp rank) (cdr rank)) 0))) + +(defmacro gnus-info-set-group (info group) + `(setcar ,info ,group)) +(defmacro gnus-info-set-rank (info rank) + `(setcar (nthcdr 1 ,info) ,rank)) +(defmacro gnus-info-set-read (info read) + `(setcar (nthcdr 2 ,info) ,read)) +(defmacro gnus-info-set-marks (info marks &optional extend) + (if extend + `(gnus-info-set-entry ,info ,marks 3) + `(setcar (nthcdr 3 ,info) ,marks))) +(defmacro gnus-info-set-method (info method &optional extend) + (if extend + `(gnus-info-set-entry ,info ,method 4) + `(setcar (nthcdr 4 ,info) ,method))) +(defmacro gnus-info-set-params (info params &optional extend) + (if extend + `(gnus-info-set-entry ,info ,params 5) + `(setcar (nthcdr 5 ,info) ,params))) + +(defun gnus-info-set-entry (info entry number) + ;; Extend the info until we have enough elements. + (while (<= (length info) number) + (nconc info (list nil))) + ;; Set the entry. + (setcar (nthcdr number info) entry)) + +(defmacro gnus-info-set-level (info level) + `(let ((rank (cdr ,info))) + (if (consp (car rank)) + (setcar (car rank) ,level) + (setcar rank ,level)))) +(defmacro gnus-info-set-score (info score) + `(let ((rank (cdr ,info))) + (if (consp (car rank)) + (setcdr (car rank) ,score) + (setcar rank (cons (car rank) ,score))))) + +(defmacro gnus-get-info (group) + `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) + +;; Byte-compiler warning. +(defvar gnus-visual) +;; Find out whether the gnus-visual TYPE is wanted. +(defun gnus-visual-p (&optional type class) + (and gnus-visual ; Has to be non-nil, at least. + (if (not type) ; We don't care about type. + gnus-visual + (if (listp gnus-visual) ; It's a list, so we check it. + (or (memq type gnus-visual) + (memq class gnus-visual)) + t)))) + +;;; Load the compatability functions. + +(require 'gnus-ems) + + +;;; +;;; Shutdown +;;; + +(defvar gnus-shutdown-alist nil) + +(defun gnus-add-shutdown (function &rest symbols) + "Run FUNCTION whenever one of SYMBOLS is shut down." + (push (cons function symbols) gnus-shutdown-alist)) + +(defun gnus-shutdown (symbol) + "Shut down everything that waits for SYMBOL." + (let ((alist gnus-shutdown-alist) + entry) + (while (setq entry (pop alist)) + (when (memq symbol (cdr entry)) + (funcall (car entry)))))) + + +;;; +;;; Gnus Utility Functions +;;; + +(defmacro gnus-string-or (&rest strings) + "Return the first element of STRINGS that is a non-blank string. +STRINGS will be evaluated in normal `or' order." + `(gnus-string-or-1 ',strings)) + +(defun gnus-string-or-1 (strings) + (let (string) + (while strings + (setq string (eval (pop strings))) + (if (string-match "^[ \t]*$" string) + (setq string nil) + (setq strings nil))) + string)) + +;; Add the current buffer to the list of buffers to be killed on exit. +(defun gnus-add-current-to-buffer-list () + (or (memq (current-buffer) gnus-buffer-list) + (push (current-buffer) gnus-buffer-list))) + +(defun gnus-version (&optional arg) + "Version number of this version of Gnus. +If ARG, insert string at point." + (interactive "P") + (let ((methods gnus-valid-select-methods) + (mess gnus-version) + meth) + ;; Go through all the legal select methods and add their version + ;; numbers to the total version string. Only the backends that are + ;; currently in use will have their message numbers taken into + ;; consideration. + (while methods + (setq meth (intern (concat (caar methods) "-version"))) + (and (boundp meth) + (stringp (symbol-value meth)) + (setq mess (concat mess "; " (symbol-value meth)))) + (setq methods (cdr methods))) + (if arg + (insert (message mess)) + (message mess)))) + +(defun gnus-continuum-version (version) + "Return VERSION as a floating point number." + (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) + (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version)) + (let* ((alpha (and (match-beginning 1) (match-string 1 version))) + (number (match-string 2 version)) + major minor least) + (string-match "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number) + (setq major (string-to-number (match-string 1 number))) + (setq minor (string-to-number (match-string 2 number))) + (setq least (if (match-beginning 3) + (string-to-number (match-string 3 number)) + 0)) + (string-to-number + (if (zerop major) + (format "%s00%02d%02d" + (cond + ((member alpha '("(ding)" "d")) "4.99") + ((member alpha '("September" "s")) "5.01") + ((member alpha '("Red" "r")) "5.03")) + minor least) + (format "%d.%02d%02d" major minor least)))))) + +(defun gnus-info-find-node () + "Find Info documentation of Gnus." + (interactive) + ;; Enlarge info window if needed. + (let (gnus-info-buffer) + (Info-goto-node (cadr (assq major-mode gnus-info-nodes))) + (setq gnus-info-buffer (current-buffer)) + (gnus-configure-windows 'info))) + +;;; +;;; gnus-interactive +;;; + +(defvar gnus-current-prefix-symbol nil + "Current prefix symbol.") + +(defvar gnus-current-prefix-symbols nil + "List of current prefix symbols.") + +(defun gnus-interactive (string &optional params) + "Return a list that can be fed to `interactive'. +See `interactive' for full documentation. + +Adds the following specs: + +y -- The current symbolic prefix. +Y -- A list of the current symbolic prefix(es). +A -- Article number. +H -- Article header. +g -- Group name." + (let ((i 0) + out c prompt) + (while (< i (length string)) + (string-match ".\\([^\n]*\\)\n?" string i) + (setq c (aref string i)) + (when (match-end 1) + (setq prompt (match-string 1 string))) + (setq i (match-end 0)) + ;; We basically emulate just about everything that + ;; `interactive' does, but adds the "g" and "G" specs. + (push + (cond + ((= c ?a) + (completing-read prompt obarray 'fboundp t)) + ((= c ?b) + (read-buffer prompt (current-buffer) t)) + ((= c ?B) + (read-buffer prompt (other-buffer (current-buffer)))) + ((= c ?c) + (read-char)) + ((= c ?C) + (completing-read prompt obarray 'commandp t)) + ((= c ?d) + (point)) + ((= c ?D) + (read-file-name prompt nil default-directory 'lambda)) + ((= c ?f) + (read-file-name prompt nil nil 'lambda)) + ((= c ?F) + (read-file-name prompt)) + ((= c ?k) + (read-key-sequence prompt)) + ((= c ?K) + (error "Not implemented spec")) + ((= c ?e) + (error "Not implemented spec")) + ((= c ?m) + (mark)) + ((= c ?N) + (error "Not implemented spec")) + ((= c ?n) + (string-to-number (read-from-minibuffer prompt))) + ((= c ?p) + (prefix-numeric-value current-prefix-arg)) + ((= c ?P) + current-prefix-arg) + ((= c ?r) + 'gnus-prefix-nil) + ((= c ?s) + (read-string prompt)) + ((= c ?S) + (intern (read-string prompt))) + ((= c ?v) + (read-variable prompt)) + ((= c ?x) + (read-minibuffer prompt)) + ((= c ?x) + (eval-minibuffer prompt)) + ;; And here the new specs come. + ((= c ?y) + gnus-current-prefix-symbol) + ((= c ?Y) + gnus-current-prefix-symbols) + ((= c ?g) + (gnus-group-group-name)) + ((= c ?A) + (gnus-summary-article-number)) + ((= c ?H) + (gnus-summary-article-header)) + (t + (error "Not implemented spec"))) + out) + (cond + ((= c ?r) + (push (if (< (point) (mark) (point) (mark))) out) + (push (if (> (point) (mark) (point) (mark))) out)))) + (setq out (delq 'gnus-prefix-nil out)) + (nreverse out))) + +(defun gnus-symbolic-argument (&optional arg) + "Read a symbolic argument and a command, and then execute command." + (interactive "P") + (let* ((in-command (this-command-keys)) + (command in-command) + gnus-current-prefix-symbols + gnus-current-prefix-symbol + syms) + (while (equal in-command command) + (message "%s-" (key-description (this-command-keys))) + (push (intern (char-to-string (read-char))) syms) + (setq command (read-key-sequence nil t))) + (setq gnus-current-prefix-symbols (nreverse syms) + gnus-current-prefix-symbol (car gnus-current-prefix-symbols)) + (call-interactively (key-binding command t)))) + +;;; More various functions. + +(defsubst gnus-check-backend-function (func group) + "Check whether GROUP supports function FUNC. +GROUP can either be a string (a group name) or a select method." + (ignore-errors + (let ((method (if (stringp group) + (car (gnus-find-method-for-group group)) + group))) + (unless (featurep method) + (require method)) + (fboundp (intern (format "%s-%s" method func)))))) + +(defun gnus-group-read-only-p (&optional group) + "Check whether GROUP supports editing or not. +If GROUP is nil, `gnus-newsgroup-name' will be checked instead. Note +that that variable is buffer-local to the summary buffers." + (let ((group (or group gnus-newsgroup-name))) + (not (gnus-check-backend-function 'request-replace-article group)))) + +(defun gnus-group-total-expirable-p (group) + "Check whether GROUP is total-expirable or not." + (let ((params (gnus-group-find-parameter group)) + val) + (cond + ((memq 'total-expire params) + t) + ((setq val (assq 'total-expire params)) ; (auto-expire . t) + (cdr val)) + (gnus-total-expirable-newsgroups ; Check var. + (string-match gnus-total-expirable-newsgroups group))))) + +(defun gnus-group-auto-expirable-p (group) + "Check whether GROUP is auto-expirable or not." + (let ((params (gnus-group-find-parameter group)) + val) + (cond + ((memq 'auto-expire params) + t) + ((setq val (assq 'auto-expire params)) ; (auto-expire . t) + (cdr val)) + (gnus-auto-expirable-newsgroups ; Check var. + (string-match gnus-auto-expirable-newsgroups group))))) + +(defun gnus-virtual-group-p (group) + "Say whether GROUP is virtual or not." + (memq 'virtual (assoc (symbol-name (car (gnus-find-method-for-group group))) + gnus-valid-select-methods))) + +(defun gnus-news-group-p (group &optional article) + "Return non-nil if GROUP (and ARTICLE) come from a news server." + (or (gnus-member-of-valid 'post group) ; Ordinary news group. + (and (gnus-member-of-valid 'post-mail group) ; Combined group. + (eq (gnus-request-type group article) 'news)))) + +;; Returns a list of writable groups. +(defun gnus-writable-groups () + (let ((alist gnus-newsrc-alist) + groups group) + (while (setq group (car (pop alist))) + (unless (gnus-group-read-only-p group) + (push group groups))) + (nreverse groups))) + +;; Check whether to use long file names. +(defun gnus-use-long-file-name (symbol) + ;; The variable has to be set... + (and gnus-use-long-file-name + ;; If it isn't a list, then we return t. + (or (not (listp gnus-use-long-file-name)) + ;; If it is a list, and the list contains `symbol', we + ;; return nil. + (not (memq symbol gnus-use-long-file-name))))) + +;; Generate a unique new group name. +(defun gnus-generate-new-group-name (leaf) + (let ((name leaf) + (num 0)) + (while (gnus-gethash name gnus-newsrc-hashtb) + (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">"))) + name)) + +(defun gnus-ephemeral-group-p (group) + "Say whether GROUP is ephemeral or not." + (gnus-group-get-parameter group 'quit-config)) + +(defun gnus-group-quit-config (group) + "Return the quit-config of GROUP." + (gnus-group-get-parameter group 'quit-config)) + +(defun gnus-kill-ephemeral-group (group) + "Remove ephemeral GROUP from relevant structures." + (gnus-sethash group nil gnus-newsrc-hashtb)) + +(defun gnus-simplify-mode-line () + "Make mode lines a bit simpler." + (setq mode-line-modified (cdr gnus-mode-line-modified)) + (when (listp mode-line-format) + (make-local-variable 'mode-line-format) + (setq mode-line-format (copy-sequence mode-line-format)) + (when (equal (nth 3 mode-line-format) " ") + (setcar (nthcdr 3 mode-line-format) " ")))) + +;;; Servers and groups. + +(defsubst gnus-server-add-address (method) + (let ((method-name (symbol-name (car method)))) + (if (and (memq 'address (assoc method-name gnus-valid-select-methods)) + (not (assq (intern (concat method-name "-address")) method)) + (memq 'physical-address (assq (car method) + gnus-valid-select-methods))) + (append method (list (list (intern (concat method-name "-address")) + (nth 1 method)))) + method))) + +(defsubst gnus-server-get-method (group method) + ;; Input either a server name, and extended server name, or a + ;; select method, and return a select method. + (cond ((stringp method) + (gnus-server-to-method method)) + ((equal method gnus-select-method) + gnus-select-method) + ((and (stringp (car method)) group) + (gnus-server-extend-method group method)) + ((and method (not group) + (equal (cadr method) "")) + method) + (t + (gnus-server-add-address method)))) + +(defun gnus-server-to-method (server) + "Map virtual server names to select methods." + (or + ;; Is this a method, perhaps? + (and server (listp server) server) + ;; Perhaps this is the native server? + (and (equal server "native") gnus-select-method) + ;; It should be in the server alist. + (cdr (assoc server gnus-server-alist)) + ;; It could be in the predefined server alist. + (cdr (assoc server gnus-predefined-server-alist)) + ;; If not, we look through all the opened server + ;; to see whether we can find it there. + (let ((opened gnus-opened-servers)) + (while (and opened + (not (equal server (format "%s:%s" (caaar opened) + (cadaar opened))))) + (pop opened)) + (caar opened)))) + +(defmacro gnus-method-equal (ss1 ss2) + "Say whether two servers are equal." + `(let ((s1 ,ss1) + (s2 ,ss2)) + (or (equal s1 s2) + (and (= (length s1) (length s2)) + (progn + (while (and s1 (member (car s1) s2)) + (setq s1 (cdr s1))) + (null s1)))))) + +(defun gnus-server-equal (m1 m2) + "Say whether two methods are equal." + (let ((m1 (cond ((null m1) gnus-select-method) + ((stringp m1) (gnus-server-to-method m1)) + (t m1))) + (m2 (cond ((null m2) gnus-select-method) + ((stringp m2) (gnus-server-to-method m2)) + (t m2)))) + (gnus-method-equal m1 m2))) + +(defun gnus-servers-using-backend (backend) + "Return a list of known servers using BACKEND." + (let ((opened gnus-opened-servers) + out) + (while opened + (when (eq backend (caaar opened)) + (push (caar opened) out)) + (pop opened)) + out)) + +(defun gnus-archive-server-wanted-p () + "Say whether the user wants to use the archive server." + (cond + ((or (not gnus-message-archive-method) + (not gnus-message-archive-group)) + nil) + ((and gnus-message-archive-method gnus-message-archive-group) + t) + (t + (let ((active (cadr (assq 'nnfolder-active-file + gnus-message-archive-method)))) + (and active + (file-exists-p active)))))) + +(defun gnus-group-prefixed-name (group method) + "Return the whole name from GROUP and METHOD." + (and (stringp method) (setq method (gnus-server-to-method method))) + (if (not method) + group + (concat (format "%s" (car method)) + (when (and + (or (assoc (format "%s" (car method)) + (gnus-methods-using 'address)) + (gnus-server-equal method gnus-message-archive-method)) + (nth 1 method) + (not (string= (nth 1 method) ""))) + (concat "+" (nth 1 method))) + ":" group))) + +(defun gnus-group-real-prefix (group) + "Return the prefix of the current group name." + (if (string-match "^[^:]+:" group) + (substring group 0 (match-end 0)) + "")) + +(defun gnus-group-method (group) + "Return the server or method used for selecting GROUP. +You should probably use `gnus-find-method-for-group' instead." + (let ((prefix (gnus-group-real-prefix group))) + (if (equal prefix "") + gnus-select-method + (let ((servers gnus-opened-servers) + (server "") + backend possible found) + (if (string-match "^[^\\+]+\\+" prefix) + (setq backend (intern (substring prefix 0 (1- (match-end 0)))) + server (substring prefix (match-end 0) (1- (length prefix)))) + (setq backend (intern (substring prefix 0 (1- (length prefix)))))) + (while servers + (when (eq (caaar servers) backend) + (setq possible (caar servers)) + (when (equal (cadaar servers) server) + (setq found (caar servers)))) + (pop servers)) + (or (car (rassoc found gnus-server-alist)) + found + (car (rassoc possible gnus-server-alist)) + possible + (list backend server)))))) + +(defsubst gnus-secondary-method-p (method) + "Return whether METHOD is a secondary select method." + (let ((methods gnus-secondary-select-methods) + (gmethod (gnus-server-get-method nil method))) + (while (and methods + (not (equal (gnus-server-get-method nil (car methods)) + gmethod))) + (setq methods (cdr methods))) + methods)) + +(defun gnus-groups-from-server (server) + "Return a list of all groups that are fetched from SERVER." + (let ((alist (cdr gnus-newsrc-alist)) + info groups) + (while (setq info (pop alist)) + (when (gnus-server-equal (gnus-info-method info) server) + (push (gnus-info-group info) groups))) + (sort groups 'string<))) + +(defun gnus-group-foreign-p (group) + "Say whether a group is foreign or not." + (and (not (gnus-group-native-p group)) + (not (gnus-group-secondary-p group)))) + +(defun gnus-group-native-p (group) + "Say whether the group is native or not." + (not (string-match ":" group))) + +(defun gnus-group-secondary-p (group) + "Say whether the group is secondary or not." + (gnus-secondary-method-p (gnus-find-method-for-group group))) + +(defun gnus-group-find-parameter (group &optional symbol) + "Return the group parameters for GROUP. +If SYMBOL, return the value of that symbol in the group parameters." + (save-excursion + (set-buffer gnus-group-buffer) + (let ((parameters (funcall gnus-group-get-parameter-function group))) + (if symbol + (gnus-group-parameter-value parameters symbol) + parameters)))) + +(defun gnus-group-get-parameter (group &optional symbol) + "Return the group parameters for GROUP. +If SYMBOL, return the value of that symbol in the group parameters." + (let ((params (gnus-info-params (gnus-get-info group)))) + (if symbol + (gnus-group-parameter-value params symbol) + params))) + +(defun gnus-group-parameter-value (params symbol) + "Return the value of SYMBOL in group PARAMS." + (or (car (memq symbol params)) ; It's either a simple symbol + (cdr (assq symbol params)))) ; or a cons. + +(defun gnus-group-add-parameter (group param) + "Add parameter PARAM to GROUP." + (let ((info (gnus-get-info group))) + (when info + (gnus-group-remove-parameter group (if (consp param) (car param) param)) + ;; Cons the new param to the old one and update. + (gnus-group-set-info (cons param (gnus-info-params info)) + group 'params)))) + +(defun gnus-group-set-parameter (group name value) + "Set parameter NAME to VALUE in GROUP." + (let ((info (gnus-get-info group))) + (when info + (gnus-group-remove-parameter group name) + (let ((old-params (gnus-info-params info)) + (new-params (list (cons name value)))) + (while old-params + (when (or (not (listp (car old-params))) + (not (eq (caar old-params) name))) + (setq new-params (append new-params (list (car old-params))))) + (setq old-params (cdr old-params))) + (gnus-group-set-info new-params group 'params))))) + +(defun gnus-group-remove-parameter (group name) + "Remove parameter NAME from GROUP." + (let ((info (gnus-get-info group))) + (when info + (let ((params (gnus-info-params info))) + (when params + (setq params (delq name params)) + (while (assq name params) + (setq params (delq (assq name params) params))) + (gnus-info-set-params info params)))))) + +(defun gnus-group-add-score (group &optional score) + "Add SCORE to the GROUP score. +If SCORE is nil, add 1 to the score of GROUP." + (let ((info (gnus-get-info group))) + (when info + (gnus-info-set-score info (+ (gnus-info-score info) (or score 1)))))) + +;; Function written by Stainless Steel Rat +(defun gnus-short-group-name (group &optional levels) + "Collapse GROUP name LEVELS. +Select methods are stripped and any remote host name is stripped down to +just the host name." + (let* ((name "") (foreign "") (depth -1) (skip 1) + (levels (or levels + (progn + (while (string-match "\\." group skip) + (setq skip (match-end 0) + depth (+ depth 1))) + depth)))) + ;; separate foreign select method from group name and collapse. + ;; if method contains a server, collapse to non-domain server name, + ;; otherwise collapse to select method + (when (string-match ":" group) + (cond ((string-match "+" group) + (let* ((plus (string-match "+" group)) + (colon (string-match ":" group (or plus 0))) + (dot (string-match "\\." group))) + (setq foreign (concat + (substring group (+ 1 plus) + (cond ((null dot) colon) + ((< colon dot) colon) + ((< dot colon) dot))) + ":") + group (substring group (+ 1 colon))))) + (t + (let* ((colon (string-match ":" group))) + (setq foreign (concat (substring group 0 (+ 1 colon))) + group (substring group (+ 1 colon))))))) + ;; collapse group name leaving LEVELS uncollapsed elements + (while group + (if (and (string-match "\\." group) (> levels 0)) + (setq name (concat name (substring group 0 1)) + group (substring group (match-end 0)) + levels (- levels 1) + name (concat name ".")) + (setq name (concat foreign name group) + group nil))) + name)) + +(defun gnus-narrow-to-body () + "Narrow to the body of an article." + (narrow-to-region + (progn + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) + (point-max))) + (point-max))) + + +;;; +;;; Kill file handling. +;;; + +(defun gnus-apply-kill-file () + "Apply a kill file to the current newsgroup. +Returns the number of articles marked as read." + (if (or (file-exists-p (gnus-newsgroup-kill-file nil)) + (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) + (gnus-apply-kill-file-internal) + 0)) + +(defun gnus-kill-save-kill-buffer () + (let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name))) + (when (get-file-buffer file) + (save-excursion + (set-buffer (get-file-buffer file)) + (when (buffer-modified-p) + (save-buffer)) + (kill-buffer (current-buffer)))))) + +(defcustom gnus-kill-file-name "KILL" + "Suffix of the kill files." + :group 'gnus-score-kill + :group 'gnus-score-files + :type 'string) + +(defun gnus-newsgroup-kill-file (newsgroup) + "Return the name of a kill file name for NEWSGROUP. +If NEWSGROUP is nil, return the global kill file name instead." + (cond + ;; The global KILL file is placed at top of the directory. + ((or (null newsgroup) + (string-equal newsgroup "")) + (expand-file-name gnus-kill-file-name + gnus-kill-files-directory)) + ;; Append ".KILL" to newsgroup name. + ((gnus-use-long-file-name 'not-kill) + (expand-file-name (concat (gnus-newsgroup-savable-name newsgroup) + "." gnus-kill-file-name) + gnus-kill-files-directory)) + ;; Place "KILL" under the hierarchical directory. + (t + (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) + "/" gnus-kill-file-name) + gnus-kill-files-directory)))) + +;;; Server things. + +(defun gnus-member-of-valid (symbol group) + "Find out if GROUP has SYMBOL as part of its \"valid\" spec." + (memq symbol (assoc + (symbol-name (car (gnus-find-method-for-group group))) + gnus-valid-select-methods))) + +(defun gnus-method-option-p (method option) + "Return non-nil if select METHOD has OPTION as a parameter." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (memq option (assoc (format "%s" (car method)) + gnus-valid-select-methods))) + +(defun gnus-similar-server-opened (method) + (let ((opened gnus-opened-servers)) + (while (and method opened) + (when (and (equal (cadr method) (cadaar opened)) + (not (equal method (caar opened)))) + (setq method nil)) + (pop opened)) + (not method))) + +(defun gnus-server-extend-method (group method) + ;; This function "extends" a virtual server. If the server is + ;; "hello", and the select method is ("hello" (my-var "something")) + ;; in the group "alt.alt", this will result in a new virtual server + ;; called "hello+alt.alt". + (if (or (not (inline (gnus-similar-server-opened method))) + (not (cddr method))) + method + `(,(car method) ,(concat (cadr method) "+" group) + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method)))) + +(defun gnus-server-status (method) + "Return the status of METHOD." + (nth 1 (assoc method gnus-opened-servers))) + +(defun gnus-group-name-to-method (group) + "Guess a select method based on GROUP." + (if (string-match ":" group) + (let ((server (substring group 0 (match-beginning 0)))) + (if (string-match "\\+" server) + (list (intern (substring server 0 (match-beginning 0))) + (substring server (match-end 0))) + (list (intern server) ""))) + gnus-select-method)) + +(defun gnus-find-method-for-group (group &optional info) + "Find the select method that GROUP uses." + (or gnus-override-method + (and (not group) + gnus-select-method) + (let ((info (or info (gnus-get-info group))) + method) + (if (or (not info) + (not (setq method (gnus-info-method info))) + (equal method "native")) + gnus-select-method + (setq method + (cond ((stringp method) + (inline (gnus-server-to-method method))) + ((stringp (cadr method)) + (inline (gnus-server-extend-method group method))) + (t + method))) + (cond ((equal (cadr method) "") + method) + ((null (cadr method)) + (list (car method) "")) + (t + (gnus-server-add-address method))))))) + +(defun gnus-methods-using (feature) + "Find all methods that have FEATURE." + (let ((valids gnus-valid-select-methods) + outs) + (while valids + (when (memq feature (car valids)) + (push (car valids) outs)) + (setq valids (cdr valids))) + outs)) + +(defun gnus-read-group (prompt &optional default) + "Prompt the user for a group name. +Disallow illegal group names." + (let ((prefix "") + group) + (while (not group) + (when (string-match + "[: `'\"/]\\|^$" + (setq group (read-string (concat prefix prompt) + (cons (or default "") 0) + 'gnus-group-history))) + (setq prefix (format "Illegal group name: \"%s\". " group) + group nil))) + group)) + +(defun gnus-read-method (prompt) + "Prompt the user for a method. +Allow completion over sensible values." + (let ((method + (completing-read + prompt (append gnus-valid-select-methods gnus-predefined-server-alist + gnus-server-alist) + nil t nil 'gnus-method-history))) + (cond + ((equal method "") + (setq method gnus-select-method)) + ((assoc method gnus-valid-select-methods) + (list (intern method) + (if (memq 'prompt-address + (assoc method gnus-valid-select-methods)) + (read-string "Address: ") + ""))) + ((assoc method gnus-server-alist) + method) + (t + (list (intern method) ""))))) + +;;; User-level commands. + +;;;###autoload +(defun gnus-slave-no-server (&optional arg) + "Read network news as a slave, without connecting to local server" + (interactive "P") + (gnus-no-server arg t)) + +;;;###autoload +(defun gnus-no-server (&optional arg slave) + "Read network news. +If ARG is a positive number, Gnus will use that as the +startup level. If ARG is nil, Gnus will be started at level 2. +If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local server." + (interactive "P") + (gnus-no-server-1 arg slave)) + +;;;###autoload +(defun gnus-slave (&optional arg) + "Read news as a slave." + (interactive "P") + (gnus arg nil 'slave)) + +;;;###autoload +(defun gnus-other-frame (&optional arg) + "Pop up a frame to read news." + (interactive "P") + (let ((window (get-buffer-window gnus-group-buffer))) + (cond (window + (select-frame (window-frame window))) + ((= (length (frame-list)) 1) + (select-frame (make-frame))) + (t + (other-frame 1)))) + (gnus arg)) + +;;;###autoload +(defun gnus (&optional arg dont-connect slave) + "Read network news. +If ARG is non-nil and a positive number, Gnus will use that as the +startup level. If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use." + (interactive "P") + (gnus-1 arg dont-connect slave)) + +;; Allow redefinition of Gnus functions. + +(gnus-ems-redefine) + +(provide 'gnus) + +;;; gnus.el ends here diff --git a/lisp/lpath.el b/lisp/lpath.el new file mode 100644 index 0000000..c463dfb --- /dev/null +++ b/lisp/lpath.el @@ -0,0 +1,55 @@ +;; Shut up. + +(defvar byte-compile-default-warnings) + +(defun maybe-fbind (args) + (while args + (or (fboundp (car args)) + (fset (car args) 'ignore)) + (setq args (cdr args)))) + +(defun maybe-bind (args) + (mapcar (lambda (var) (unless (boundp var) (set var nil))) args)) + +(if (string-match "XEmacs" emacs-version) + (progn + (defvar track-mouse nil) + (maybe-fbind '(posn-point + event-start x-popup-menu + facemenu-get-face window-at coordinates-in-window-p + compute-motion x-defined-colors easy-menu-create-keymaps + read-event internal-find-face internal-next-face-id + make-face-internal set-frame-face-alist frame-face-alist + facemenu-add-new-face make-face-x-resource-internal + set-font-size set-font-family posn-window + run-with-idle-timer mouse-minibuffer-check window-edges + event-click-count track-mouse read-event mouse-movement-p + event-end mouse-scroll-subr overlay-lists delete-overlay + set-face-stipple mail-abbrevs-setup char-int + make-char-table set-char-table-range font-create-object + x-color-values widget-make-intangible error-message-string + w3-form-encode-xwfu + )) + (maybe-bind '(global-face-data + mark-active transient-mark-mode mouse-selection-click-count + mouse-selection-click-count-buffer buffer-display-table + font-lock-defaults user-full-name user-login-name + gnus-newsgroup-name gnus-article-x-face-too-ugly))) + (defvar browse-url-browser-function nil) + (maybe-fbind '(color-instance-rgb-components + make-color-instance color-instance-name specifier-instance + device-type device-class get-popup-menu-response event-object + x-defined-colors read-color add-submenu set-font-family + font-create-object set-font-size frame-device find-face + set-extent-property make-extent characterp display-error + set-face-doc-string frame-property face-doc-string + button-press-event-p next-command-event + widget-make-intangible glyphp make-glyph set-glyph-image + set-glyph-property event-glyph glyph-property event-point + device-on-window-system-p make-gui-button Info-goto-node + pp-to-string color-name))) + +(setq load-path (cons "." load-path)) +(require 'custom) + +(provide 'lpath) diff --git a/lisp/mailheader.el b/lisp/mailheader.el new file mode 100644 index 0000000..5e2b097 --- /dev/null +++ b/lisp/mailheader.el @@ -0,0 +1,182 @@ +;;; mail-header.el --- Mail header parsing, merging, formatting + +;; Copyright (C) 1996 by Free Software Foundation, Inc. + +;; Author: Erik Naggum +;; Keywords: tools, mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package provides an abstraction to RFC822-style messages, used in +;; mail news, and some other systems. The simple syntactic rules for such +;; headers, such as quoting and line folding, are routinely reimplemented +;; in many individual packages. This package removes the need for this +;; redundancy by representing message headers as association lists, +;; offering functions to extract the set of headers from a message, to +;; parse individual headers, to merge sets of headers, and to format a set +;; of headers. + +;; The car of each element in the message-header alist is a symbol whose +;; print name is the name of the header, in all lower-case. The cdr of an +;; element depends on the operation. After extracting headers from a +;; message, it is a string, the value of the header. An extracted set of +;; headers may be parsed further, which may turn it into a list, whose car +;; is the original value and whose subsequent elements depend on the +;; header. For formatting, it is evaluated to obtain the strings to be +;; inserted. For merging, one set of headers consists of strings, while +;; the other set will be evaluated with the symbols in the first set of +;; headers bound to their respective values. + +;;; Code: + +(require 'cl) + +;; Make the byte-compiler shut up. +(defvar headers) + +(defun mail-header-extract () + "Extract headers from current buffer after point. +Returns a header alist, where each element is a cons cell (name . value), +where NAME is a symbol, and VALUE is the string value of the header having +that name." + (let ((message-headers ()) (top (point)) + start end) + (while (and (setq start (point)) + (> (skip-chars-forward "^\0- :") 0) + (= (following-char) ?:) + (setq end (point)) + (progn (forward-char) + (> (skip-chars-forward " \t") 0))) + (let ((header (intern (downcase (buffer-substring start end)))) + (value (list (buffer-substring + (point) (progn (end-of-line) (point)))))) + (while (progn (forward-char) (> (skip-chars-forward " \t") 0)) + (push (buffer-substring (point) (progn (end-of-line) (point))) + value)) + (push (if (cdr value) + (cons header (mapconcat #'identity (nreverse value) " ")) + (cons header (car value))) + message-headers))) + (goto-char top) + (nreverse message-headers))) + +(defun mail-header-extract-no-properties () + "Extract headers from current buffer after point, without properties. +Returns a header alist, where each element is a cons cell (name . value), +where NAME is a symbol, and VALUE is the string value of the header having +that name." + (mapcar + (lambda (elt) + (set-text-properties 0 (length (cdr elt)) nil (cdr elt)) + elt) + (mail-header-extract))) + +(defun mail-header-parse (parsing-rules headers) + "Apply PARSING-RULES to HEADERS. +PARSING-RULES is an alist whose keys are header names (symbols) and whose +value is a parsing function. The function takes one argument, a string, +and return a list of values, which will destructively replace the value +associated with the key in HEADERS, after being prepended with the original +value." + (dolist (rule parsing-rules) + (let ((header (assq (car rule) headers))) + (when header + (if (consp (cdr header)) + (setf (cddr header) (funcall (cdr rule) (cadr header))) + (setf (cdr header) + (cons (cdr header) (funcall (cdr rule) (cdr header)))))))) + headers) + +(defsubst mail-header (header &optional header-alist) + "Return the value associated with header HEADER in HEADER-ALIST. +If the value is a string, it is the original value of the header. If the +value is a list, its first element is the original value of the header, +with any subsequent elements being the result of parsing the value. +If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." + (cdr (assq header (or header-alist headers)))) + +(defun mail-header-set (header value &optional header-alist) + "Set the value associated with header HEADER to VALUE in HEADER-ALIST. +HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. +See `mail-header' for the semantics of VALUE." + (let* ((alist (or header-alist headers)) + (entry (assq header alist))) + (if entry + (setf (cdr entry) value) + (nconc alist (list (cons header value))))) + value) + +(defsetf mail-header (header &optional header-alist) (value) + `(mail-header-set ,header ,value ,header-alist)) + +(defun mail-header-merge (merge-rules headers) + "Return a new header alist with MERGE-RULES applied to HEADERS. +MERGE-RULES is an alist whose keys are header names (symbols) and whose +values are forms to evaluate, the results of which are the new headers. It +should be a string or a list of string. The first element may be nil to +denote that the formatting functions must use the remaining elements, or +skip the header altogether if there are no other elements. + The macro `mail-header' can be used to access headers in HEADERS." + (mapcar + (lambda (rule) + (cons (car rule) (eval (cdr rule)))) + merge-rules)) + +(defvar mail-header-format-function + (lambda (header value) + "Function to format headers without a specified formatting function." + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n"))) + +(defun mail-header-format (format-rules headers) + "Use FORMAT-RULES to format HEADERS and insert into current buffer. +FORMAT-RULES is an alist whose keys are header names (symbols), and whose +values are functions that format the header, the results of which are +inserted, unless it is nil. The function takes two arguments, the header +symbol, and the value of that header. If the function itself is nil, the +default action is to insert the value of the header, unless it is nil. +The headers are inserted in the order of the FORMAT-RULES. +A key of t represents any otherwise unmentioned headers. +A key of nil has as its value a list of defaulted headers to ignore." + (let ((ignore (append (cdr (assq nil format-rules)) + (mapcar #'car format-rules)))) + (dolist (rule format-rules) + (let* ((header (car rule)) + (value (mail-header header))) + (cond ((null header) 'ignore) + ((eq header t) + (dolist (defaulted headers) + (unless (memq (car defaulted) ignore) + (let* ((header (car defaulted)) + (value (cdr defaulted))) + (if (cdr rule) + (funcall (cdr rule) header value) + (funcall mail-header-format-function header value)))))) + (value + (if (cdr rule) + (funcall (cdr rule) header value) + (funcall mail-header-format-function header value)))))) + (insert "\n"))) + +(provide 'mailheader) + +;;; mail-header.el ends here diff --git a/lisp/md5.el b/lisp/md5.el new file mode 100644 index 0000000..c27fc4a --- /dev/null +++ b/lisp/md5.el @@ -0,0 +1,409 @@ +;;; md5.el -- MD5 Message Digest Algorithm +;;; Gareth Rees + +;; LCD Archive Entry: +;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| +;; MD5 cryptographic message digest algorithm| +;; 13-Nov-95|1.0|~/misc/md5.el.Z| + +;;; Details: ------------------------------------------------------------------ + +;; This is a direct translation into Emacs LISP of the reference C +;; implementation of the MD5 Message-Digest Algorithm written by RSA +;; Data Security, Inc. +;; +;; The algorithm takes a message (that is, a string of bytes) and +;; computes a 16-byte checksum or "digest" for the message. This digest +;; is supposed to be cryptographically strong in the sense that if you +;; are given a 16-byte digest D, then there is no easier way to +;; construct a message whose digest is D than to exhaustively search the +;; space of messages. However, the robustness of the algorithm has not +;; been proven, and a similar algorithm (MD4) was shown to be unsound, +;; so treat with caution! +;; +;; The C algorithm uses 32-bit integers; because GNU Emacs +;; implementations provide 28-bit integers (with 24-bit integers on +;; versions prior to 19.29), the code represents a 32-bit integer as the +;; cons of two 16-bit integers. The most significant word is stored in +;; the car and the least significant in the cdr. The algorithm requires +;; at least 17 bits of integer representation in order to represent the +;; carry from a 16-bit addition. + +;;; Usage: -------------------------------------------------------------------- + +;; To compute the MD5 Message Digest for a message M (represented as a +;; string or as a vector of bytes), call +;; +;; (md5-encode M) +;; +;; which returns the message digest as a vector of 16 bytes. If you +;; need to supply the message in pieces M1, M2, ... Mn, then call +;; +;; (md5-init) +;; (md5-update M1) +;; (md5-update M2) +;; ... +;; (md5-update Mn) +;; (md5-final) + +;;; Copyright and licence: ---------------------------------------------------- + +;; Copyright (C) 1995 by Gareth Rees +;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm +;; +;; md5.el is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the +;; Free Software Foundation; either version 2, or (at your option) any +;; later version. +;; +;; md5.el is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +;; for more details. +;; +;; The original copyright notice is given below, as required by the +;; licence for the original code. This code is distributed under *both* +;; RSA's original licence and the GNU General Public Licence. (There +;; should be no problems, as the former is more liberal than the +;; latter). + +;;; Original copyright notice: ------------------------------------------------ + +;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. +;; +;; License to copy and use this software is granted provided that it is +;; identified as the "RSA Data Security, Inc. MD5 Message- Digest +;; Algorithm" in all material mentioning or referencing this software or +;; this function. +;; +;; License is also granted to make and use derivative works provided +;; that such works are identified as "derived from the RSA Data +;; Security, Inc. MD5 Message-Digest Algorithm" in all material +;; mentioning or referencing the derived work. +;; +;; RSA Data Security, Inc. makes no representations concerning either +;; the merchantability of this software or the suitability of this +;; software for any particular purpose. It is provided "as is" without +;; express or implied warranty of any kind. +;; +;; These notices must be retained in any copies of any part of this +;; documentation and/or software. + +;;; Code: --------------------------------------------------------------------- + +(defvar md5-program "md5" + "*Program that reads a message on its standard input and writes an +MD5 digest on its output.") + +(defvar md5-maximum-internal-length 4096 + "*The maximum size of a piece of data that should use the MD5 routines +written in lisp. If a message exceeds this, it will be run through an +external filter for processing. Also see the `md5-program' variable. +This variable has no effect if you call the md5-init|update|final +functions - only used by the `md5' function's simpler interface.") + +(defvar md5-bits (make-vector 4 0) + "Number of bits handled, modulo 2^64. +Represented as four 16-bit numbers, least significant first.") +(defvar md5-buffer (make-vector 4 '(0 . 0)) + "Scratch buffer (four 32-bit integers).") +(defvar md5-input (make-vector 64 0) + "Input buffer (64 bytes).") + +(defun md5-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun md5-encode (message) + "Encodes MESSAGE using the MD5 message digest algorithm. +MESSAGE must be a string or an array of bytes. +Returns a vector of 16 bytes containing the message digest." + (if (<= (length message) md5-maximum-internal-length) + (progn + (md5-init) + (md5-update message) + (md5-final)) + (save-excursion + (set-buffer (get-buffer-create " *md5-work*")) + (erase-buffer) + (insert message) + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t (current-buffer) nil + "-c" md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (let ((data (buffer-substring (point-min) (+ (point-min) 32))) + (vec (make-vector 16 0)) + (ctr 0)) + (while (< ctr 16) + (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) + (md5-unhex (aref data (1+ (* ctr 2)))))) + (setq ctr (1+ ctr))))))) + +(defsubst md5-add (x y) + "Return 32-bit sum of 32-bit integers X and Y." + (let ((m (+ (car x) (car y))) + (l (+ (cdr x) (cdr y)))) + (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) + +;; FF, GG, HH and II are basic MD5 functions, providing transformations +;; for rounds 1, 2, 3 and 4 respectively. Each function follows this +;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x +;; by y bits to the left): +;; +;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b +;; +;; so we use the macro `md5-make-step' to construct each one. The +;; helper functions F, G, H and I operate on 16-bit numbers; the full +;; operation splits its inputs, operates on the halves separately and +;; then puts the results together. + +(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) +(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) +(defsubst md5-H (x y z) (logxor x y z)) +(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) + +(defmacro md5-make-step (name func) + (` + (defun (, name) (a b c d x s ac) + (let* + ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) + (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) + (m2 (logand 65535 (+ m1 (lsh l1 -16)))) + (l2 (logand 65535 l1)) + (m3 (logand 65535 (if (> s 15) + (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) + (+ (lsh m2 s) (lsh l2 (- s 16)))))) + (l3 (logand 65535 (if (> s 15) + (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) + (+ (lsh l2 s) (lsh m2 (- s 16))))))) + (md5-add (cons m3 l3) b))))) + +(md5-make-step md5-FF md5-F) +(md5-make-step md5-GG md5-G) +(md5-make-step md5-HH md5-H) +(md5-make-step md5-II md5-I) + +(defun md5-init () + "Initialise the state of the message-digest routines." + (aset md5-bits 0 0) + (aset md5-bits 1 0) + (aset md5-bits 2 0) + (aset md5-bits 3 0) + (aset md5-buffer 0 '(26437 . 8961)) + (aset md5-buffer 1 '(61389 . 43913)) + (aset md5-buffer 2 '(39098 . 56574)) + (aset md5-buffer 3 '( 4146 . 21622))) + +(defun md5-update (string) + "Update the current MD5 state with STRING (an array of bytes)." + (let ((len (length string)) + (i 0) + (j 0)) + (while (< i len) + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Store this byte (truncating to 8 bits to be sure) + (aset md5-input j (logand 255 (aref string i))) + + ;; Update number of bits by 8 (modulo 2^64) + (let ((c 8) (k 0)) + (while (and (> c 0) (< k 4)) + (let ((b (aref md5-bits k))) + (aset md5-bits k (logand 65535 (+ b c))) + (setq c (if (> b (- 65535 c)) 1 0) + k (1+ k))))) + + ;; Increment number of bytes processed + (setq i (1+ i)) + + ;; When 64 bytes accumulated, pack them into sixteen 32-bit + ;; integers in the array `in' and then tranform them. + (if (= j 63) + (let ((in (make-vector 16 (cons 0 0))) + (k 0) + (kk 0)) + (while (< k 16) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4))) + (md5-transform in)))))) + +(defun md5-pack (array i) + "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." + (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) + (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) + +(defun md5-byte (array n b) + "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." + (let ((e (aref array n))) + (cond ((eq b 0) (logand 255 (cdr e))) + ((eq b 1) (lsh (cdr e) -8)) + ((eq b 2) (logand 255 (car e))) + ((eq b 3) (lsh (car e) -8))))) + +(defun md5-final () + (let ((in (make-vector 16 (cons 0 0))) + (j 0) + (digest (make-vector 16 0)) + (padding)) + + ;; Save the number of bits in the message + (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) + (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) + + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Pad out computation to 56 bytes modulo 64 + (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) + (aset padding 0 128) + (md5-update padding) + + ;; Append length in bits and transform + (let ((k 0) (kk 0)) + (while (< k 14) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4)))) + (md5-transform in) + + ;; Store the results in the digest + (let ((k 0) (kk 0)) + (while (< k 4) + (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) + (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) + (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) + (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) + (setq k (+ k 1) kk (+ kk 4)))) + + ;; Return digest + digest)) + +;; It says in the RSA source, "Note that if the Mysterious Constants are +;; arranged backwards in little-endian order and decrypted with the DES +;; they produce OCCULT MESSAGES!" Security through obscurity? + +(defun md5-transform (in) + "Basic MD5 step. Transform md5-buffer based on array IN." + (let ((a (aref md5-buffer 0)) + (b (aref md5-buffer 1)) + (c (aref md5-buffer 2)) + (d (aref md5-buffer 3))) + (setq + a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) + d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) + c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) + b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) + a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) + d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) + c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) + b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) + a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) + d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) + c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) + b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) + a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) + d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) + c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) + b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) + a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) + d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) + c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) + b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) + a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) + d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) + c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) + b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) + a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) + d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) + c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) + b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) + a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) + d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) + c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) + b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) + a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) + d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) + c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) + b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) + a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) + d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) + c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) + b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) + a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) + d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) + c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) + b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) + a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) + d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) + c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) + b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) + a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) + d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) + c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) + b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) + a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) + d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) + c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) + b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) + a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) + d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) + c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) + b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) + a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) + d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) + c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) + b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) + + (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) + (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) + (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) + (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Here begins the merger with the XEmacs API and the md5.el from the URL +;;; package. Courtesy wmperry@spry.com +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun md5 (object &optional start end) + "Return the MD5 (a secure message digest algorithm) of an object. +OBJECT is either a string or a buffer. +Optional arguments START and END denote buffer positions for computing the +hash of a portion of OBJECT." + (let ((buffer nil)) + (unwind-protect + (save-excursion + (setq buffer (generate-new-buffer " *md5-work*")) + (set-buffer buffer) + (cond + ((bufferp object) + (insert-buffer-substring object start end)) + ((stringp object) + (insert (if (or start end) + (substring object start end) + object))) + (t nil)) + (prog1 + (if (<= (point-max) md5-maximum-internal-length) + (mapconcat + (function (lambda (node) (format "%02x" node))) + (md5-encode (buffer-string)) + "") + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t buffer nil + "-c" md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (buffer-substring (point-min) (+ (point-min) 32))) + (kill-buffer buffer))) + (and buffer (kill-buffer buffer) nil)))) + +(provide 'md5) + +;;; md5.el ends here ---------------------------------------------------------- diff --git a/lisp/message.el b/lisp/message.el new file mode 100644 index 0000000..257d226 --- /dev/null +++ b/lisp/message.el @@ -0,0 +1,3768 @@ +;;; message.el --- composing mail and news messages +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This mode provides mail-sending facilities from within Emacs. It +;; consists mainly of large chunks of code from the sendmail.el, +;; gnus-msg.el and rnewspost.el files. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'mailheader) +(require 'rmail) +(require 'nnheader) +(require 'timezone) +(require 'easymenu) +(require 'custom) +(if (string-match "XEmacs\\|Lucid" emacs-version) + (require 'mail-abbrevs) + (require 'mailabbrev)) + +(defgroup message '((user-mail-address custom-variable) + (user-full-name custom-variable)) + "Mail and news message composing." + :link '(custom-manual "(message)Top") + :group 'mail + :group 'news) + +(put 'user-mail-address 'custom-type 'string) +(put 'user-full-name 'custom-type 'string) + +(defgroup message-various nil + "Various Message Variables" + :link '(custom-manual "(message)Various Message Variables") + :group 'message) + +(defgroup message-buffers nil + "Message Buffers" + :link '(custom-manual "(message)Message Buffers") + :group 'message) + +(defgroup message-sending nil + "Message Sending" + :link '(custom-manual "(message)Sending Variables") + :group 'message) + +(defgroup message-interface nil + "Message Interface" + :link '(custom-manual "(message)Interface") + :group 'message) + +(defgroup message-forwarding nil + "Message Forwarding" + :link '(custom-manual "(message)Forwarding") + :group 'message-interface) + +(defgroup message-insertion nil + "Message Insertion" + :link '(custom-manual "(message)Insertion") + :group 'message) + +(defgroup message-headers nil + "Message Headers" + :link '(custom-manual "(message)Message Headers") + :group 'message) + +(defgroup message-news nil + "Composing News Messages" + :group 'message) + +(defgroup message-mail nil + "Composing Mail Messages" + :group 'message) + +(defgroup message-faces nil + "Faces used for message composing." + :group 'message + :group 'faces) + +(defcustom message-directory "~/Mail/" + "*Directory from which all other mail file variables are derived." + :group 'message-various + :type 'directory) + +(defcustom message-max-buffers 10 + "*How many buffers to keep before starting to kill them off." + :group 'message-buffers + :type 'integer) + +(defcustom message-send-rename-function nil + "Function called to rename the buffer after sending it." + :group 'message-buffers + :type 'function) + +(defcustom message-fcc-handler-function 'message-output + "*A function called to save outgoing articles. +This function will be called with the name of the file to store the +article in. The default function is `message-output' which saves in Unix +mailbox format." + :type '(radio (function-item message-output) + (function :tag "Other")) + :group 'message-sending) + +(defcustom message-courtesy-message + "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" + "*This is inserted at the start of a mailed copy of a posted message. +If the string contains the format spec \"%s\", the Newsgroups +the article has been posted to will be inserted there. +If this variable is nil, no such courtesy message will be added." + :group 'message-sending + :type 'string) + +(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" + "*Regexp that matches headers to be removed in resent bounced mail." + :group 'message-interface + :type 'regexp) + +;;;###autoload +(defcustom message-from-style 'default + "*Specifies how \"From\" headers look. + +If `nil', they contain just the return address like: + king@grassland.com +If `parens', they look like: + king@grassland.com (Elvis Parsley) +If `angles', they look like: + Elvis Parsley + +Otherwise, most addresses look like `angles', but they look like +`parens' if `angles' would need quoting and `parens' would not." + :type '(choice (const :tag "simple" nil) + (const parens) + (const angles) + (const default)) + :group 'message-headers) + +(defcustom message-syntax-checks nil + ;; Guess this one shouldn't be easy to customize... + "Controls what syntax checks should not be performed on outgoing posts. +To disable checking of long signatures, for instance, add + `(signature . disabled)' to this list. + +Don't touch this variable unless you really know what you're doing. + +Checks include subject-cmsg multiple-headers sendsys message-id from +long-lines control-chars size new-text redirected-followup signature +approved sender empty empty-headers message-id from subject +shorten-followup-to existing-newsgroups buffer-file-name unchanged." + :group 'message-news) + +(defcustom message-required-news-headers + '(From Newsgroups Subject Date Message-ID + (optional . Organization) Lines + (optional . X-Newsreader)) + "Headers to be generated or prompted for when posting an article. +RFC977 and RFC1036 require From, Date, Newsgroups, Subject, +Message-ID. Organization, Lines, In-Reply-To, Expires, and +X-Newsreader are optional. If don't you want message to insert some +header, remove it from this list." + :group 'message-news + :group 'message-headers + :type '(repeat sexp)) + +(defcustom message-required-mail-headers + '(From Subject Date (optional . In-Reply-To) Message-ID Lines + (optional . X-Mailer)) + "Headers to be generated or prompted for when mailing a message. +RFC822 required that From, Date, To, Subject and Message-ID be +included. Organization, Lines and X-Mailer are optional." + :group 'message-mail + :group 'message-headers + :type '(repeat sexp)) + +(defcustom message-deletable-headers '(Message-ID Date Lines) + "Headers to be deleted if they already exist and were generated by message previously." + :group 'message-headers + :type 'sexp) + +(defcustom message-ignored-news-headers + "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "*Regexp of headers to be removed unconditionally before posting." + :group 'message-news + :group 'message-headers + :type 'regexp) + +(defcustom message-ignored-mail-headers "^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "*Regexp of headers to be removed unconditionally before mailing." + :group 'message-mail + :group 'message-headers + :type 'regexp) + +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:" + "*Header lines matching this regexp will be deleted before posting. +It's best to delete old Path and Date headers before posting to avoid +any confusion." + :group 'message-interface + :type 'regexp) + +;;;###autoload +(defcustom message-signature-separator "^-- *$" + "Regexp matching the signature separator." + :type 'regexp + :group 'message-various) + +(defcustom message-elide-elipsis "\n[...]\n\n" + "*The string which is inserted for elided text.") + +(defcustom message-interactive nil + "Non-nil means when sending a message wait for and display errors. +nil means let mailer mail back a message to report errors." + :group 'message-sending + :group 'message-mail + :type 'boolean) + +(defcustom message-generate-new-buffers t + "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. +If this is a function, call that function with three parameters: The type, +the to address and the group name. (Any of these may be nil.) The function +should return the new buffer name." + :group 'message-buffers + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (function fun))) + +(defcustom message-kill-buffer-on-exit nil + "*Non-nil means that the message buffer will be killed after sending a message." + :group 'message-buffers + :type 'boolean) + +(defvar gnus-local-organization) +(defcustom message-user-organization + (or (and (boundp 'gnus-local-organization) + (stringp gnus-local-organization) + gnus-local-organization) + (getenv "ORGANIZATION") + t) + "*String to be used as an Organization header. +If t, use `message-user-organization-file'." + :group 'message-headers + :type '(choice string + (const :tag "consult file" t))) + +;;;###autoload +(defcustom message-user-organization-file "/usr/lib/news/organization" + "*Local news organization file." + :type 'file + :group 'message-headers) + +(defcustom message-autosave-directory + (nnheader-concat message-directory "drafts/") + "*Directory where Message autosaves buffers. +If nil, Message won't autosave." + :group 'message-buffers + :type 'directory) + +(defcustom message-forward-start-separator + "------- Start of forwarded message -------\n" + "*Delimiter inserted before forwarded messages." + :group 'message-forwarding + :type 'string) + +(defcustom message-forward-end-separator + "------- End of forwarded message -------\n" + "*Delimiter inserted after forwarded messages." + :group 'message-forwarding + :type 'string) + +(defcustom message-signature-before-forwarded-message t + "*If non-nil, put the signature before any included forwarded message." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-included-forward-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" + "*Regexp matching headers to be included in forwarded messages." + :group 'message-forwarding + :type 'regexp) + +(defcustom message-ignored-resent-headers "^Return-receipt" + "*All headers that match this regexp will be deleted when resending a message." + :group 'message-interface + :type 'regexp) + +(defcustom message-ignored-cited-headers "." + "*Delete these headers from the messages you yank." + :group 'message-insertion + :type 'regexp) + +(defcustom message-cancel-message "I am canceling my own article." + "Message to be inserted in the cancel message." + :group 'message-interface + :type 'string) + +;; Useful to set in site-init.el +;;;###autoload +(defcustom message-send-mail-function 'message-send-mail-with-sendmail + "Function to call to send the current buffer as mail. +The headers should be delimited by a line whose contents match the +variable `mail-header-separator'. + +Legal values include `message-send-mail-with-sendmail' (the default), +`message-send-mail-with-mh' and `message-send-mail-with-qmail'." + :type '(radio (function-item message-send-mail-with-sendmail) + (function-item message-send-mail-with-mh) + (function-item message-send-mail-with-qmail) + (function :tag "Other")) + :group 'message-sending + :group 'message-mail) + +(defcustom message-send-news-function 'message-send-news + "Function to call to send the current buffer as news. +The headers should be delimited by a line whose contents match the +variable `mail-header-separator'." + :group 'message-sending + :group 'message-news + :type 'function) + +(defcustom message-reply-to-function nil + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers." + :group 'message-interface + :type 'function) + +(defcustom message-wide-reply-to-function nil + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers." + :group 'message-interface + :type 'function) + +(defcustom message-followup-to-function nil + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers." + :group 'message-interface + :type 'function) + +(defcustom message-use-followup-to 'ask + "*Specifies what to do with Followup-To header. +If nil, always ignore the header. If it is t, use its value, but +query before using the \"poster\" value. If it is the symbol `ask', +always query the user whether to use the value. If it is the symbol +`use', always use the value." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const use) + (const ask))) + +;; stuff relating to broken sendmail in MMDF +(defcustom message-sendmail-f-is-evil nil + "*Non-nil means that \"-f username\" should not be added to the sendmail +command line, because it is even more evil than leaving it out." + :group 'message-sending + :type 'boolean) + +;; qmail-related stuff +(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" + "Location of the qmail-inject program." + :group 'message-sending + :type 'file) + +(defcustom message-qmail-inject-args nil + "Arguments passed to qmail-inject programs. +This should be a list of strings, one string for each argument. + +For e.g., if you wish to set the envelope sender address so that bounces +go to the right place or to deal with listserv's usage of that address, you +might set this variable to '(\"-f\" \"you@some.where\")." + :group 'message-sending + :type '(repeat string)) + +(defvar gnus-post-method) +(defvar gnus-select-method) +(defcustom message-post-method + (cond ((and (boundp 'gnus-post-method) + gnus-post-method) + gnus-post-method) + ((boundp 'gnus-select-method) + gnus-select-method) + (t '(nnspool ""))) + "Method used to post news." + :group 'message-news + :group 'message-sending + ;; This should be the `gnus-select-method' widget, but that might + ;; create a dependence to `gnus.el'. + :type 'sexp) + +(defcustom message-generate-headers-first nil + "*If non-nil, generate all possible headers before composing." + :group 'message-headers + :type 'boolean) + +(defcustom message-setup-hook nil + "Normal hook, run each time a new outgoing message is initialized. +The function `message-setup' runs this hook." + :group 'message-various + :type 'hook) + +(defcustom message-signature-setup-hook nil + "Normal hook, run each time a new outgoing message is initialized. +It is run after the headers have been inserted and before +the signature is inserted." + :group 'message-various + :type 'hook) + +(defcustom message-mode-hook nil + "Hook run in message mode buffers." + :group 'message-various + :type 'hook) + +(defcustom message-header-hook nil + "Hook run in a message mode buffer narrowed to the headers." + :group 'message-various + :type 'hook) + +(defcustom message-header-setup-hook nil + "Hook called narrowed to the headers when setting up a message +buffer." + :group 'message-various + :type 'hook) + +;;;###autoload +(defcustom message-citation-line-function 'message-insert-citation-line + "*Function called to insert the \"Whomever writes:\" line." + :type 'function + :group 'message-insertion) + +;;;###autoload +(defcustom message-yank-prefix "> " + "*Prefix inserted on the lines of yanked messages. +nil means use indentation." + :type 'string + :group 'message-insertion) + +(defcustom message-indentation-spaces 3 + "*Number of spaces to insert at the beginning of each cited line. +Used by `message-yank-original' via `message-yank-cite'." + :group 'message-insertion + :type 'integer) + +;;;###autoload +(defcustom message-cite-function + (if (and (boundp 'mail-citation-hook) + mail-citation-hook) + mail-citation-hook + 'message-cite-original) + "*Function for citing an original message." + :type '(radio (function-item message-cite-original) + (function-item sc-cite-original) + (function :tag "Other")) + :group 'message-insertion) + +;;;###autoload +(defcustom message-indent-citation-function 'message-indent-citation + "*Function for modifying a citation just inserted in the mail buffer. +This can also be a list of functions. Each function can find the +citation between (point) and (mark t). And each function should leave +point and mark around the citation text as modified." + :type 'function + :group 'message-insertion) + +(defvar message-abbrevs-loaded nil) + +;;;###autoload +(defcustom message-signature t + "*String to be inserted at the end of the message buffer. +If t, the `message-signature-file' file will be inserted instead. +If a function, the result from the function will be used instead. +If a form, the result from the form will be used instead." + :type 'sexp + :group 'message-insertion) + +;;;###autoload +(defcustom message-signature-file "~/.signature" + "*File containing the text inserted at end of message buffer." + :type 'file + :group 'message-insertion) + +(defcustom message-distribution-function nil + "*Function called to return a Distribution header." + :group 'message-news + :group 'message-headers + :type 'function) + +(defcustom message-expires 14 + "Number of days before your article expires." + :group 'message-news + :group 'message-headers + :link '(custom-manual "(message)News Headers") + :type 'integer) + +(defcustom message-user-path nil + "If nil, use the NNTP server name in the Path header. +If stringp, use this; if non-nil, use no host name (user name only)." + :group 'message-news + :group 'message-headers + :link '(custom-manual "(message)News Headers") + :type '(choice (const :tag "nntp" nil) + (string :tag "name") + (sexp :tag "none" :format "%t" t))) + +(defvar message-reply-buffer nil) +(defvar message-reply-headers nil) +(defvar message-newsreader nil) +(defvar message-mailer nil) +(defvar message-sent-message-via nil) +(defvar message-checksum nil) +(defvar message-send-actions nil + "A list of actions to be performed upon successful sending of a message.") +(defvar message-exit-actions nil + "A list of actions to be performed upon exiting after sending a message.") +(defvar message-kill-actions nil + "A list of actions to be performed before killing a message buffer.") +(defvar message-postpone-actions nil + "A list of actions to be performed after postponing a message.") + +(defcustom message-default-headers "" + "*A string containing header lines to be inserted in outgoing messages. +It is inserted before you edit the message, so you can edit or delete +these lines." + :group 'message-headers + :type 'string) + +(defcustom message-default-mail-headers "" + "*A string of header lines to be inserted in outgoing mails." + :group 'message-headers + :group 'message-mail + :type 'string) + +(defcustom message-default-news-headers "" + "*A string of header lines to be inserted in outgoing news +articles." + :group 'message-headers + :group 'message-news + :type 'string) + +;; Note: could use /usr/ucb/mail instead of sendmail; +;; options -t, and -v if not interactive. +(defcustom message-mailer-swallows-blank-line + (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" + system-configuration) + (file-readable-p "/etc/sendmail.cf") + (let ((buffer (get-buffer-create " *temp*"))) + (unwind-protect + (save-excursion + (set-buffer buffer) + (insert-file-contents "/etc/sendmail.cf") + (goto-char (point-min)) + (let ((case-fold-search nil)) + (re-search-forward "^OR\\>" nil t))) + (kill-buffer buffer)))) + ;; According to RFC822, "The field-name must be composed of printable + ;; ASCII characters (i. e., characters that have decimal values between + ;; 33 and 126, except colon)", i. e., any chars except ctl chars, + ;; space, or colon. + '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) + "Set this non-nil if the system's mailer runs the header and body together. +\(This problem exists on Sunos 4 when sendmail is run in remote mode.) +The value should be an expression to test whether the problem will +actually occur." + :group 'message-sending + :type 'sexp) + +;; Ignore errors in case this is used in Emacs 19. +;; Don't use ignore-errors because this is copied into loaddefs.el. +;;;###autoload +(condition-case nil + (define-mail-user-agent 'message-user-agent + 'message-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) + (error nil)) + +(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) + "If non-nil, delete the deletable headers before feeding to mh.") + +(defvar message-send-method-alist + '((news message-news-p message-send-via-news) + (mail message-mail-p message-send-via-mail)) + "Alist of ways to send outgoing messages. +Each element has the form + + \(TYPE PREDICATE FUNCTION) + +where TYPE is a symbol that names the method; PREDICATE is a function +called without any parameters to determine whether the message is +a message of type TYPE; and FUNCTION is a function to be called if +PREDICATE returns non-nil. FUNCTION is called with one parameter -- +the prefix.") + +(defvar message-mail-alias-type 'abbrev + "*What alias expansion type to use in Message buffers. +The default is `abbrev', which uses mailabbrev. nil switches +mail aliases off.") + +;;; Internal variables. +;;; Well, not really internal. + +(defvar message-mode-syntax-table + (let ((table (copy-syntax-table text-mode-syntax-table))) + (modify-syntax-entry ?% ". " table) + table) + "Syntax table used while in Message mode.") + +(defvar message-mode-abbrev-table text-mode-abbrev-table + "Abbrev table used in Message mode buffers. +Defaults to `text-mode-abbrev-table'.") +(defgroup message-headers nil + "Message headers." + :link '(custom-manual "(message)Variables") + :group 'message) + +(defface message-header-to-face + '((((class color) + (background dark)) + (:foreground "green2" :bold t)) + (((class color) + (background light)) + (:foreground "MidnightBlue" :bold t)) + (t + (:bold t :italic t))) + "Face used for displaying From headers." + :group 'message-faces) + +(defface message-header-cc-face + '((((class color) + (background dark)) + (:foreground "green4" :bold t)) + (((class color) + (background light)) + (:foreground "MidnightBlue")) + (t + (:bold t))) + "Face used for displaying Cc headers." + :group 'message-faces) + +(defface message-header-subject-face + '((((class color) + (background dark)) + (:foreground "green3")) + (((class color) + (background light)) + (:foreground "navy blue" :bold t)) + (t + (:bold t))) + "Face used for displaying subject headers." + :group 'message-faces) + +(defface message-header-newsgroups-face + '((((class color) + (background dark)) + (:foreground "yellow" :bold t :italic t)) + (((class color) + (background light)) + (:foreground "blue4" :bold t :italic t)) + (t + (:bold t :italic t))) + "Face used for displaying newsgroups headers." + :group 'message-faces) + +(defface message-header-other-face + '((((class color) + (background dark)) + (:foreground "red4")) + (((class color) + (background light)) + (:foreground "steel blue")) + (t + (:bold t :italic t))) + "Face used for displaying newsgroups headers." + :group 'message-faces) + +(defface message-header-name-face + '((((class color) + (background dark)) + (:foreground "DarkGreen")) + (((class color) + (background light)) + (:foreground "cornflower blue")) + (t + (:bold t))) + "Face used for displaying header names." + :group 'message-faces) + +(defface message-header-xheader-face + '((((class color) + (background dark)) + (:foreground "blue")) + (((class color) + (background light)) + (:foreground "blue")) + (t + (:bold t))) + "Face used for displaying X-Header headers." + :group 'message-faces) + +(defface message-separator-face + '((((class color) + (background dark)) + (:foreground "blue4")) + (((class color) + (background light)) + (:foreground "brown")) + (t + (:bold t))) + "Face used for displaying the separator." + :group 'message-faces) + +(defface message-cited-text-face + '((((class color) + (background dark)) + (:foreground "red")) + (((class color) + (background light)) + (:foreground "red")) + (t + (:bold t))) + "Face used for displaying cited text names." + :group 'message-faces) + +(defvar message-font-lock-keywords + (let* ((cite-prefix "A-Za-z") + (cite-suffix (concat cite-prefix "0-9_.@-")) + (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)")) + `((,(concat "^\\([Tt]o:\\)" content) + (1 'message-header-name-face) + (2 'message-header-to-face nil t)) + (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (1 'message-header-name-face) + (2 'message-header-cc-face nil t)) + (,(concat "^\\([Ss]ubject:\\)" content) + (1 'message-header-name-face) + (2 'message-header-subject-face nil t)) + (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) + (1 'message-header-name-face) + (2 'message-header-newsgroups-face nil t)) + (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) + (1 'message-header-name-face) + (2 'message-header-other-face nil t)) + (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) + (1 'message-header-name-face) + (2 'message-header-name-face)) + (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") + 1 'message-separator-face) + (,(concat "^[ \t]*" + "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" + "[>|}].*") + (0 'message-cited-text-face)))) + "Additional expressions to highlight in Message mode.") + +(defvar message-face-alist + '((bold . bold-region) + (underline . underline-region) + (default . (lambda (b e) + (unbold-region b e) + (ununderline-region b e)))) + "Alist of mail and news faces for facemenu. +The cdr of ech entry is a function for applying the face to a region.") + +(defcustom message-send-hook nil + "Hook run before sending messages." + :group 'message-various + :options '(ispell-message) + :type 'hook) + +(defcustom message-send-mail-hook nil + "Hook run before sending mail messages." + :group 'message-various + :type 'hook) + +(defcustom message-send-news-hook nil + "Hook run before sending news messages." + :group 'message-various + :type 'hook) + +(defcustom message-sent-hook nil + "Hook run after sending messages." + :group 'message-various + :type 'hook) + +;;; Internal variables. + +(defvar message-buffer-list nil) +(defvar message-this-is-news nil) +(defvar message-this-is-mail nil) +(defvar message-draft-article nil) + +;; Byte-compiler warning +(defvar gnus-active-hashtb) +(defvar gnus-read-active-file) + +;;; Regexp matching the delimiter of messages in UNIX mail format +;;; (UNIX From lines), minus the initial ^. It should be a copy +;;; of rmail.el's rmail-unix-mail-delimiter. +(defvar message-unix-mail-delimiter + (let ((time-zone-regexp + (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?" + "\\|[-+]?[0-9][0-9][0-9][0-9]" + "\\|" + "\\) *"))) + (concat + "From " + + ;; Many things can happen to an RFC 822 mailbox before it is put into + ;; a `From' line. The leading phrase can be stripped, e.g. + ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. + ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF + ;; can be removed, e.g. + ;; From: joe@y.z (Joe K + ;; User) + ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and + ;; From: Joe User + ;; + ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. + ;; The mailbox can be removed or be replaced by white space, e.g. + ;; From: "Joe User"{space}{tab} + ;; + ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', + ;; where {space} and {tab} represent the Ascii space and tab characters. + ;; We want to match the results of any of these manglings. + ;; The following regexp rejects names whose first characters are + ;; obviously bogus, but after that anything goes. + "\\([^\0-\b\n-\r\^?].*\\)? " + + ;; The time the message was sent. + "\\([^\0-\r \^?]+\\) +" ; day of the week + "\\([^\0-\r \^?]+\\) +" ; month + "\\([0-3]?[0-9]\\) +" ; day of month + "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day + + ;; Perhaps a time zone, specified by an abbreviation, or by a + ;; numeric offset. + time-zone-regexp + + ;; The year. + " \\([0-9][0-9]+\\) *" + + ;; On some systems the time zone can appear after the year, too. + time-zone-regexp + + ;; Old uucp cruft. + "\\(remote from .*\\)?" + + "\n")) + "Regexp matching the delimiter of messages in UNIX mail format.") + +(defvar message-unsent-separator + (concat "^ *---+ +Unsent message follows +---+ *$\\|" + "^ *---+ +Returned message +---+ *$\\|" + "^Start of returned message$\\|" + "^ *---+ +Original message +---+ *$\\|" + "^ *--+ +begin message +--+ *$\\|" + "^ *---+ +Original message follows +---+ *$\\|" + "^|? *---+ +Message text follows: +---+ *|?$") + "A regexp that matches the separator before the text of a failed message.") + +(defvar message-header-format-alist + `((Newsgroups) + (To . message-fill-address) + (Cc . message-fill-address) + (Subject) + (In-Reply-To) + (Fcc) + (Bcc) + (Date) + (Organization) + (Distribution) + (Lines) + (Expires) + (Message-ID) + (References) + (X-Mailer) + (X-Newsreader)) + "Alist used for formatting headers.") + +(eval-and-compile + (autoload 'message-setup-toolbar "messagexmas") + (autoload 'mh-send-letter "mh-comp") + (autoload 'gnus-point-at-eol "gnus-util") + (autoload 'gnus-point-at-bol "gnus-util") + (autoload 'gnus-output-to-mail "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") + (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") + (autoload 'nndraft-request-associate-buffer "nndraft") + (autoload 'nndraft-request-expire-articles "nndraft")) + + + +;;; +;;; Utility functions. +;;; + +(defmacro message-y-or-n-p (question show &rest text) + "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" + `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) + +;; Delete the current line (and the next N lines.); +(defmacro message-delete-line (&optional n) + `(delete-region (progn (beginning-of-line) (point)) + (progn (forward-line ,(or n 1)) (point)))) + +(defun message-tokenize-header (header &optional separator) + "Split HEADER into a list of header elements. +\",\" is used as the separator." + (if (not header) + nil + (let ((regexp (format "[%s]+" (or separator ","))) + (beg 1) + (first t) + quoted elems paren) + (save-excursion + (message-set-work-buffer) + (insert header) + (goto-char (point-min)) + (while (not (eobp)) + (if first + (setq first nil) + (forward-char 1)) + (cond ((and (> (point) beg) + (or (eobp) + (and (looking-at regexp) + (not quoted) + (not paren)))) + (push (buffer-substring beg (point)) elems) + (setq beg (match-end 0))) + ((= (following-char) ?\") + (setq quoted (not quoted))) + ((and (= (following-char) ?\() + (not quoted)) + (setq paren t)) + ((and (= (following-char) ?\)) + (not quoted)) + (setq paren nil)))) + (nreverse elems))))) + +(defun message-mail-file-mbox-p (file) + "Say whether FILE looks like a Unix mbox file." + (when (and (file-exists-p file) + (file-readable-p file) + (file-regular-p file)) + (nnheader-temp-write nil + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (looking-at message-unix-mail-delimiter)))) + +(defun message-fetch-field (header &optional not-all) + "The same as `mail-fetch-field', only remove all newlines." + (let ((value (mail-fetch-field header nil (not not-all)))) + (when value + (nnheader-replace-chars-in-string value ?\n ? )))) + +(defun message-add-header (&rest headers) + "Add the HEADERS to the message header, skipping those already present." + (while headers + (let (hclean) + (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) + (error "Invalid header `%s'" (car headers))) + (setq hclean (match-string 1 (car headers))) + (save-restriction + (message-narrow-to-headers) + (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) + (insert (car headers) ?\n)))) + (setq headers (cdr headers)))) + +(defun message-fetch-reply-field (header) + "Fetch FIELD from the message we're replying to." + (when (and message-reply-buffer + (buffer-name message-reply-buffer)) + (save-excursion + (set-buffer message-reply-buffer) + (message-fetch-field header)))) + +(defun message-set-work-buffer () + (if (get-buffer " *message work*") + (progn + (set-buffer " *message work*") + (erase-buffer)) + (set-buffer (get-buffer-create " *message work*")) + (kill-all-local-variables) + (buffer-disable-undo (current-buffer)))) + +(defun message-functionp (form) + "Return non-nil if FORM is funcallable." + (or (and (symbolp form) (fboundp form)) + (and (listp form) (eq (car form) 'lambda)) + (byte-code-function-p form))) + +(defun message-strip-subject-re (subject) + "Remove \"Re:\" from subject lines." + (if (string-match "^[Rr][Ee]: *" subject) + (substring subject (match-end 0)) + subject)) + +(defun message-remove-header (header &optional is-regexp first reverse) + "Remove HEADER in the narrowed buffer. +If REGEXP, HEADER is a regular expression. +If FIRST, only remove the first instance of the header. +Return the number of headers removed." + (goto-char (point-min)) + (let ((regexp (if is-regexp header (concat "^" header ":"))) + (number 0) + (case-fold-search t) + last) + (while (and (not (eobp)) + (not last)) + (if (if reverse + (not (looking-at regexp)) + (looking-at regexp)) + (progn + (incf number) + (when first + (setq last t)) + (delete-region + (point) + ;; There might be a continuation header, so we have to search + ;; until we find a new non-continuation line. + (progn + (forward-line 1) + (if (re-search-forward "^[^ \t]" nil t) + (goto-char (match-beginning 0)) + (point-max))))) + (forward-line 1) + (if (re-search-forward "^[^ \t]" nil t) + (goto-char (match-beginning 0)) + (point-max)))) + number)) + +(defun message-narrow-to-headers () + "Narrow the buffer to the head of the message." + (widen) + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min))) + +(defun message-narrow-to-head () + "Narrow the buffer to the head of the message." + (widen) + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil 1) + (1- (point)) + (point-max))) + (goto-char (point-min))) + +(defun message-news-p () + "Say whether the current buffer contains a news message." + (or message-this-is-news + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "newsgroups"))))) + +(defun message-mail-p () + "Say whether the current buffer contains a mail message." + (or message-this-is-mail + (save-excursion + (save-restriction + (message-narrow-to-headers) + (or (message-fetch-field "to") + (message-fetch-field "cc") + (message-fetch-field "bcc")))))) + +(defun message-next-header () + "Go to the beginning of the next header." + (beginning-of-line) + (or (eobp) (forward-char 1)) + (not (if (re-search-forward "^[^ \t]" nil t) + (beginning-of-line) + (goto-char (point-max))))) + +(defun message-sort-headers-1 () + "Sort the buffer as headers using `message-rank' text props." + (goto-char (point-min)) + (sort-subr + nil 'message-next-header + (lambda () + (message-next-header) + (unless (bobp) + (forward-char -1))) + (lambda () + (or (get-text-property (point) 'message-rank) + 10000)))) + +(defun message-sort-headers () + "Sort the headers of the current message according to `message-header-format-alist'." + (interactive) + (save-excursion + (save-restriction + (let ((max (1+ (length message-header-format-alist))) + rank) + (message-narrow-to-headers) + (while (re-search-forward "^[^ \n]+:" nil t) + (put-text-property + (match-beginning 0) (1+ (match-beginning 0)) + 'message-rank + (if (setq rank (length (memq (assq (intern (buffer-substring + (match-beginning 0) + (1- (match-end 0)))) + message-header-format-alist) + message-header-format-alist))) + (- max rank) + (1+ max))))) + (message-sort-headers-1)))) + + + +;;; +;;; Message mode +;;; + +;;; Set up keymap. + +(defvar message-mode-map nil) + +(unless message-mode-map + (setq message-mode-map (copy-keymap text-mode-map)) + (define-key message-mode-map "\C-c?" 'describe-mode) + + (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) + (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) + (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) + (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) + (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) + (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) + (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) + (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) + (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) + (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) + (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) + (define-key message-mode-map "\C-c\C-b" 'message-goto-body) + (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) + + (define-key message-mode-map "\C-c\C-t" 'message-insert-to) + (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) + + (define-key message-mode-map "\C-c\C-y" 'message-yank-original) + (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) + (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) + (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body) + (define-key message-mode-map "\C-c\C-o" 'message-sort-headers) + (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer) + + (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit) + (define-key message-mode-map "\C-c\C-s" 'message-send) + (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) + (define-key message-mode-map "\C-c\C-d" 'message-dont-send) + + (define-key message-mode-map "\C-c\C-e" 'message-elide-region) + (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) + (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) + + (define-key message-mode-map "\t" 'message-tab)) + +(easy-menu-define + message-mode-menu message-mode-map "Message Menu." + '("Message" + ["Sort Headers" message-sort-headers t] + ["Yank Original" message-yank-original t] + ["Fill Yanked Message" message-fill-yanked-message t] + ["Insert Signature" message-insert-signature t] + ["Caesar (rot13) Message" message-caesar-buffer-body t] + ["Caesar (rot13) Region" message-caesar-region (mark t)] + ["Elide Region" message-elide-region (mark t)] + ["Delete Outside Region" message-delete-not-region (mark t)] + ["Newline and Reformat" message-newline-and-reformat t] + ["Rename buffer" message-rename-buffer t] + ["Spellcheck" ispell-message t] + "----" + ["Send Message" message-send-and-exit t] + ["Abort Message" message-dont-send t])) + +(easy-menu-define + message-mode-field-menu message-mode-map "" + '("Field" + ["Fetch To" message-insert-to t] + ["Fetch Newsgroups" message-insert-newsgroups t] + "----" + ["To" message-goto-to t] + ["Subject" message-goto-subject t] + ["Cc" message-goto-cc t] + ["Reply-To" message-goto-reply-to t] + ["Summary" message-goto-summary t] + ["Keywords" message-goto-keywords t] + ["Newsgroups" message-goto-newsgroups t] + ["Followup-To" message-goto-followup-to t] + ["Distribution" message-goto-distribution t] + ["Body" message-goto-body t] + ["Signature" message-goto-signature t])) + +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) + +;;;###autoload +(defun message-mode () + "Major mode for editing mail and news to be sent. +Like Text Mode but with these additional commands: +C-c C-s message-send (send the message) C-c C-c message-send-and-exit +C-c C-f move to a header field (and create it if there isn't): + C-c C-f C-t move to To C-c C-f C-s move to Subject + C-c C-f C-c move to Cc C-c C-f C-b move to Bcc + C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To + C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups + C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution + C-c C-f C-f move to Followup-To +C-c C-t message-insert-to (add a To header to a news followup) +C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply) +C-c C-b message-goto-body (move to beginning of message text). +C-c C-i message-goto-signature (move to the beginning of the signature). +C-c C-w message-insert-signature (insert `message-signature-file' file). +C-c C-y message-yank-original (insert current message, if any). +C-c C-q message-fill-yanked-message (fill what was yanked). +C-c C-e message-elide-region (elide the text between point and mark). +C-c C-r message-caesar-buffer-body (rot13 the message body)." + (interactive) + (kill-all-local-variables) + (make-local-variable 'message-reply-buffer) + (setq message-reply-buffer nil) + (make-local-variable 'message-send-actions) + (make-local-variable 'message-exit-actions) + (make-local-variable 'message-kill-actions) + (make-local-variable 'message-postpone-actions) + (make-local-variable 'message-draft-article) + (make-local-hook 'kill-buffer-hook) + (set-syntax-table message-mode-syntax-table) + (use-local-map message-mode-map) + (setq local-abbrev-table message-mode-abbrev-table) + (setq major-mode 'message-mode) + (setq mode-name "Message") + (setq buffer-offer-save t) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(message-font-lock-keywords t)) + (make-local-variable 'facemenu-add-face-function) + (make-local-variable 'facemenu-remove-face-function) + (setq facemenu-add-face-function + (lambda (face end) + (let ((face-fun (cdr (assq face message-face-alist)))) + (if face-fun + (funcall face-fun (point) end) + (error "Face %s not configured for %s mode" face mode-name))) + "") + facemenu-remove-face-function t) + (make-local-variable 'paragraph-separate) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat (regexp-quote mail-header-separator) + "$\\|[ \t]*[-_][-_][-_]+$\\|" + "-- $\\|" + "[> ]+$\\|" + paragraph-start)) + (setq paragraph-separate (concat (regexp-quote mail-header-separator) + "$\\|[ \t]*[-_][-_][-_]+$\\|" + "-- $\\|" + "[> ]+$\\|" + paragraph-separate)) + (make-local-variable 'message-reply-headers) + (setq message-reply-headers nil) + (make-local-variable 'message-newsreader) + (make-local-variable 'message-mailer) + (make-local-variable 'message-post-method) + (make-local-variable 'message-sent-message-via) + (setq message-sent-message-via nil) + (make-local-variable 'message-checksum) + (setq message-checksum nil) + ;;(when (fboundp 'mail-hist-define-keys) + ;; (mail-hist-define-keys)) + (when (string-match "XEmacs\\|Lucid" emacs-version) + (message-setup-toolbar)) + (easy-menu-add message-mode-menu message-mode-map) + (easy-menu-add message-mode-field-menu message-mode-map) + ;; Allow mail alias things. + (when (eq message-mail-alias-type 'abbrev) + (if (fboundp 'mail-abbrevs-setup) + (mail-abbrevs-setup) + (funcall (intern "mail-aliases-setup")))) + (message-set-auto-save-file-name) + (run-hooks 'text-mode-hook 'message-mode-hook)) + + + +;;; +;;; Message mode commands +;;; + +;;; Movement commands + +(defun message-goto-to () + "Move point to the To header." + (interactive) + (message-position-on-field "To")) + +(defun message-goto-subject () + "Move point to the Subject header." + (interactive) + (message-position-on-field "Subject")) + +(defun message-goto-cc () + "Move point to the Cc header." + (interactive) + (message-position-on-field "Cc" "To")) + +(defun message-goto-bcc () + "Move point to the Bcc header." + (interactive) + (message-position-on-field "Bcc" "Cc" "To")) + +(defun message-goto-fcc () + "Move point to the Fcc header." + (interactive) + (message-position-on-field "Fcc" "To" "Newsgroups")) + +(defun message-goto-reply-to () + "Move point to the Reply-To header." + (interactive) + (message-position-on-field "Reply-To" "Subject")) + +(defun message-goto-newsgroups () + "Move point to the Newsgroups header." + (interactive) + (message-position-on-field "Newsgroups")) + +(defun message-goto-distribution () + "Move point to the Distribution header." + (interactive) + (message-position-on-field "Distribution")) + +(defun message-goto-followup-to () + "Move point to the Followup-To header." + (interactive) + (message-position-on-field "Followup-To" "Newsgroups")) + +(defun message-goto-keywords () + "Move point to the Keywords header." + (interactive) + (message-position-on-field "Keywords" "Subject")) + +(defun message-goto-summary () + "Move point to the Summary header." + (interactive) + (message-position-on-field "Summary" "Subject")) + +(defun message-goto-body () + "Move point to the beginning of the message body." + (interactive) + (if (looking-at "[ \t]*\n") (expand-abbrev)) + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t)) + +(defun message-goto-signature () + "Move point to the beginning of the message signature." + (interactive) + (goto-char (point-min)) + (if (re-search-forward message-signature-separator nil t) + (forward-line 1) + (goto-char (point-max)))) + + + +(defun message-insert-to (&optional force) + "Insert a To header that points to the author of the article being replied to. +If the original author requested not to be sent mail, the function signals +an error. +With the prefix argument FORCE, insert the header anyway." + (interactive "P") + (let ((co (message-fetch-reply-field "mail-copies-to"))) + (when (and (null force) + co + (equal (downcase co) "never")) + (error "The user has requested not to have copies sent via mail"))) + (when (and (message-position-on-field "To") + (mail-fetch-field "to") + (not (string-match "\\` *\\'" (mail-fetch-field "to")))) + (insert ", ")) + (insert (or (message-fetch-reply-field "reply-to") + (message-fetch-reply-field "from") ""))) + +(defun message-insert-newsgroups () + "Insert the Newsgroups header from the article being replied to." + (interactive) + (when (and (message-position-on-field "Newsgroups") + (mail-fetch-field "newsgroups") + (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups")))) + (insert ",")) + (insert (or (message-fetch-reply-field "newsgroups") ""))) + + + +;;; Various commands + +(defun message-delete-not-region (beg end) + "Delete everything in the body of the current message that is outside of the region." + (interactive "r") + (save-excursion + (goto-char end) + (delete-region (point) (progn (message-goto-signature) + (forward-line -2) + (point))) + (insert "\n") + (goto-char beg) + (delete-region beg (progn (message-goto-body) + (forward-line 2) + (point)))) + (message-goto-signature) + (forward-line -2)) + +(defun message-newline-and-reformat () + "Insert four newlines, and then reformat if inside quoted text." + (interactive) + (let ((point (point)) + quoted) + (save-excursion + (beginning-of-line) + (setq quoted (looking-at (regexp-quote message-yank-prefix)))) + (insert "\n\n\n\n") + (when quoted + (insert message-yank-prefix)) + (fill-paragraph nil) + (goto-char point) + (forward-line 2))) + +(defun message-insert-signature (&optional force) + "Insert a signature. See documentation for the `message-signature' variable." + (interactive (list 0)) + (let* ((signature + (cond + ((and (null message-signature) + (eq force 0)) + (save-excursion + (goto-char (point-max)) + (not (re-search-backward + message-signature-separator nil t)))) + ((and (null message-signature) + force) + t) + ((message-functionp message-signature) + (funcall message-signature)) + ((listp message-signature) + (eval message-signature)) + (t message-signature))) + (signature + (cond ((stringp signature) + signature) + ((and (eq t signature) + message-signature-file + (file-exists-p message-signature-file)) + signature)))) + (when signature + (goto-char (point-max)) + ;; Insert the signature. + (unless (bolp) + (insert "\n")) + (insert "\n-- \n") + (if (eq signature t) + (insert-file-contents message-signature-file) + (insert signature)) + (goto-char (point-max)) + (or (bolp) (insert "\n"))))) + +(defun message-elide-region (b e) + "Elide the text between point and mark. An ellipsis (from +message-elide-elipsis) will be inserted where the text was killed." + (interactive "r") + (kill-region b e) + (unless (bolp) + (insert "\n")) + (insert message-elide-elipsis)) + +(defvar message-caesar-translation-table nil) + +(defun message-caesar-region (b e &optional n) + "Caesar rotation of region by N, default 13, for decrypting netnews." + (interactive + (list + (min (point) (or (mark t) (point))) + (max (point) (or (mark t) (point))) + (when current-prefix-arg + (prefix-numeric-value current-prefix-arg)))) + + (setq n (if (numberp n) (mod n 26) 13)) ;canonize N + (unless (or (zerop n) ; no action needed for a rot of 0 + (= b e)) ; no region to rotate + ;; We build the table, if necessary. + (when (or (not message-caesar-translation-table) + (/= (aref message-caesar-translation-table ?a) (+ ?a n))) + (setq message-caesar-translation-table + (message-make-caesar-translation-table n))) + ;; Then we translate the region. Do it this way to retain + ;; text properties. + (while (< b e) + (subst-char-in-region + b (1+ b) (char-after b) + (aref message-caesar-translation-table (char-after b))) + (incf b)))) + +(defun message-make-caesar-translation-table (n) + "Create a rot table with offset N." + (let ((i -1) + (table (make-string 256 0))) + (while (< (incf i) 256) + (aset table i i)) + (concat + (substring table 0 ?A) + (substring table (+ ?A n) (+ ?A n (- 26 n))) + (substring table ?A (+ ?A n)) + (substring table (+ ?A 26) ?a) + (substring table (+ ?a n) (+ ?a n (- 26 n))) + (substring table ?a (+ ?a n)) + (substring table (+ ?a 26) 255)))) + +(defun message-caesar-buffer-body (&optional rotnum) + "Caesar rotates all letters in the current buffer by 13 places. +Used to encode/decode possibly offensive messages (commonly in net.jokes). +With prefix arg, specifies the number of places to rotate each letter forward. +Mail and USENET news headers are not rotated." + (interactive (if current-prefix-arg + (list (prefix-numeric-value current-prefix-arg)) + (list nil))) + (save-excursion + (save-restriction + (when (message-goto-body) + (narrow-to-region (point) (point-max))) + (message-caesar-region (point-min) (point-max) rotnum)))) + +(defun message-pipe-buffer-body (program) + "Pipe the message body in the current buffer through PROGRAM." + (save-excursion + (save-restriction + (when (message-goto-body) + (narrow-to-region (point) (point-max))) + (let ((body (buffer-substring (point-min) (point-max)))) + (unless (equal 0 (call-process-region + (point-min) (point-max) program t t)) + (insert body) + (message "%s failed." program)))))) + +(defun message-rename-buffer (&optional enter-string) + "Rename the *message* buffer to \"*message* RECIPIENT\". +If the function is run with a prefix, it will ask for a new buffer +name, rather than giving an automatic name." + (interactive "Pbuffer name: ") + (save-excursion + (save-restriction + (goto-char (point-min)) + (narrow-to-region (point) + (search-forward mail-header-separator nil 'end)) + (let* ((mail-to (or + (if (message-news-p) (message-fetch-field "Newsgroups") + (message-fetch-field "To")) + "")) + (mail-trimmed-to + (if (string-match "," mail-to) + (concat (substring mail-to 0 (match-beginning 0)) ", ...") + mail-to)) + (name-default (concat "*message* " mail-trimmed-to)) + (name (if enter-string + (read-string "New buffer name: " name-default) + name-default)) + (default-directory + (file-name-as-directory message-autosave-directory))) + (rename-buffer name t))))) + +(defun message-fill-yanked-message (&optional justifyp) + "Fill the paragraphs of a message yanked into this one. +Numeric argument means justify as well." + (interactive "P") + (save-excursion + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t) + (let ((fill-prefix message-yank-prefix)) + (fill-individual-paragraphs (point) (point-max) justifyp t)))) + +(defun message-indent-citation () + "Modify text just inserted from a message to be cited. +The inserted text should be the region. +When this function returns, the region is again around the modified text. + +Normally, indent each nonblank line `message-indentation-spaces' spaces. +However, if `message-yank-prefix' is non-nil, insert that prefix on each line." + (let ((start (point))) + ;; Remove unwanted headers. + (when message-ignored-cited-headers + (let (all-removed) + (save-restriction + (narrow-to-region + (goto-char start) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point))) + (message-remove-header message-ignored-cited-headers t) + (when (= (point-min) (point-max)) + (setq all-removed t)) + (goto-char (point-max))) + (if all-removed + (goto-char start) + (forward-line 1)))) + ;; Delete blank lines at the start of the buffer. + (while (and (point-min) + (eolp) + (not (eobp))) + (message-delete-line)) + ;; Delete blank lines at the end of the buffer. + (goto-char (point-max)) + (unless (eolp) + (insert "\n")) + (while (and (zerop (forward-line -1)) + (looking-at "$")) + (message-delete-line)) + ;; Do the indentation. + (if (null message-yank-prefix) + (indent-rigidly start (mark t) message-indentation-spaces) + (save-excursion + (goto-char start) + (while (< (point) (mark t)) + (insert message-yank-prefix) + (forward-line 1)))) + (goto-char start))) + +(defun message-yank-original (&optional arg) + "Insert the message being replied to, if any. +Puts point before the text and mark after. +Normally indents each nonblank line ARG spaces (default 3). However, +if `message-yank-prefix' is non-nil, insert that prefix on each line. + +This function uses `message-cite-function' to do the actual citing. + +Just \\[universal-argument] as argument means don't indent, insert no +prefix, and don't delete any headers." + (interactive "P") + (let ((modified (buffer-modified-p))) + (when (and message-reply-buffer + message-cite-function) + (delete-windows-on message-reply-buffer t) + (insert-buffer message-reply-buffer) + (funcall message-cite-function) + (message-exchange-point-and-mark) + (unless (bolp) + (insert ?\n)) + (unless modified + (setq message-checksum (cons (message-checksum) (buffer-size))))))) + +(defun message-cite-original () + "Cite function in the standard Message manner." + (let ((start (point)) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function))))) + (goto-char start) + (while functions + (funcall (pop functions))) + (when message-citation-line-function + (unless (bolp) + (insert "\n")) + (funcall message-citation-line-function)))) + +(defun message-insert-citation-line () + "Function that inserts a simple citation line." + (when message-reply-headers + (insert (mail-header-from message-reply-headers) " writes:\n\n"))) + +(defun message-position-on-field (header &rest afters) + (let ((case-fold-search t)) + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (progn + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (match-beginning 0))) + (goto-char (point-min)) + (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t) + (progn + (re-search-forward "^[^ \t]" nil 'move) + (beginning-of-line) + (skip-chars-backward "\n") + t) + (while (and afters + (not (re-search-forward + (concat "^" (regexp-quote (car afters)) ":") + nil t))) + (pop afters)) + (when afters + (re-search-forward "^[^ \t]" nil 'move) + (beginning-of-line)) + (insert header ": \n") + (forward-char -1) + nil)))) + +(defun message-remove-signature () + "Remove the signature from the text between point and mark. +The text will also be indented the normal way." + (save-excursion + (let ((start (point)) + mark) + (if (not (re-search-forward message-signature-separator (mark t) t)) + ;; No signature here, so we just indent the cited text. + (message-indent-citation) + ;; Find the last non-empty line. + (forward-line -1) + (while (looking-at "[ \t]*$") + (forward-line -1)) + (forward-line 1) + (setq mark (set-marker (make-marker) (point))) + (goto-char start) + (message-indent-citation) + ;; Enable undoing the deletion. + (undo-boundary) + (delete-region mark (mark t)) + (set-marker mark nil))))) + + + +;;; +;;; Sending messages +;;; + +(defun message-send-and-exit (&optional arg) + "Send message like `message-send', then, if no errors, exit from mail buffer." + (interactive "P") + (let ((buf (current-buffer)) + (actions message-exit-actions)) + (when (and (message-send arg) + (buffer-name buf)) + (if message-kill-buffer-on-exit + (kill-buffer buf) + (bury-buffer buf) + (when (eq buf (current-buffer)) + (message-bury buf))) + (message-do-actions actions)))) + +(defun message-dont-send () + "Don't send the message you have been editing." + (interactive) + (let ((actions message-postpone-actions)) + (message-bury (current-buffer)) + (message-do-actions actions))) + +(defun message-kill-buffer () + "Kill the current buffer." + (interactive) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Message modified; kill anyway? ")) + (let ((actions message-kill-actions)) + (setq buffer-file-name nil) + (kill-buffer (current-buffer)) + (message-do-actions actions)))) + +(defun message-bury (buffer) + "Bury this mail buffer." + (let ((newbuf (other-buffer buffer))) + (bury-buffer buffer) + (if (and (fboundp 'frame-parameters) + (cdr (assq 'dedicated (frame-parameters))) + (not (null (delq (selected-frame) (visible-frame-list))))) + (delete-frame (selected-frame)) + (switch-to-buffer newbuf)))) + +(defun message-send (&optional arg) + "Send the message in the current buffer. +If `message-interactive' is non-nil, wait for success indication +or error messages, and inform user. +Otherwise any failure is reported in a message back to +the user from the mailer." + (interactive "P") + ;; Disabled test. + (when (if (and buffer-file-name + nil) + (y-or-n-p (format "Send buffer contents as %s message? " + (if (message-mail-p) + (if (message-news-p) "mail and news" "mail") + "news"))) + (or (buffer-modified-p) + (message-check-element 'unchanged) + (y-or-n-p "No changes in the buffer; really send? "))) + ;; Make it possible to undo the coming changes. + (undo-boundary) + (let ((inhibit-read-only t)) + (put-text-property (point-min) (point-max) 'read-only nil)) + (message-fix-before-sending) + (run-hooks 'message-send-hook) + (message "Sending...") + (let ((alist message-send-method-alist) + (success t) + elem sent) + (while (and success + (setq elem (pop alist))) + (when (and (or (not (funcall (cadr elem))) + (and (or (not (memq (car elem) + message-sent-message-via)) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem)))) + (setq success (funcall (caddr elem) arg))))) + (setq sent t))) + (when (and success sent) + (message-do-fcc) + ;;(when (fboundp 'mail-hist-put-headers-into-history) + ;; (mail-hist-put-headers-into-history)) + (run-hooks 'message-sent-hook) + (message "Sending...done") + ;; Mark the buffer as unmodified and delete autosave. + (set-buffer-modified-p nil) + (delete-auto-save-file-if-necessary t) + (message-disassociate-draft) + ;; Delete other mail buffers and stuff. + (message-do-send-housekeeping) + (message-do-actions message-send-actions) + ;; Return success. + t)))) + +(defun message-send-via-mail (arg) + "Send the current message via mail." + (message-send-mail arg)) + +(defun message-send-via-news (arg) + "Send the current message via news." + (funcall message-send-news-function arg)) + +(defun message-fix-before-sending () + "Do various things to make the message nice before sending it." + ;; Make sure there's a newline at the end of the message. + (goto-char (point-max)) + (unless (bolp) + (insert "\n"))) + +(defun message-add-action (action &rest types) + "Add ACTION to be performed when doing an exit of type TYPES." + (let (var) + (while types + (set (setq var (intern (format "message-%s-actions" (pop types)))) + (nconc (symbol-value var) (list action)))))) + +(defun message-do-actions (actions) + "Perform all actions in ACTIONS." + ;; Now perform actions on successful sending. + (while actions + (ignore-errors + (cond + ;; A simple function. + ((message-functionp (car actions)) + (funcall (car actions))) + ;; Something to be evaled. + (t + (eval (car actions))))) + (pop actions))) + +(defun message-send-mail (&optional arg) + (require 'mail-utils) + (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) + (case-fold-search nil) + (news (message-news-p)) + (mailbuf (current-buffer))) + (save-restriction + (message-narrow-to-headers) + ;; Insert some headers. + (let ((message-deletable-headers + (if news nil message-deletable-headers))) + (message-generate-headers message-required-mail-headers)) + ;; Let the user do all of the above. + (run-hooks 'message-header-hook)) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer mailbuf) + (buffer-string)))) + ;; Remove some headers. + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (when (and news + (or (message-fetch-field "cc") + (message-fetch-field "to"))) + (message-insert-courtesy-copy)) + (funcall message-send-mail-function)) + (kill-buffer tembuf)) + (set-buffer mailbuf) + (push 'mail message-sent-message-via))) + +(defun message-send-mail-with-sendmail () + "Send off the prepared buffer with sendmail." + (let ((errbuf (if message-interactive + (generate-new-buffer " sendmail errors") + 0)) + resend-to-addresses delimline) + (let ((case-fold-search t)) + (save-restriction + (message-narrow-to-headers) + (setq resend-to-addresses (message-fetch-field "resent-to"))) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (when (eval message-mailer-swallows-blank-line) + (newline)) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + (let ((default-directory "/")) + (apply 'call-process-region + (append (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (user-login-name))) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t"))))) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (goto-char (point-min)) + (while (re-search-forward "\n\n* *" nil t) + (replace-match "; ")) + (if (not (zerop (buffer-size))) + (error "Sending...failed to %s" + (buffer-substring (point-min) (point-max))))) + (when (bufferp errbuf) + (kill-buffer errbuf))))) + +(defun message-send-mail-with-qmail () + "Pass the prepared message buffer to qmail-inject. +Refer to the documentation for the variable `message-send-mail-function' +to find out how to use this." + ;; replace the header delimiter with a blank line + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (run-hooks 'message-send-mail-hook) + ;; send the message + (case + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args) + ;; qmail-inject doesn't say anything on it's stdout/stderr, + ;; we have to look at the retval instead + (0 nil) + (1 (error "qmail-inject reported permanent failure")) + (111 (error "qmail-inject reported transient failure")) + ;; should never happen + (t (error "qmail-inject reported unknown failure")))) + +(defun message-send-mail-with-mh () + "Send the prepared message buffer with mh." + (let ((mh-previous-window-config nil) + (name (make-temp-name + (concat (file-name-as-directory + (expand-file-name message-autosave-directory)) + "msg.")))) + (setq buffer-file-name name) + ;; MH wants to generate these headers itself. + (when message-mh-deletable-headers + (let ((headers message-mh-deletable-headers)) + (while headers + (goto-char (point-min)) + (and (re-search-forward + (concat "^" (symbol-name (car headers)) ": *") nil t) + (message-delete-line)) + (pop headers)))) + (run-hooks 'message-send-mail-hook) + ;; Pass it on to mh. + (mh-send-letter))) + +(defun message-send-news (&optional arg) + (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) + (case-fold-search nil) + (method (if (message-functionp message-post-method) + (funcall message-post-method arg) + message-post-method)) + (messbuf (current-buffer)) + (message-syntax-checks + (if arg + (cons '(existing-newsgroups . disabled) + message-syntax-checks) + message-syntax-checks)) + result) + (save-restriction + (message-narrow-to-headers) + ;; Insert some headers. + (message-generate-headers message-required-news-headers) + ;; Let the user do all of the above. + (run-hooks 'message-header-hook)) + (message-cleanup-headers) + (if (not (message-check-news-syntax)) + (progn + ;;(message "Posting not performed") + nil) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer messbuf) + (buffer-string)))) + ;; Remove some headers. + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-news-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (let ((case-fold-search t)) + ;; Remove the delimiter. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1)) + (run-hooks 'message-send-news-hook) + ;;(require (car method)) + ;;(funcall (intern (format "%s-open-server" (car method))) + ;;(cadr method) (cddr method)) + ;;(setq result + ;; (funcall (intern (format "%s-request-post" (car method))) + ;; (cadr method))) + (gnus-open-server method) + (setq result (gnus-request-post method))) + (kill-buffer tembuf)) + (set-buffer messbuf) + (if result + (push 'news message-sent-message-via) + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method))) + nil)))) + +;;; +;;; Header generation & syntax checking. +;;; + +(defmacro message-check (type &rest forms) + "Eval FORMS if TYPE is to be checked." + `(or (message-check-element ,type) + (save-excursion + ,@forms))) + +(put 'message-check 'lisp-indent-function 1) +(put 'message-check 'edebug-form-spec '(form body)) + +(defun message-check-element (type) + "Returns non-nil if this type is not to be checked." + (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) + t + (let ((able (assq type message-syntax-checks))) + (and (consp able) + (eq (cdr able) 'disabled))))) + +(defun message-check-news-syntax () + "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-news-header-syntax))) + ;; Check the body. + (message-check-news-body-syntax))))) + +(defun message-check-news-header-syntax () + (and + ;; Check the Subject header. + (message-check 'subject + (let* ((case-fold-search t) + (subject (message-fetch-field "subject"))) + (or + (and subject + (not (string-match "\\`[ \t]*\\'" subject))) + (ignore + (message + "The subject field is empty or missing. Posting is denied."))))) + ;; Check for commands in Subject. + (message-check 'subject-cmsg + (if (string-match "^cmsg " (message-fetch-field "subject")) + (y-or-n-p + "The control code \"cmsg\" is in the subject. Really post? ") + t)) + ;; Check for multiple identical headers. + (message-check 'multiple-headers + (let (found) + (while (and (not found) + (re-search-forward "^[^ \t:]+: " nil t)) + (save-excursion + (or (re-search-forward + (concat "^" + (regexp-quote + (setq found + (buffer-substring + (match-beginning 0) (- (match-end 0) 2)))) + ":") + nil t) + (setq found nil)))) + (if found + (y-or-n-p (format "Multiple %s headers. Really post? " found)) + t))) + ;; Check for Version and Sendsys. + (message-check 'sendsys + (if (re-search-forward "^Sendsys:\\|^Version:" nil t) + (y-or-n-p + (format "The article contains a %s command. Really post? " + (buffer-substring (match-beginning 0) + (1- (match-end 0))))) + t)) + ;; See whether we can shorten Followup-To. + (message-check 'shorten-followup-to + (let ((newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) + to) + (when (and newsgroups + (string-match "," newsgroups) + (not followup-to) + (not + (zerop + (length + (setq to (completing-read + "Followups to: (default all groups) " + (mapcar (lambda (g) (list g)) + (cons "poster" + (message-tokenize-header + newsgroups))))))))) + (goto-char (point-min)) + (insert "Followup-To: " to "\n")) + t)) + ;; Check "Shoot me". + (message-check 'shoot + (if (re-search-forward + "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t) + (y-or-n-p "You appear to have a misconfigured system. Really post? ") + t)) + ;; Check for Approved. + (message-check 'approved + (if (re-search-forward "^Approved:" nil t) + (y-or-n-p "The article contains an Approved header. Really post? ") + t)) + ;; Check the Message-ID header. + (message-check 'message-id + (let* ((case-fold-search t) + (message-id (message-fetch-field "message-id" t))) + (or (not message-id) + (and (string-match "@" message-id) + (string-match "@[^\\.]*\\." message-id)) + (y-or-n-p + (format "The Message-ID looks strange: \"%s\". Really post? " + message-id))))) + ;; Check the Newsgroups & Followup-To headers. + (message-check 'existing-newsgroups + (let* ((case-fold-search t) + (newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) + (groups (message-tokenize-header + (if followup-to + (concat newsgroups "," followup-to) + newsgroups))) + (hashtb (and (boundp 'gnus-active-hashtb) + gnus-active-hashtb)) + errors) + (if (or (not hashtb) + (not (boundp 'gnus-read-active-file)) + (not gnus-read-active-file) + (eq gnus-read-active-file 'some)) + t + (while groups + (when (and (not (boundp (intern (car groups) hashtb))) + (not (equal (car groups) "poster"))) + (push (car groups) errors)) + (pop groups)) + (if (not errors) + t + (y-or-n-p + (format + "Really post to %s unknown group%s: %s " + (if (= (length errors) 1) "this" "these") + (if (= (length errors) 1) "" "s") + (mapconcat 'identity errors ", "))))))) + ;; Check the Newsgroups & Followup-To headers for syntax errors. + (message-check 'valid-newsgroups + (let ((case-fold-search t) + (headers '("Newsgroups" "Followup-To")) + header error) + (while (and headers (not error)) + (when (setq header (mail-fetch-field (car headers))) + (if (or + (not + (string-match + "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'" + header)) + (memq + nil (mapcar + (lambda (g) + (not (string-match "\\.\\'\\|\\.\\." g))) + (message-tokenize-header header ",")))) + (setq error t))) + (unless error + (pop headers))) + (if (not error) + t + (y-or-n-p + (format "The %s header looks odd: \"%s\". Really post? " + (car headers) header))))) + (message-check 'repeated-newsgroups + (let ((case-fold-search t) + (headers '("Newsgroups" "Followup-To")) + header error groups group) + (while (and headers + (not error)) + (when (setq header (mail-fetch-field (pop headers))) + (setq groups (message-tokenize-header header ",")) + (while (setq group (pop groups)) + (when (member group groups) + (setq error group + groups nil))))) + (if (not error) + t + (y-or-n-p + (format "Group %s is repeated in headers. Really post? " error))))) + ;; Check the From header. + (message-check 'from + (let* ((case-fold-search t) + (from (message-fetch-field "from")) + (ad (nth 1 (mail-extract-address-components from)))) + (cond + ((not from) + (message "There is no From line. Posting is denied.") + nil) + ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi + (string-match "\\.\\." ad) ;larsi@ifi..uio + (string-match "@\\." ad) ;larsi@.ifi.uio + (string-match "\\.$" ad) ;larsi@ifi.uio. + (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio + (string-match "(.*).*(.*)" from)) ;(lars) (lars) + (message + "Denied posting -- the From looks strange: \"%s\"." from) + nil) + (t t)))))) + +(defun message-check-news-body-syntax () + (and + ;; Check for long lines. + (message-check 'long-lines + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (while (and + (progn + (end-of-line) + (< (current-column) 80)) + (zerop (forward-line 1)))) + (or (bolp) + (eobp) + (y-or-n-p + "You have lines longer than 79 characters. Really post? "))) + ;; Check whether the article is empty. + (message-check 'empty + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (let ((b (point))) + (goto-char (point-max)) + (re-search-backward message-signature-separator nil t) + (beginning-of-line) + (or (re-search-backward "[^ \n\t]" b t) + (y-or-n-p "Empty article. Really post? ")))) + ;; Check for control characters. + (message-check 'control-chars + (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) + (y-or-n-p + "The article contains control characters. Really post? ") + t)) + ;; Check excessive size. + (message-check 'size + (if (> (buffer-size) 60000) + (y-or-n-p + (format "The article is %d octets long. Really post? " + (buffer-size))) + t)) + ;; Check whether any new text has been added. + (message-check 'new-text + (or + (not message-checksum) + (not (and (eq (message-checksum) (car message-checksum)) + (eq (buffer-size) (cdr message-checksum)))) + (y-or-n-p + "It looks like no new text has been added. Really post? "))) + ;; Check the length of the signature. + (message-check 'signature + (goto-char (point-max)) + (if (or (not (re-search-backward message-signature-separator nil t)) + (search-forward message-forward-end-separator nil t)) + t + (if (> (count-lines (point) (point-max)) 5) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (count-lines (point) (point-max))))) + t))))) + +(defun message-checksum () + "Return a \"checksum\" for the current buffer." + (let ((sum 0)) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (while (not (eobp)) + (when (not (looking-at "[ \t\n]")) + (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) + (following-char)))) + (forward-char 1))) + sum)) + +(defun message-do-fcc () + "Process Fcc headers in the current buffer." + (let ((case-fold-search t) + (buf (current-buffer)) + list file) + (save-excursion + (set-buffer (get-buffer-create " *message temp*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring buf) + (save-restriction + (message-narrow-to-headers) + (while (setq file (message-fetch-field "fcc")) + (push file list) + (message-remove-header "fcc" nil t))) + (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (replace-match "" t t) + ;; Process FCC operations. + (while list + (setq file (pop list)) + (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) + ;; Pipe the article to the program in question. + (call-process-region (point-min) (point-max) shell-file-name + nil nil nil shell-command-switch + (match-string 1 file)) + ;; Save the article. + (setq file (expand-file-name file)) + (unless (file-exists-p (file-name-directory file)) + (make-directory (file-name-directory file) t)) + (if (and message-fcc-handler-function + (not (eq message-fcc-handler-function 'rmail-output))) + (funcall message-fcc-handler-function file) + (if (and (file-readable-p file) (mail-file-babyl-p file)) + (rmail-output file 1 nil t) + (let ((mail-use-rfc822 t)) + (rmail-output file 1 t t)))))) + + (kill-buffer (current-buffer))))) + +(defun message-output (filename) + "Append this article to Unix/babyl mail file.." + (if (and (file-readable-p filename) + (mail-file-babyl-p filename)) + (gnus-output-to-rmail filename t) + (gnus-output-to-mail filename t))) + +(defun message-cleanup-headers () + "Do various automatic cleanups of the headers." + ;; Remove empty lines in the header. + (save-restriction + (message-narrow-to-headers) + (while (re-search-forward "^[ \t]*\n" nil t) + (replace-match "" t t))) + + ;; Correct Newsgroups and Followup-To headers: change sequence of + ;; spaces to comma and eliminate spaces around commas. Eliminate + ;; embedded line breaks. + (goto-char (point-min)) + (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) + (save-restriction + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (forward-line 1) + (point))) + (goto-char (point-min)) + (while (re-search-forward "\n[ \t]+" nil t) + (replace-match " " t t)) ;No line breaks (too confusing) + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) + (replace-match "," t t)) + (goto-char (point-min)) + ;; Remove trailing commas. + (when (re-search-forward ",+$" nil t) + (replace-match "" t t))))) + +(defun message-make-date () + "Make a valid data header." + (let ((now (current-time))) + (timezone-make-date-arpa-standard + (current-time-string now) (current-time-zone now)))) + +(defun message-make-message-id () + "Make a unique Message-ID." + (concat "<" (message-unique-id) + (let ((psubject (save-excursion (message-fetch-field "subject"))) + (psupersedes + (save-excursion (message-fetch-field "supersedes")))) + (if (or + (and message-reply-headers + (mail-header-references message-reply-headers) + (mail-header-subject message-reply-headers) + psubject + (mail-header-subject message-reply-headers) + (not (string= + (message-strip-subject-re + (mail-header-subject message-reply-headers)) + (message-strip-subject-re psubject)))) + (and psupersedes + (string-match "_-_@" psupersedes))) + "_-_" "")) + "@" (message-make-fqdn) ">")) + +(defvar message-unique-id-char nil) + +;; If you ever change this function, make sure the new version +;; cannot generate IDs that the old version could. +;; You might for example insert a "." somewhere (not next to another dot +;; or string boundary), or modify the "fsf" string. +(defun message-unique-id () + ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Instead we use this randomly inited counter. + (setq message-unique-id-char + (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20))))) + ;; (current-time) returns 16-bit ints, + ;; and 2^16*25 just fits into 4 digits i base 36. + (* 25 25))) + (let ((tm (current-time))) + (concat + (if (memq system-type '(ms-dos emx vax-vms)) + (let ((user (downcase (user-login-name)))) + (while (string-match "[^a-z0-9_]" user) + (aset user (match-beginning 0) ?_)) + user) + (message-number-base36 (user-uid) -1)) + (message-number-base36 (+ (car tm) + (lsh (% message-unique-id-char 25) 16)) 4) + (message-number-base36 (+ (nth 1 tm) + (lsh (/ message-unique-id-char 25) 16)) 4) + ;; Append the newsreader name, because while the generated + ;; ID is unique to this newsreader, other newsreaders might + ;; otherwise generate the same ID via another algorithm. + ".fsf"))) + +(defun message-number-base36 (num len) + (if (if (< len 0) + (<= num 0) + (= len 0)) + "" + (concat (message-number-base36 (/ num 36) (1- len)) + (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" + (% num 36)))))) + +(defun message-make-organization () + "Make an Organization header." + (let* ((organization + (or (getenv "ORGANIZATION") + (when message-user-organization + (if (message-functionp message-user-organization) + (funcall message-user-organization) + message-user-organization))))) + (save-excursion + (message-set-work-buffer) + (cond ((stringp organization) + (insert organization)) + ((and (eq t organization) + message-user-organization-file + (file-exists-p message-user-organization-file)) + (insert-file-contents message-user-organization-file))) + (goto-char (point-min)) + (while (re-search-forward "[\t\n]+" nil t) + (replace-match "" t t)) + (unless (zerop (buffer-size)) + (buffer-string))))) + +(defun message-make-lines () + "Count the number of lines and return numeric string." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (int-to-string (count-lines (point) (point-max)))))) + +(defun message-make-in-reply-to () + "Return the In-Reply-To header for this message." + (when message-reply-headers + (let ((from (mail-header-from message-reply-headers)) + (date (mail-header-date message-reply-headers))) + (when from + (let ((stop-pos + (string-match " *at \\| *@ \\| *(\\| *<" from))) + (concat (if stop-pos (substring from 0 stop-pos) from) + "'s message of \"" + (if (or (not date) (string= date "")) + "(unknown date)" date) + "\"")))))) + +(defun message-make-distribution () + "Make a Distribution header." + (let ((orig-distribution (message-fetch-reply-field "distribution"))) + (cond ((message-functionp message-distribution-function) + (funcall message-distribution-function)) + (t orig-distribution)))) + +(defun message-make-expires () + "Return an Expires header based on `message-expires'." + (let ((current (current-time)) + (future (* 1.0 message-expires 60 60 24))) + ;; Add the future to current. + (setcar current (+ (car current) (round (/ future (expt 2 16))))) + (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) + ;; Return the date in the future in UT. + (timezone-make-date-arpa-standard + (current-time-string current) (current-time-zone current) '(0 "UT")))) + +(defun message-make-path () + "Return uucp path." + (let ((login-name (user-login-name))) + (cond ((null message-user-path) + (concat (system-name) "!" login-name)) + ((stringp message-user-path) + ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. + (concat message-user-path "!" login-name)) + (t login-name)))) + +(defun message-make-from () + "Make a From header." + (let* ((style message-from-style) + (login (message-make-address)) + (fullname + (or (and (boundp 'user-full-name) + user-full-name) + (user-full-name)))) + (when (string= fullname "&") + (setq fullname (user-login-name))) + (save-excursion + (message-set-work-buffer) + (cond + ((or (null style) + (equal fullname "")) + (insert login)) + ((or (eq style 'angles) + (and (not (eq style 'parens)) + ;; Use angles if no quoting is needed, or if parens would + ;; need quoting too. + (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname)) + (let ((tmp (concat fullname nil))) + (while (string-match "([^()]*)" tmp) + (aset tmp (match-beginning 0) ?-) + (aset tmp (1- (match-end 0)) ?-)) + (string-match "[\\()]" tmp))))) + (insert fullname) + (goto-char (point-min)) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) + ;; Quote fullname, escaping specials. + (goto-char (point-min)) + (insert "\"") + (while (re-search-forward "[\"\\]" nil 1) + (replace-match "\\\\\\&" t)) + (insert "\"")) + (insert " <" login ">")) + (t ; 'parens or default + (insert login " (") + (let ((fullname-start (point))) + (insert fullname) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" nil 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + nil 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start))) + (insert ")"))) + (buffer-string)))) + +(defun message-make-sender () + "Return the \"real\" user address. +This function tries to ignore all user modifications, and +give as trustworthy answer as possible." + (concat (user-login-name) "@" (system-name))) + +(defun message-make-address () + "Make the address of the user." + (or (message-user-mail-address) + (concat (user-login-name) "@" (message-make-domain)))) + +(defun message-user-mail-address () + "Return the pertinent part of `user-mail-address'." + (when user-mail-address + (if (string-match " " user-mail-address) + (nth 1 (mail-extract-address-components user-mail-address)) + user-mail-address))) + +(defun message-make-fqdn () + "Return user's fully qualified domain name." + (let ((system-name (system-name)) + (user-mail (message-user-mail-address))) + (cond + ((string-match "[^.]\\.[^.]" system-name) + ;; `system-name' returned the right result. + system-name) + ;; Try `mail-host-address'. + ((and (boundp 'mail-host-address) + (stringp mail-host-address) + (string-match "\\." mail-host-address)) + mail-host-address) + ;; We try `user-mail-address' as a backup. + ((and (string-match "\\." user-mail) + (string-match "@\\(.*\\)\\'" user-mail)) + (match-string 1 user-mail)) + ;; Default to this bogus thing. + (t + (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me"))))) + +(defun message-make-host-name () + "Return the name of the host." + (let ((fqdn (message-make-fqdn))) + (string-match "^[^.]+\\." fqdn) + (substring fqdn 0 (1- (match-end 0))))) + +(defun message-make-domain () + "Return the domain name." + (or mail-host-address + (message-make-fqdn))) + +(defun message-generate-headers (headers) + "Prepare article HEADERS. +Headers already prepared in the buffer are not modified." + (save-restriction + (message-narrow-to-headers) + (let* ((Date (message-make-date)) + (Message-ID (message-make-message-id)) + (Organization (message-make-organization)) + (From (message-make-from)) + (Path (message-make-path)) + (Subject nil) + (Newsgroups nil) + (In-Reply-To (message-make-in-reply-to)) + (To nil) + (Distribution (message-make-distribution)) + (Lines (message-make-lines)) + (X-Newsreader message-newsreader) + (X-Mailer (and (not (message-fetch-field "X-Newsreader")) + message-mailer)) + (Expires (message-make-expires)) + (case-fold-search t) + header value elem) + ;; First we remove any old generated headers. + (let ((headers message-deletable-headers)) + (unless (buffer-modified-p) + (setq headers (delq 'Message-ID (copy-sequence headers)))) + (while headers + (goto-char (point-min)) + (and (re-search-forward + (concat "^" (symbol-name (car headers)) ": *") nil t) + (get-text-property (1+ (match-beginning 0)) 'message-deletable) + (message-delete-line)) + (pop headers))) + ;; Go through all the required headers and see if they are in the + ;; articles already. If they are not, or are empty, they are + ;; inserted automatically - except for Subject, Newsgroups and + ;; Distribution. + (while headers + (goto-char (point-min)) + (setq elem (pop headers)) + (if (consp elem) + (if (eq (car elem) 'optional) + (setq header (cdr elem)) + (setq header (car elem))) + (setq header elem)) + (when (or (not (re-search-forward + (concat "^" (downcase (symbol-name header)) ":") + nil t)) + (progn + ;; The header was found. We insert a space after the + ;; colon, if there is none. + (if (/= (following-char) ? ) (insert " ") (forward-char 1)) + ;; Find out whether the header is empty... + (looking-at "[ \t]*$"))) + ;; So we find out what value we should insert. + (setq value + (cond + ((and (consp elem) (eq (car elem) 'optional)) + ;; This is an optional header. If the cdr of this + ;; is something that is nil, then we do not insert + ;; this header. + (setq header (cdr elem)) + (or (and (fboundp (cdr elem)) (funcall (cdr elem))) + (and (boundp (cdr elem)) (symbol-value (cdr elem))))) + ((consp elem) + ;; The element is a cons. Either the cdr is a + ;; string to be inserted verbatim, or it is a + ;; function, and we insert the value returned from + ;; this function. + (or (and (stringp (cdr elem)) (cdr elem)) + (and (fboundp (cdr elem)) (funcall (cdr elem))))) + ((and (boundp header) (symbol-value header)) + ;; The element is a symbol. We insert the value + ;; of this symbol, if any. + (symbol-value header)) + (t + ;; We couldn't generate a value for this header, + ;; so we just ask the user. + (read-from-minibuffer + (format "Empty header for %s; enter value: " header))))) + ;; Finally insert the header. + (when (and value + (not (equal value ""))) + (save-excursion + (if (bolp) + (progn + ;; This header didn't exist, so we insert it. + (goto-char (point-max)) + (insert (symbol-name header) ": " value "\n") + (forward-line -1)) + ;; The value of this header was empty, so we clear + ;; totally and insert the new value. + (delete-region (point) (gnus-point-at-eol)) + (insert value)) + ;; Add the deletable property to the headers that require it. + (and (memq header message-deletable-headers) + (progn (beginning-of-line) (looking-at "[^:]+: ")) + (add-text-properties + (point) (match-end 0) + '(message-deletable t face italic) (current-buffer))))))) + ;; Insert new Sender if the From is strange. + (let ((from (message-fetch-field "from")) + (sender (message-fetch-field "sender")) + (secure-sender (message-make-sender))) + (when (and from + (not (message-check-element 'sender)) + (not (string= + (downcase + (cadr (mail-extract-address-components from))) + (downcase secure-sender))) + (or (null sender) + (not + (string= + (downcase + (cadr (mail-extract-address-components sender))) + (downcase secure-sender))))) + (goto-char (point-min)) + ;; Rename any old Sender headers to Original-Sender. + (when (re-search-forward "^\\(Original-\\)*Sender:" nil t) + (beginning-of-line) + (insert "Original-") + (beginning-of-line)) + (when (or (message-news-p) + (string-match "^[^@]@.+\\..+" secure-sender)) + (insert "Sender: " secure-sender "\n"))))))) + +(defun message-insert-courtesy-copy () + "Insert a courtesy message in mail copies of combined messages." + (let (newsgroups) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (when (setq newsgroups (message-fetch-field "newsgroups")) + (goto-char (point-max)) + (insert "Posted-To: " newsgroups "\n"))) + (forward-line 1) + (when message-courtesy-message + (cond + ((string-match "%s" message-courtesy-message) + (insert (format message-courtesy-message newsgroups))) + (t + (insert message-courtesy-message))))))) + +;;; +;;; Setting up a message buffer +;;; + +(defun message-fill-address (header value) + (save-restriction + (narrow-to-region (point) (point)) + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n") + (narrow-to-region (point-min) (1- (point-max))) + (let (quoted last) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^,\"" (point-max)) + (if (or (= (following-char) ?,) + (eobp)) + (when (not quoted) + (if (and (> (current-column) 78) + last) + (progn + (save-excursion + (goto-char last) + (insert "\n\t")) + (setq last (1+ (point)))) + (setq last (1+ (point))))) + (setq quoted (not quoted))) + (unless (eobp) + (forward-char 1)))) + (goto-char (point-max)) + (widen) + (forward-line 1))) + +(defun message-fill-header (header value) + (let ((begin (point)) + (fill-column 78) + (fill-prefix "\t")) + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n") + (save-restriction + (narrow-to-region begin (point)) + (fill-region-as-paragraph begin (point)) + ;; Tapdance around looong Message-IDs. + (forward-line -1) + (when (looking-at "[ \t]*$") + (message-delete-line)) + (goto-char begin) + (re-search-forward ":" nil t) + (when (looking-at "\n[ \t]+") + (replace-match " " t t)) + (goto-char (point-max))))) + +(defun message-position-point () + "Move point to where the user probably wants to find it." + (message-narrow-to-headers) + (cond + ((re-search-forward "^[^:]+:[ \t]*$" nil t) + (search-backward ":" ) + (widen) + (forward-char 1) + (if (= (following-char) ? ) + (forward-char 1) + (insert " "))) + (t + (goto-char (point-max)) + (widen) + (forward-line 1) + (unless (looking-at "$") + (forward-line 2))) + (sit-for 0))) + +(defun message-buffer-name (type &optional to group) + "Return a new (unique) buffer name based on TYPE and TO." + (cond + ;; Check whether `message-generate-new-buffers' is a function, + ;; and if so, call it. + ((message-functionp message-generate-new-buffers) + (funcall message-generate-new-buffers type to group)) + ;; Generate a new buffer name The Message Way. + (message-generate-new-buffers + (generate-new-buffer-name + (concat "*" type + (if to + (concat " to " + (or (car (mail-extract-address-components to)) + to) "") + "") + (if (and group (not (string= group ""))) (concat " on " group) "") + "*"))) + ;; Use standard name. + (t + (format "*%s message*" type)))) + +(defun message-pop-to-buffer (name) + "Pop to buffer NAME, and warn if it already exists and is modified." + (let ((buffer (get-buffer name))) + (if (and buffer + (buffer-name buffer)) + (progn + (set-buffer (pop-to-buffer buffer)) + (when (and (buffer-modified-p) + (not (y-or-n-p + "Message already being composed; erase? "))) + (error "Message being composed"))) + (set-buffer (pop-to-buffer name)))) + (erase-buffer) + (message-mode)) + +(defun message-do-send-housekeeping () + "Kill old message buffers." + ;; We might have sent this buffer already. Delete it from the + ;; list of buffers. + (setq message-buffer-list (delq (current-buffer) message-buffer-list)) + (while (and message-max-buffers + message-buffer-list + (>= (length message-buffer-list) message-max-buffers)) + ;; Kill the oldest buffer -- unless it has been changed. + (let ((buffer (pop message-buffer-list))) + (when (and (buffer-name buffer) + (not (buffer-modified-p buffer))) + (kill-buffer buffer)))) + ;; Rename the buffer. + (if message-send-rename-function + (funcall message-send-rename-function) + (when (string-match "\\`\\*" (buffer-name)) + (rename-buffer + (concat "*sent " (substring (buffer-name) (match-end 0))) t))) + ;; Push the current buffer onto the list. + (when message-max-buffers + (setq message-buffer-list + (nconc message-buffer-list (list (current-buffer)))))) + +(defvar mc-modes-alist) +(defun message-setup (headers &optional replybuffer actions) + (when (and (boundp 'mc-modes-alist) + (not (assq 'message-mode mc-modes-alist))) + (push '(message-mode (encrypt . mc-encrypt-message) + (sign . mc-sign-message)) + mc-modes-alist)) + (when actions + (setq message-send-actions actions)) + (setq message-reply-buffer replybuffer) + (goto-char (point-min)) + ;; Insert all the headers. + (mail-header-format + (let ((h headers) + (alist message-header-format-alist)) + (while h + (unless (assq (caar h) message-header-format-alist) + (push (list (caar h)) alist)) + (pop h)) + alist) + headers) + (delete-region (point) (progn (forward-line -1) (point))) + (when message-default-headers + (insert message-default-headers)) + (put-text-property + (point) + (progn + (insert mail-header-separator "\n") + (1- (point))) + 'read-only nil) + (forward-line -1) + (when (message-news-p) + (when message-default-news-headers + (insert message-default-news-headers)) + (when message-generate-headers-first + (message-generate-headers + (delq 'Lines + (delq 'Subject + (copy-sequence message-required-news-headers)))))) + (when (message-mail-p) + (when message-default-mail-headers + (insert message-default-mail-headers)) + (when message-generate-headers-first + (message-generate-headers + (delq 'Lines + (delq 'Subject + (copy-sequence message-required-mail-headers)))))) + (run-hooks 'message-signature-setup-hook) + (message-insert-signature) + (save-restriction + (message-narrow-to-headers) + (run-hooks 'message-header-setup-hook)) + (set-buffer-modified-p nil) + (setq buffer-undo-list nil) + (run-hooks 'message-setup-hook) + (message-position-point) + (undo-boundary)) + +(defun message-set-auto-save-file-name () + "Associate the message buffer with a file in the drafts directory." + (when message-autosave-directory + (setq message-draft-article (nndraft-request-associate-buffer "drafts")) + (clear-visited-file-modtime))) + +(defun message-disassociate-draft () + "Disassociate the message buffer from the drafts directory." + (when message-draft-article + (nndraft-request-expire-articles + (list message-draft-article) "drafts" nil t))) + + + +;;; +;;; Commands for interfacing with message +;;; + +;;;###autoload +(defun message-mail (&optional to subject + other-headers continue switch-function + yank-action send-actions) + "Start editing a mail message to be sent." + (interactive) + (let ((message-this-is-mail t)) + (message-pop-to-buffer (message-buffer-name "mail" to)) + (message-setup + (nconc + `((To . ,(or to "")) (Subject . ,(or subject ""))) + (when other-headers other-headers))))) + +;;;###autoload +(defun message-news (&optional newsgroups subject) + "Start editing a news article to be sent." + (interactive) + (let ((message-this-is-news t)) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject "")))))) + +;;;###autoload +(defun message-reply (&optional to-address wide ignore-reply-to) + "Start editing a reply to the article in the current buffer." + (interactive) + (let ((cur (current-buffer)) + from subject date reply-to to cc + references message-id follow-to + (inhibit-point-motion-hooks t) + mct never-mct gnus-warning) + (save-restriction + (message-narrow-to-head) + ;; Allow customizations to have their say. + (if (not wide) + ;; This is a regular reply. + (if (message-functionp message-reply-to-function) + (setq follow-to (funcall message-reply-to-function))) + ;; This is a followup. + (if (message-functionp message-wide-reply-to-function) + (save-excursion + (setq follow-to + (funcall message-wide-reply-to-function))))) + ;; Find all relevant headers we need. + (setq from (message-fetch-field "from") + date (message-fetch-field "date") + subject (or (message-fetch-field "subject") "none") + to (message-fetch-field "to") + cc (message-fetch-field "cc") + mct (message-fetch-field "mail-copies-to") + reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) + references (message-fetch-field "references") + message-id (message-fetch-field "message-id" t)) + ;; Remove any (buggy) Re:'s that are present and make a + ;; proper one. + (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) + (setq subject (substring subject (match-end 0)))) + (setq subject (concat "Re: " subject)) + + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) + + ;; Handle special values of Mail-Copies-To. + (when mct + (cond ((equal (downcase mct) "never") + (setq never-mct t) + (setq mct nil)) + ((equal (downcase mct) "always") + (setq mct (or reply-to from))))) + + (unless follow-to + (if (or (not wide) + to-address) + (setq follow-to (list (cons 'To (or to-address reply-to from)))) + (let (ccalist) + (save-excursion + (message-set-work-buffer) + (unless never-mct + (insert (or reply-to from ""))) + (insert (if to (concat (if (bolp) "" ", ") to "") "")) + (insert (if mct (concat (if (bolp) "" ", ") mct) "")) + (insert (if cc (concat (if (bolp) "" ", ") cc) "")) + (goto-char (point-min)) + (while (re-search-forward "[ \t]+" nil t) + (replace-match " " t t)) + ;; Remove addresses that match `rmail-dont-reply-to-names'. + (insert (prog1 (rmail-dont-reply-to (buffer-string)) + (erase-buffer))) + (goto-char (point-min)) + ;; Perhaps Mail-Copies-To: never removed the only address? + (when (eobp) + (insert (or reply-to from ""))) + (setq ccalist + (mapcar + (lambda (addr) + (cons (mail-strip-quoted-names addr) addr)) + (message-tokenize-header (buffer-string)))) + (let ((s ccalist)) + (while s + (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) + (setq follow-to (list (cons 'To (cdr (pop ccalist))))) + (when ccalist + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to)))))) + (widen)) + + (message-pop-to-buffer (message-buffer-name + (if wide "wide reply" "reply") from + (if wide to-address nil))) + + (setq message-reply-headers + (vector 0 subject from date message-id references 0 0 "")) + + (message-setup + `((Subject . ,subject) + ,@follow-to + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id "")))) + nil)) + cur))) + +;;;###autoload +(defun message-wide-reply (&optional to-address ignore-reply-to) + "Make a \"wide\" reply to the message in the current buffer." + (interactive) + (message-reply to-address t ignore-reply-to)) + +;;;###autoload +(defun message-followup (&optional to-newsgroups) + "Follow up to the message in the current buffer. +If TO-NEWSGROUPS, use that as the new Newsgroups line." + (interactive) + (let ((cur (current-buffer)) + from subject date reply-to mct + references message-id follow-to + (inhibit-point-motion-hooks t) + (message-this-is-news t) + followup-to distribution newsgroups gnus-warning posted-to) + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (when (message-functionp message-followup-to-function) + (setq follow-to + (funcall message-followup-to-function))) + (setq from (message-fetch-field "from") + date (message-fetch-field "date") + subject (or (message-fetch-field "subject") "none") + references (message-fetch-field "references") + message-id (message-fetch-field "message-id" t) + followup-to (message-fetch-field "followup-to") + newsgroups (message-fetch-field "newsgroups") + posted-to (message-fetch-field "posted-to") + reply-to (message-fetch-field "reply-to") + distribution (message-fetch-field "distribution") + mct (message-fetch-field "mail-copies-to")) + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) + ;; Remove bogus distribution. + (when (and (stringp distribution) + (let ((case-fold-search t)) + (string-match "world" distribution))) + (setq distribution nil)) + ;; Remove any (buggy) Re:'s that are present and make a + ;; proper one. + (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) + (setq subject (substring subject (match-end 0)))) + (setq subject (concat "Re: " subject)) + (widen)) + + (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) + + (message-setup + `((Subject . ,subject) + ,@(cond + (to-newsgroups + (list (cons 'Newsgroups to-newsgroups))) + (follow-to follow-to) + ((and followup-to message-use-followup-to) + (list + (cond + ((equal (downcase followup-to) "poster") + (if (or (eq message-use-followup-to 'use) + (message-y-or-n-p "Obey Followup-To: poster? " t "\ +You should normally obey the Followup-To: header. + +`Followup-To: poster' sends your response via e-mail instead of news. + +A typical situation where `Followup-To: poster' is used is when the poster +does not read the newsgroup, so he wouldn't see any replies sent to it.")) + (progn + (setq message-this-is-news nil) + (cons 'To (or reply-to from ""))) + (cons 'Newsgroups newsgroups))) + (t + (if (or (equal followup-to newsgroups) + (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Followup-To: " followup-to "? ") t "\ +You should normally obey the Followup-To: header. + + `Followup-To: " followup-to "' +directs your response to " (if (string-match "," followup-to) + "the specified newsgroups" + "that newsgroup only") ". + +If a message is posted to several newsgroups, Followup-To is often +used to direct the following discussion to one newsgroup only, +because discussions that are spread over several newsgroup tend to +be fragmented and very difficult to follow. + +Also, some source/announcement newsgroups are not indented for discussion; +responses here are directed to other newsgroups.")) + (cons 'Newsgroups followup-to) + (cons 'Newsgroups newsgroups)))))) + (posted-to + `((Newsgroups . ,posted-to))) + (t + `((Newsgroups . ,newsgroups)))) + ,@(and distribution (list (cons 'Distribution distribution))) + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id ""))))) + ,@(when (and mct + (not (equal (downcase mct) "never"))) + (list (cons 'Cc (if (equal (downcase mct) "always") + (or reply-to from "") + mct))))) + + cur) + + (setq message-reply-headers + (vector 0 subject from date message-id references 0 0 "")))) + + +;;;###autoload +(defun message-cancel-news () + "Cancel an article you posted." + (interactive) + (unless (message-news-p) + (error "This is not a news article; canceling is impossible")) + (when (yes-or-no-p "Do you really want to cancel this article? ") + (let (from newsgroups message-id distribution buf) + (save-excursion + ;; Get header info. from original article. + (save-restriction + (message-narrow-to-head) + (setq from (message-fetch-field "from") + newsgroups (message-fetch-field "newsgroups") + message-id (message-fetch-field "message-id" t) + distribution (message-fetch-field "distribution"))) + ;; Make sure that this article was written by the user. + (unless (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (message-make-address))) + (error "This article is not yours")) + ;; Make control message. + (setq buf (set-buffer (get-buffer-create " *message cancel*"))) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert "Newsgroups: " newsgroups "\n" + "From: " (message-make-from) "\n" + "Subject: cmsg cancel " message-id "\n" + "Control: cancel " message-id "\n" + (if distribution + (concat "Distribution: " distribution "\n") + "") + mail-header-separator "\n" + message-cancel-message) + (message "Canceling your article...") + (if (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (funcall message-send-news-function)) + (message "Canceling your article...done")) + (kill-buffer buf))))) + +;;;###autoload +(defun message-supersede () + "Start composing a message to supersede the current message. +This is done simply by taking the old article and adding a Supersedes +header line with the old Message-ID." + (interactive) + (let ((cur (current-buffer))) + ;; Check whether the user owns the article that is to be superseded. + (unless (string-equal + (downcase (cadr (mail-extract-address-components + (message-fetch-field "from")))) + (downcase (message-make-address))) + (error "This article is not yours")) + ;; Get a normal message buffer. + (message-pop-to-buffer (message-buffer-name "supersede")) + (insert-buffer-substring cur) + (message-narrow-to-head) + ;; Remove unwanted headers. + (when message-ignored-supersedes-headers + (message-remove-header message-ignored-supersedes-headers t)) + (goto-char (point-min)) + (if (not (re-search-forward "^Message-ID: " nil t)) + (error "No Message-ID in this article") + (replace-match "Supersedes: " t t)) + (goto-char (point-max)) + (insert mail-header-separator) + (widen) + (forward-line 1))) + +;;;###autoload +(defun message-recover () + "Reread contents of current buffer from its last auto-save file." + (interactive) + (let ((file-name (make-auto-save-file-name))) + (cond ((save-window-excursion + (if (not (eq system-type 'vax-vms)) + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (let ((default-directory "/")) + (call-process + "ls" nil standard-output nil "-l" file-name)))) + (yes-or-no-p (format "Recover auto save file %s? " file-name))) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-file-contents file-name nil))) + (t (error "message-recover cancelled"))))) + +;;; Forwarding messages. + +(defun message-make-forward-subject () + "Return a Subject header suitable for the message in the current buffer." + (save-excursion + (save-restriction + (current-buffer) + (message-narrow-to-head) + (concat "[" (or (message-fetch-field + (if (message-news-p) "newsgroups" "from")) + "(nowhere)") + "] " (or (message-fetch-field "Subject") ""))))) + +;;;###autoload +(defun message-forward (&optional news) + "Forward the current message via mail. +Optional NEWS will use news to forward instead of mail." + (interactive "P") + (let ((cur (current-buffer)) + (subject (message-make-forward-subject)) + art-beg) + (if news (message-news nil subject) (message-mail nil subject)) + ;; Put point where we want it before inserting the forwarded + ;; message. + (if message-signature-before-forwarded-message + (goto-char (point-max)) + (message-goto-body)) + ;; Make sure we're at the start of the line. + (unless (eolp) + (insert "\n")) + ;; Narrow to the area we are to insert. + (narrow-to-region (point) (point)) + ;; Insert the separators and the forwarded buffer. + (insert message-forward-start-separator) + (setq art-beg (point)) + (insert-buffer-substring cur) + (goto-char (point-max)) + (insert message-forward-end-separator) + (set-text-properties (point-min) (point-max) nil) + ;; Remove all unwanted headers. + (goto-char art-beg) + (narrow-to-region (point) (if (search-forward "\n\n" nil t) + (1- (point)) + (point))) + (goto-char (point-min)) + (message-remove-header message-included-forward-headers t nil t) + (widen) + (message-position-point))) + +;;;###autoload +(defun message-resend (address) + "Resend the current article to ADDRESS." + (interactive "sResend message to: ") + (message "Resending message to %s..." address) + (save-excursion + (let ((cur (current-buffer)) + beg) + ;; We first set up a normal mail buffer. + (set-buffer (get-buffer-create " *message resend*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (message-setup `((To . ,address))) + ;; Insert our usual headers. + (message-generate-headers '(From Date To)) + (message-narrow-to-headers) + ;; Rename them all to "Resent-*". + (while (re-search-forward "^[A-Za-z]" nil t) + (forward-char -1) + (insert "Resent-")) + (widen) + (forward-line) + (delete-region (point) (point-max)) + (setq beg (point)) + ;; Insert the message to be resent. + (insert-buffer-substring cur) + (goto-char (point-min)) + (search-forward "\n\n") + (forward-char -1) + (save-restriction + (narrow-to-region beg (point)) + (message-remove-header message-ignored-resent-headers t) + (goto-char (point-max))) + (insert mail-header-separator) + ;; Rename all old ("Also-")Resent headers. + (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) + (beginning-of-line) + (insert "Also-")) + ;; Quote any "From " lines at the beginning. + (goto-char beg) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + ;; Send it. + (message-send-mail) + (kill-buffer (current-buffer))) + (message "Resending message to %s...done" address))) + +;;;###autoload +(defun message-bounce () + "Re-mail the current message. +This only makes sense if the current message is a bounce message than +contains some mail you have written which has been bounced back to +you." + (interactive) + (let ((cur (current-buffer)) + boundary) + (message-pop-to-buffer (message-buffer-name "bounce")) + (insert-buffer-substring cur) + (undo-boundary) + (message-narrow-to-head) + (if (and (message-fetch-field "Mime-Version") + (setq boundary (message-fetch-field "Content-Type"))) + (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary) + (setq boundary (concat (match-string 1 boundary) " *\n" + "Content-Type: message/rfc822")) + (setq boundary nil))) + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (or (and boundary + (re-search-forward boundary nil t) + (forward-line 2)) + (and (re-search-forward message-unsent-separator nil t) + (forward-line 1)) + (re-search-forward "^Return-Path:.*\n" nil t)) + ;; We remove everything before the bounced mail. + (delete-region + (point-min) + (if (re-search-forward "^[^ \n\t]+:" nil t) + (match-beginning 0) + (point))) + (save-restriction + (message-narrow-to-head) + (message-remove-header message-ignored-bounced-headers t) + (goto-char (point-max)) + (insert mail-header-separator)) + (message-position-point))) + +;;; +;;; Interactive entry points for new message buffers. +;;; + +;;;###autoload +(defun message-mail-other-window (&optional to subject) + "Like `message-mail' command, but display mail buffer in another window." + (interactive) + (let ((pop-up-windows t) + (special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (message-pop-to-buffer (message-buffer-name "mail" to))) + (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + +;;;###autoload +(defun message-mail-other-frame (&optional to subject) + "Like `message-mail' command, but display mail buffer in another frame." + (interactive) + (let ((pop-up-frames t) + (special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (message-pop-to-buffer (message-buffer-name "mail" to))) + (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + +;;;###autoload +(defun message-news-other-window (&optional newsgroups subject) + "Start editing a news article to be sent." + (interactive) + (let ((pop-up-windows t) + (special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject ""))))) + +;;;###autoload +(defun message-news-other-frame (&optional newsgroups subject) + "Start editing a news article to be sent." + (interactive) + (let ((pop-up-frames t) + (special-display-buffer-names nil) + (special-display-regexps nil) + (same-window-buffer-names nil) + (same-window-regexps nil)) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject ""))))) + +;;; underline.el + +;; This code should be moved to underline.el (from which it is stolen). + +;;;###autoload +(defun bold-region (start end) + "Bold all nonblank characters in the region. +Works by overstriking characters. +Called from program, takes two arguments START and END +which specify the range to operate on." + (interactive "r") + (save-excursion + (let ((end1 (make-marker))) + (move-marker end1 (max start end)) + (goto-char (min start end)) + (while (< (point) end1) + (or (looking-at "[_\^@- ]") + (insert (following-char) "\b")) + (forward-char 1))))) + +;;;###autoload +(defun unbold-region (start end) + "Remove all boldness (overstruck characters) in the region. +Called from program, takes two arguments START and END +which specify the range to operate on." + (interactive "r") + (save-excursion + (let ((end1 (make-marker))) + (move-marker end1 (max start end)) + (goto-char (min start end)) + (while (re-search-forward "\b" end1 t) + (if (eq (following-char) (char-after (- (point) 2))) + (delete-char -2)))))) + +(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) + +;; Support for toolbar +(when (string-match "XEmacs\\|Lucid" emacs-version) + (require 'messagexmas)) + +;;; Group name completion. + +(defvar message-newgroups-header-regexp + "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" + "Regexp that match headers that lists groups.") + +(defun message-tab () + "Expand group names in Newsgroups and Followup-To headers. +Do a `tab-to-tab-stop' if not in those headers." + (interactive) + (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp)) + (mail-abbrev-in-expansion-header-p)) + (message-expand-group) + (tab-to-tab-stop))) + +(defvar gnus-active-hashtb) +(defun message-expand-group () + (let* ((b (save-excursion + (save-restriction + (narrow-to-region + (save-excursion + (beginning-of-line) + (skip-chars-forward "^:") + (1+ (point))) + (point)) + (skip-chars-backward "^, \t\n") (point)))) + (completion-ignore-case t) + (string (buffer-substring b (point))) + (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) + (completions (all-completions string hashtb)) + (cur (current-buffer)) + comp) + (delete-region b (point)) + (cond + ((= (length completions) 1) + (if (string= (car completions) string) + (progn + (insert string) + (message "Only matching group")) + (insert (car completions)))) + ((and (setq comp (try-completion string hashtb)) + (not (string= comp string))) + (insert comp)) + (t + (insert string) + (if (not comp) + (message "No matching groups") + (save-selected-window + (pop-to-buffer "*Completions*") + (buffer-disable-undo (current-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (display-completion-list (sort completions 'string<))) + (goto-char (point-min)) + (delete-region (point) (progn (forward-line 3) (point)))))))))) + +;;; Help stuff. + +(defun message-talkative-question (ask question show &rest text) + "Call FUNCTION with argument QUESTION; optionally display TEXT... args. +If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer. +The following arguments may contain lists of values." + (if (and show + (setq text (message-flatten-list text))) + (save-window-excursion + (save-excursion + (with-output-to-temp-buffer " *MESSAGE information message*" + (set-buffer " *MESSAGE information message*") + (mapcar 'princ text) + (goto-char (point-min)))) + (funcall ask question)) + (funcall ask question))) + +(defun message-flatten-list (list) + "Return a new, flat list that contains all elements of LIST. + +\(message-flatten-list '(1 (2 3 (4 5 (6))) 7)) +=> (1 2 3 4 5 6 7)" + (cond ((consp list) + (apply 'append (mapcar 'message-flatten-list list))) + (list + (list list)))) + +(defun message-generate-new-buffer-clone-locals (name &optional varstr) + "Create and return a buffer with a name based on NAME using generate-new-buffer. +Then clone the local variables and values from the old buffer to the +new one, cloning only the locals having a substring matching the +regexp varstr." + (let ((oldbuf (current-buffer))) + (save-excursion + (set-buffer (generate-new-buffer name)) + (message-clone-locals oldbuf) + (current-buffer)))) + +(defun message-clone-locals (buffer) + "Clone the local variables from BUFFER to the current buffer." + (let ((locals (save-excursion + (set-buffer buffer) + (buffer-local-variables))) + (regexp "^gnus\\|^nn\\|^message")) + (mapcar + (lambda (local) + (when (and (consp local) + (car local) + (string-match regexp (symbol-name (car local)))) + (ignore-errors + (set (make-local-variable (car local)) + (cdr local))))) + locals))) + +;;; Miscellaneous functions + +;; stolen (and renamed) from nnheader.el +(defun message-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string)) + +(run-hooks 'message-load-hook) + +(provide 'message) + +;;; message.el ends here diff --git a/lisp/messagexmas.el b/lisp/messagexmas.el new file mode 100644 index 0000000..4fd13d2 --- /dev/null +++ b/lisp/messagexmas.el @@ -0,0 +1,125 @@ +;;; messagexmas.el --- XEmacs extensions to message +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) + +(defvar message-xmas-dont-activate-region t + "If t, don't activate region after yanking.") + +(defvar message-xmas-glyph-directory nil + "*Directory where Message logos and icons are located. +If this variable is nil, Message will try to locate the directory +automatically.") + +(defvar message-use-toolbar (if (featurep 'toolbar) + 'default-toolbar + nil) + "*If nil, do not use a toolbar. +If it is non-nil, it must be a toolbar. The five legal values are +`default-toolbar', `top-toolbar', `bottom-toolbar', +`right-toolbar', and `left-toolbar'.") + +(defvar message-toolbar + '([message-spell ispell-message t "Spell"] + [message-help (Info-goto-node "(Message)Top") t "Message help"]) + "The message buffer toolbar.") + +(defun message-xmas-find-glyph-directory (&optional package) + (setq package (or package "message")) + (let ((dir (symbol-value + (intern-soft (concat package "-xmas-glyph-directory"))))) + (if (and (stringp dir) (file-directory-p dir)) + dir + (nnheader-find-etc-directory package)))) + +(defun message-xmas-setup-toolbar (bar &optional force package) + (let ((dir (message-xmas-find-glyph-directory package)) + (xpm (if (featurep 'xpm) "xpm" "xbm")) + icon up down disabled name) + (unless package + (setq message-xmas-glyph-directory dir)) + (when dir + (while bar + (setq icon (aref (car bar) 0) + name (symbol-name icon) + bar (cdr bar)) + (when (or force + (not (boundp icon))) + (setq up (concat dir name "-up." xpm)) + (setq down (concat dir name "-down." xpm)) + (setq disabled (concat dir name "-disabled." xpm)) + (if (not (file-exists-p up)) + (setq bar nil + dir nil) + (set icon (toolbar-make-button-list + up (and (file-exists-p down) down) + (and (file-exists-p disabled) disabled))))))) + dir)) + +(defun message-setup-toolbar () + (and message-use-toolbar + (message-xmas-setup-toolbar message-toolbar) + (set-specifier (symbol-value message-use-toolbar) + (cons (current-buffer) message-toolbar)))) + +(defun message-xmas-exchange-point-and-mark () + "Exchange point and mark, but allow for XEmacs' optional argument." + (exchange-point-and-mark message-xmas-dont-activate-region)) + +(fset 'message-exchange-point-and-mark 'message-xmas-exchange-point-and-mark) + +(defun message-xmas-maybe-fontify () + (when (and (featurep 'font-lock) + font-lock-auto-fontify) + (turn-on-font-lock))) + +(defun message-xmas-make-caesar-translation-table (n) + "Create a rot table with offset N." + (let ((i -1) + (table (make-string 256 0)) + (a (char-int ?a)) + (A (char-int ?A))) + (while (< (incf i) 256) + (aset table i i)) + (concat + (substring table 0 A) + (substring table (+ A n) (+ A n (- 26 n))) + (substring table A (+ A n)) + (substring table (+ A 26) a) + (substring table (+ a n) (+ a n (- 26 n))) + (substring table a (+ a n)) + (substring table (+ a 26) 255)))) + +(when (>= emacs-major-version 20) + (fset 'message-make-caesar-translation-table + 'message-xmas-make-caesar-translation-table)) + +(add-hook 'message-mode-hook 'message-xmas-maybe-fontify) + +(provide 'messagexmas) + +;;; messagexmas.el ends here diff --git a/lisp/messcompat.el b/lisp/messcompat.el new file mode 100644 index 0000000..19371fe --- /dev/null +++ b/lisp/messcompat.el @@ -0,0 +1,86 @@ +;;; messcompat.el --- making message mode compatible with mail mode +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file tries to provide backward compatability with sendmail.el +;; for Message mode. It should be used by simply adding +;; +;; (require 'messcompat) +;; +;; to the .emacs file. Loading it after Message mode has been +;; loaded will have no effect. + +;;; Code: + +(require 'sendmail) + +(defvar message-from-style mail-from-style + "*Specifies how \"From\" headers look. + +If `nil', they contain just the return address like: + king@grassland.com +If `parens', they look like: + king@grassland.com (Elvis Parsley) +If `angles', they look like: + Elvis Parsley + +Otherwise, most addresses look like `angles', but they look like +`parens' if `angles' would need quoting and `parens' would not.") + +(defvar message-interactive mail-interactive + "Non-nil means when sending a message wait for and display errors. +nil means let mailer mail back a message to report errors.") + +(defvar message-setup-hook mail-setup-hook + "Normal hook, run each time a new outgoing message is initialized. +The function `message-setup' runs this hook.") + +(defvar message-mode-hook mail-mode-hook + "Hook run in message mode buffers.") + +(defvar message-indentation-spaces mail-indentation-spaces + "*Number of spaces to insert at the beginning of each cited line. +Used by `message-yank-original' via `message-yank-cite'.") + +(defvar message-signature mail-signature + "*String to be inserted at the end of the message buffer. +If t, the `message-signature-file' file will be inserted instead. +If a function, the result from the function will be used instead. +If a form, the result from the form will be used instead.") + +;; Deleted the autoload cookie because this crashes in loaddefs.el. +(defvar message-signature-file mail-signature-file + "*File containing the text inserted at end of message. buffer.") + +(defvar message-default-headers mail-default-headers + "*A string containing header lines to be inserted in outgoing messages. +It is inserted before you edit the message, so you can edit or delete +these lines.") + +(defvar message-send-hook mail-send-hook + "Hook run before sending messages.") + +(provide 'messcompat) + +;;; messcompat.el ends here diff --git a/lisp/nnagent.el b/lisp/nnagent.el new file mode 100644 index 0000000..9f762aa --- /dev/null +++ b/lisp/nnagent.el @@ -0,0 +1,119 @@ +;;; nnagent.el --- offline backend for Gnus +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nnoo) +(require 'cl) +(require 'gnus-agent) +(require 'nnml) + +(nnoo-declare nnagent + nnml) + + + +(defconst nnagent-version "nnagent 1.0") + +(defvoo nnagent-directory nil + "Internal variable." + nnml-directory) + +(defvoo nnagent-active-file nil + "Internal variable." + nnml-active-file) + +(defvoo nnagent-newsgroups-file nil + "Internal variable." + nnml-newsgroups-file) + +(defvoo nnagent-get-new-mail nil + "Internal variable." + nnml-get-new-mail) + +;;; Interface functions. + +(nnoo-define-basics nnagent) + +(deffoo nnagent-open-server (server &optional defs) + (setq defs + `((nnagent-directory ,(gnus-agent-directory)) + (nnagent-active-file ,(gnus-agent-lib-file "active")) + (nnagent-newsgroups-file ,(gnus-agent-lib-file "newsgroups")) + (nnagent-get-new-mail nil))) + (nnoo-change-server 'nnagent server defs) + (let ((dir (gnus-agent-directory)) + err) + (cond + ((not (condition-case arg + (file-exists-p dir) + (ftp-error (setq err (format "%s" arg))))) + (nnagent-close-server) + (nnheader-report + 'nnagent (or err "No such file or directory: %s" dir))) + ((not (file-directory-p (file-truename dir))) + (nnagent-close-server) + (nnheader-report 'nnagent "Not a directory: %s" dir)) + (t + (nnheader-report 'nnagent "Opened server %s using directory %s" + server dir) + t)))) + +(deffoo nnagent-retrieve-groups (groups &optional server) + (save-excursion + (cond + ((file-exists-p (gnus-agent-lib-file "groups")) + (nnmail-find-file (gnus-agent-lib-file "groups")) + 'groups) + ((file-exists-p (gnus-agent-lib-file "active")) + (nnmail-find-file (gnus-agent-lib-file "active")) + 'active) + (t nil)))) + +(defun nnagent-request-type (group article) + (let ((gnus-plugged t)) + (if (not (gnus-check-backend-function + 'request-type (car gnus-command-method))) + 'unknown + (funcall (gnus-get-function gnus-command-method 'request-type) + (gnus-group-real-name group) article)))) + +(deffoo nnagent-request-newgroups (date server) + nil) + +(deffoo nnagent-request-post (&optional server) + (gnus-request-accept-article "nndraft:queue")) + +;; Use nnml functions for just about everything. +(nnoo-import nnagent + (nnml)) + + +;;; Internal functions. + +(provide 'nnagent) + +;;; nnagent.el ends here diff --git a/lisp/nnbabyl.el b/lisp/nnbabyl.el new file mode 100644 index 0000000..8c37024 --- /dev/null +++ b/lisp/nnbabyl.el @@ -0,0 +1,650 @@ +;;; nnbabyl.el --- rmail mbox access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; For an overview of what the interface functions do, please see the +;; Gnus sources. + +;;; Code: + +(require 'nnheader) +(require 'rmail) +(require 'nnmail) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnbabyl) + +(defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL") + "The name of the rmail box file in the users home directory.") + +(defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active") + "The name of the active file for the rmail box.") + +(defvoo nnbabyl-get-new-mail t + "If non-nil, nnbabyl will check the incoming mail file and split the mail.") + +(defvoo nnbabyl-prepare-save-mail-hook nil + "Hook run narrowed to an article before saving.") + + + +(defvar nnbabyl-mail-delimiter "\^_") + +(defconst nnbabyl-version "nnbabyl 1.0" + "nnbabyl version.") + +(defvoo nnbabyl-mbox-buffer nil) +(defvoo nnbabyl-current-group nil) +(defvoo nnbabyl-status-string "") +(defvoo nnbabyl-group-alist nil) +(defvoo nnbabyl-active-timestamp nil) + +(defvoo nnbabyl-previous-buffer-mode nil) + +(eval-and-compile + (autoload 'gnus-set-text-properties "gnus-ems")) + + + +;;; Interface functions + +(nnoo-define-basics nnbabyl) + +(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((number (length articles)) + (count 0) + (delim (concat "^" nnbabyl-mail-delimiter)) + article art-string start stop) + (nnbabyl-possibly-change-newsgroup group server) + (while (setq article (pop articles)) + (setq art-string (nnbabyl-article-string article)) + (set-buffer nnbabyl-mbox-buffer) + (end-of-line) + (when (or (search-forward art-string nil t) + (search-backward art-string nil t)) + (unless (re-search-backward delim nil t) + (goto-char (point-min))) + (while (and (not (looking-at ".+:")) + (zerop (forward-line 1)))) + (setq start (point)) + (search-forward "\n\n" nil t) + (setq stop (1- (point))) + (set-buffer nntp-server-buffer) + (insert "221 ") + (princ article (current-buffer)) + (insert " Article retrieved.\n") + (insert-buffer-substring nnbabyl-mbox-buffer start stop) + (goto-char (point-max)) + (insert ".\n")) + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (zerop (% (incf count) 20)) + (nnheader-message 5 "nnbabyl: Receiving headers... %d%%" + (/ (* count 100) number)))) + + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (nnheader-message 5 "nnbabyl: Receiving headers...done")) + + (set-buffer nntp-server-buffer) + (nnheader-fold-continuation-lines) + 'headers))) + +(deffoo nnbabyl-open-server (server &optional defs) + (nnoo-change-server 'nnbabyl server defs) + (nnbabyl-create-mbox) + (cond + ((not (file-exists-p nnbabyl-mbox-file)) + (nnbabyl-close-server) + (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file)) + ((file-directory-p nnbabyl-mbox-file) + (nnbabyl-close-server) + (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file)) + (t + (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server + nnbabyl-mbox-file) + t))) + +(deffoo nnbabyl-close-server (&optional server) + ;; Restore buffer mode. + (when (and (nnbabyl-server-opened) + nnbabyl-previous-buffer-mode) + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (narrow-to-region + (caar nnbabyl-previous-buffer-mode) + (cdar nnbabyl-previous-buffer-mode)) + (funcall (cdr nnbabyl-previous-buffer-mode)))) + (nnoo-close-server 'nnbabyl server) + (setq nnbabyl-mbox-buffer nil) + t) + +(deffoo nnbabyl-server-opened (&optional server) + (and (nnoo-current-server-p 'nnbabyl server) + nnbabyl-mbox-buffer + (buffer-name nnbabyl-mbox-buffer) + nntp-server-buffer + (buffer-name nntp-server-buffer))) + +(deffoo nnbabyl-request-article (article &optional newsgroup server buffer) + (nnbabyl-possibly-change-newsgroup newsgroup server) + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-min)) + (when (search-forward (nnbabyl-article-string article) nil t) + (let (start stop summary-line) + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) + (while (and (not (looking-at ".+:")) + (zerop (forward-line 1)))) + (setq start (point)) + (or (when (re-search-forward + (concat "^" nnbabyl-mail-delimiter) nil t) + (beginning-of-line) + t) + (goto-char (point-max))) + (setq stop (point)) + (let ((nntp-server-buffer (or buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring nnbabyl-mbox-buffer start stop) + (goto-char (point-min)) + ;; If there is an EOOH header, then we have to remove some + ;; duplicated headers. + (setq summary-line (looking-at "Summary-line:")) + (when (search-forward "\n*** EOOH ***" nil t) + (if summary-line + ;; The headers to be deleted are located before the + ;; EOOH line... + (delete-region (point-min) (progn (forward-line 1) + (point))) + ;; ...or after. + (delete-region (progn (beginning-of-line) (point)) + (or (search-forward "\n\n" nil t) + (point))))) + (if (numberp article) + (cons nnbabyl-current-group article) + (nnbabyl-article-group-number))))))) + +(deffoo nnbabyl-request-group (group &optional server dont-check) + (let ((active (cadr (assoc group nnbabyl-group-alist)))) + (save-excursion + (cond + ((or (null active) + (null (nnbabyl-possibly-change-newsgroup group server))) + (nnheader-report 'nnbabyl "No such group: %s" group)) + (dont-check + (nnheader-report 'nnbabyl "Selected group %s" group) + (nnheader-insert "")) + (t + (nnheader-report 'nnbabyl "Selected group %s" group) + (nnheader-insert "211 %d %d %d %s\n" + (1+ (- (cdr active) (car active))) + (car active) (cdr active) group)))))) + +(deffoo nnbabyl-request-scan (&optional group server) + (nnbabyl-possibly-change-newsgroup group server) + (nnbabyl-read-mbox) + (nnmail-get-new-mail + 'nnbabyl + (lambda () + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (save-buffer))) + (file-name-directory nnbabyl-mbox-file) + group + (lambda () + (save-excursion + (let ((in-buf (current-buffer))) + (goto-char (point-min)) + (while (search-forward "\n\^_\n" nil t) + (delete-char -1)) + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-max)) + (search-backward "\n\^_" nil t) + (goto-char (match-end 0)) + (insert-buffer-substring in-buf))) + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))) + +(deffoo nnbabyl-close-group (group &optional server) + t) + +(deffoo nnbabyl-request-create-group (group &optional server args) + (nnmail-activate 'nnbabyl) + (unless (assoc group nnbabyl-group-alist) + (push (list group (cons 1 0)) + nnbabyl-group-alist) + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) + t) + +(deffoo nnbabyl-request-list (&optional server) + (save-excursion + (nnmail-find-file nnbabyl-active-file) + (setq nnbabyl-group-alist (nnmail-get-active)) + t)) + +(deffoo nnbabyl-request-newgroups (date &optional server) + (nnbabyl-request-list server)) + +(deffoo nnbabyl-request-list-newsgroups (&optional server) + (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented.")) + +(deffoo nnbabyl-request-expire-articles + (articles newsgroup &optional server force) + (nnbabyl-possibly-change-newsgroup newsgroup server) + (let* ((is-old t) + rest) + (nnmail-activate 'nnbabyl) + + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (gnus-set-text-properties (point-min) (point-max) nil) + (while (and articles is-old) + (goto-char (point-min)) + (when (search-forward (nnbabyl-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) force)) + (progn + (nnheader-message 5 "Deleting article %d in %s..." + (car articles) newsgroup) + (nnbabyl-delete-mail)) + (push (car articles) rest))) + (setq articles (cdr articles))) + (save-buffer) + ;; Find the lowest active article in this group. + (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist)))) + (goto-char (point-min)) + (while (and (not (search-forward + (nnbabyl-article-string (car active)) nil t)) + (<= (car active) (cdr active))) + (setcar active (1+ (car active))) + (goto-char (point-min)))) + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) + (nconc rest articles)))) + +(deffoo nnbabyl-request-move-article + (article group server accept-form &optional last) + (let ((buf (get-buffer-create " *nnbabyl move*")) + result) + (and + (nnbabyl-request-article article group server) + (save-excursion + (set-buffer buf) + (insert-buffer-substring nntp-server-buffer) + (goto-char (point-min)) + (while (re-search-forward + "^X-Gnus-Newsgroup:" + (save-excursion (search-forward "\n\n" nil t) (point)) t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (save-excursion + (nnbabyl-possibly-change-newsgroup group server) + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-min)) + (if (search-forward (nnbabyl-article-string article) nil t) + (nnbabyl-delete-mail)) + (and last (save-buffer)))) + result)) + +(deffoo nnbabyl-request-accept-article (group &optional server last) + (nnbabyl-possibly-change-newsgroup group server) + (nnmail-check-syntax) + (let ((buf (current-buffer)) + result beg) + (and + (nnmail-activate 'nnbabyl) + (save-excursion + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (forward-line -1) + (save-excursion + (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) + (delete-region (point) (progn (forward-line 1) (point))))) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (setq result + (if (stringp group) + (list (cons group (nnbabyl-active-number group))) + (nnmail-article-group 'nnbabyl-active-number))) + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result (car (nnbabyl-save-mail result)))) + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-max)) + (search-backward "\n\^_") + (goto-char (match-end 0)) + (insert-buffer-substring buf) + (when last + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (save-buffer) + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) + result)))) + +(deffoo nnbabyl-request-replace-article (article group buffer) + (nnbabyl-possibly-change-newsgroup group) + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-min)) + (if (not (search-forward (nnbabyl-article-string article) nil t)) + nil + (nnbabyl-delete-mail t t) + (insert-buffer-substring buffer) + (save-buffer) + t))) + +(deffoo nnbabyl-request-delete-group (group &optional force server) + (nnbabyl-possibly-change-newsgroup group server) + ;; Delete all articles in GROUP. + (if (not force) + () ; Don't delete the articles. + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-min)) + ;; Delete all articles in this group. + (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) + found) + (while (search-forward ident nil t) + (setq found t) + (nnbabyl-delete-mail)) + (when found + (save-buffer))))) + ;; Remove the group from all structures. + (setq nnbabyl-group-alist + (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist) + nnbabyl-current-group nil) + ;; Save the active file. + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) + t) + +(deffoo nnbabyl-request-rename-group (group new-name &optional server) + (nnbabyl-possibly-change-newsgroup group server) + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-min)) + (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) + (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) + found) + (while (search-forward ident nil t) + (replace-match new-ident t t) + (setq found t)) + (when found + (save-buffer)))) + (let ((entry (assoc group nnbabyl-group-alist))) + (and entry (setcar entry new-name)) + (setq nnbabyl-current-group nil) + ;; Save the new group alist. + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) + t)) + + +;;; Internal functions. + +;; If FORCE, delete article no matter how many X-Gnus-Newsgroup +;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox +;; delimiter line. +(defun nnbabyl-delete-mail (&optional force leave-delim) + ;; Delete the current X-Gnus-Newsgroup line. + (unless force + (delete-region + (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + ;; Beginning of the article. + (save-excursion + (save-restriction + (widen) + (narrow-to-region + (save-excursion + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) + (if leave-delim (progn (forward-line 1) (point)) + (match-beginning 0))) + (progn + (forward-line 1) + (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) + nil t) + (match-beginning 0)) + (point-max)))) + (goto-char (point-min)) + ;; Only delete the article if no other groups owns it as well. + (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (delete-region (point-min) (point-max)))))) + +(defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server) + (when (and server + (not (nnbabyl-server-opened server))) + (nnbabyl-open-server server)) + (when (or (not nnbabyl-mbox-buffer) + (not (buffer-name nnbabyl-mbox-buffer))) + (save-excursion (nnbabyl-read-mbox))) + (unless nnbabyl-group-alist + (nnmail-activate 'nnbabyl)) + (if newsgroup + (if (assoc newsgroup nnbabyl-group-alist) + (setq nnbabyl-current-group newsgroup) + (nnheader-report 'nnbabyl "No such group in file")) + t)) + +(defun nnbabyl-article-string (article) + (if (numberp article) + (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" + (int-to-string article) " ") + (concat "\nMessage-ID: " article))) + +(defun nnbabyl-article-group-number () + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " + nil t) + (cons (buffer-substring (match-beginning 1) (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))))) + +(defun nnbabyl-insert-lines () + "Insert how many lines and chars there are in the body of the mail." + (let (lines chars) + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + ;; There may be an EOOH line here... + (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") + (search-forward "\n\n" nil t)) + (setq chars (- (point-max) (point)) + lines (max (- (count-lines (point) (point-max)) 1) 0)) + ;; Move back to the end of the headers. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (forward-char -1) + (save-excursion + (when (re-search-backward "^Lines: " nil t) + (delete-region (point) (progn (forward-line 1) (point))))) + (insert (format "Lines: %d\n" lines)) + chars)))) + +(defun nnbabyl-save-mail (group-art) + ;; Called narrowed to an article. + (nnbabyl-insert-lines) + (nnmail-insert-xref group-art) + (nnbabyl-insert-newsgroup-line group-art) + (run-hooks 'nnbabyl-prepare-save-mail-hook) + group-art) + +(defun nnbabyl-insert-newsgroup-line (group-art) + (save-excursion + (goto-char (point-min)) + (while (looking-at "From ") + (replace-match "Mail-from: From " t t) + (forward-line 1)) + ;; If there is a C-l at the beginning of the narrowed region, this + ;; isn't really a "save", but rather a "scan". + (goto-char (point-min)) + (unless (looking-at "\^L") + (save-excursion + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (goto-char (point-max)) + (insert "\^_\n"))) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (while group-art + (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" + (caar group-art) (cdar group-art) + (current-time-string))) + (setq group-art (cdr group-art)))) + t)) + +(defun nnbabyl-active-number (group) + ;; Find the next article number in GROUP. + (let ((active (cadr (assoc group nnbabyl-group-alist)))) + (if active + (setcdr active (1+ (cdr active))) + ;; This group is new, so we create a new entry for it. + ;; This might be a bit naughty... creating groups on the drop of + ;; a hat, but I don't know... + (push (list group (setq active (cons 1 1))) + nnbabyl-group-alist)) + (cdr active))) + +(defun nnbabyl-create-mbox () + (unless (file-exists-p nnbabyl-mbox-file) + ;; Create a new, empty RMAIL mbox file. + (save-excursion + (set-buffer (setq nnbabyl-mbox-buffer + (create-file-buffer nnbabyl-mbox-file))) + (setq buffer-file-name nnbabyl-mbox-file) + (insert "BABYL OPTIONS:\n\n\^_") + (nnmail-write-region + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) + +(defun nnbabyl-read-mbox () + (nnmail-activate 'nnbabyl) + (nnbabyl-create-mbox) + + (unless (and nnbabyl-mbox-buffer + (buffer-name nnbabyl-mbox-buffer) + (save-excursion + (set-buffer nnbabyl-mbox-buffer) + (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) + ;; This buffer has changed since we read it last. Possibly. + (save-excursion + (let ((delim (concat "^" nnbabyl-mail-delimiter)) + (alist nnbabyl-group-alist) + start end number) + (set-buffer (setq nnbabyl-mbox-buffer + (nnheader-find-file-noselect + nnbabyl-mbox-file nil 'raw))) + ;; Save previous buffer mode. + (setq nnbabyl-previous-buffer-mode + (cons (cons (point-min) (point-max)) + major-mode)) + + (buffer-disable-undo (current-buffer)) + (widen) + (setq buffer-read-only nil) + (fundamental-mode) + + ;; Go through the group alist and compare against + ;; the rmail file. + (while alist + (goto-char (point-max)) + (when (and (re-search-backward + (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " + (caar alist)) + nil t) + (> (setq number + (string-to-number + (buffer-substring + (match-beginning 1) (match-end 1)))) + (cdadar alist))) + (setcdr (cadar alist) number)) + (setq alist (cdr alist))) + + ;; We go through the mbox and make sure that each and + ;; every mail belongs to some group or other. + (goto-char (point-min)) + (if (looking-at "\^L") + (setq start (point)) + (re-search-forward delim nil t) + (setq start (match-end 0))) + (while (re-search-forward delim nil t) + (setq end (match-end 0)) + (unless (search-backward "\nX-Gnus-Newsgroup: " start t) + (goto-char end) + (save-excursion + (save-restriction + (narrow-to-region (goto-char start) end) + (nnbabyl-save-mail + (nnmail-article-group 'nnbabyl-active-number)) + (setq end (point-max))))) + (goto-char (setq start end))) + (when (buffer-modified-p (current-buffer)) + (save-buffer)) + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))) + +(defun nnbabyl-remove-incoming-delims () + (goto-char (point-min)) + (while (search-forward "\^_" nil t) + (replace-match "?" t t))) + +(defun nnbabyl-check-mbox () + "Go through the nnbabyl mbox and make sure that no article numbers are reused." + (interactive) + (let ((idents (make-vector 1000 0)) + id) + (save-excursion + (when (or (not nnbabyl-mbox-buffer) + (not (buffer-name nnbabyl-mbox-buffer))) + (nnbabyl-read-mbox)) + (set-buffer nnbabyl-mbox-buffer) + (goto-char (point-min)) + (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) + (if (intern-soft (setq id (match-string 1)) idents) + (progn + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))) + (nnheader-message 7 "Moving %s..." id) + (nnbabyl-save-mail + (nnmail-article-group 'nnbabyl-active-number))) + (intern id idents))) + (when (buffer-modified-p (current-buffer)) + (save-buffer)) + (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) + (message "")))) + +(provide 'nnbabyl) + +;;; nnbabyl.el ends here diff --git a/lisp/nndb.el b/lisp/nndb.el new file mode 100644 index 0000000..679376b --- /dev/null +++ b/lisp/nndb.el @@ -0,0 +1,332 @@ +;;; nndb.el --- nndb access for Gnus +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Kai Grossjohann +;; Joe Hildebrand +;; David Blacka +;; Keywords: news + +;; This file is NOT part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; This was based upon Kai Grossjohan's shamessly snarfed code and +;;; further modified by Joe Hildebrand. It has been updated for Red +;;; Gnus. + +;; TODO: +;; +;; * Fix bug where server connection can be lost and impossible to regain +;; This hasn't happened to me in a while; think it was fixed in Rgnus +;; +;; * make it handle different nndb servers seemlessly +;; +;; * Optimize expire if FORCE +;; +;; * Optimize move (only expire once) +;; +;; * Deal with add/deletion of groups +;; +;; * make the backend TOUCH an article when marked as expireable (will +;; make article expire 'expiry' days after that moment). + +;;- +;; Register nndb with known select methods. + +(gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address) + +;;; Code: + +(require 'nnmail) +(require 'nnheader) +(require 'nntp) +(eval-when-compile (require 'cl)) + +(eval-and-compile + (unless (fboundp 'open-network-stream) + (require 'tcp))) + +(eval-when-compile (require 'cl)) + +(eval-and-compile + (autoload 'news-setup "rnewspost") + (autoload 'news-reply-mode "rnewspost") + (autoload 'cancel-timer "timer") + (autoload 'telnet "telnet" nil t) + (autoload 'telnet-send-input "telnet" nil t) + (autoload 'timezone-parse-date "timezone")) + +;; Declare nndb as derived from nntp + +(nnoo-declare nndb nntp) + +;; Variables specific to nndb + +;;- currently not used but just in case... +(defvoo nndb-deliver-program "nndel" + "*The program used to put a message in an NNDB group.") + +(defvoo nndb-server-side-expiry nil + "If t, expiry calculation will occur on the server side") + +(defvoo nndb-set-expire-date-on-mark nil + "If t, the expiry date for a given article will be set to the time +it was marked as expireable; otherwise the date will be the time the +article was posted to nndb") + +;; Variables copied from nntp + +(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) + "Like nntp-server-opened-hook." + nntp-server-opened-hook) + +(defvoo nndb-address "localhost" + "*The name of the NNDB server." + nntp-address) + +(defvoo nndb-port-number 9000 + "*Port number to connect to." + nntp-port-number) + +;; change to 'news if you are actually using nndb for news +(defvoo nndb-article-type 'mail) + +(defvoo nndb-status-string nil "" nntp-status-string) + + + +(defconst nndb-version "nndb 0.7" + "Version numbers of this version of NNDB.") + + +;;; Interface functions. + +(nnoo-define-basics nndb) + +;;------------------------------------------------------------------ + +;; this function turns the lisp list into a string list. There is +;; probably a more efficient way to do this. +(defun nndb-build-article-string (articles) + (let (art-string art) + (while articles + (setq art (pop articles)) + (setq art-string (concat art-string art " "))) + art-string)) + +(defun nndb-build-expire-rest-list (total expire) + (let (art rest) + (while total + (setq art (pop total)) + (if (memq art expire) + () + (push art rest))) + rest)) + + +;; +(deffoo nndb-request-type (group &optional article) + nndb-article-type) + +;; nndb-request-update-info does not exist and is not needed + +;; nndb-request-update-mark does not exist; it should be used to TOUCH +;; articles as they are marked exipirable +(defun nndb-touch-article (group article) + (nntp-send-command nil "X-TOUCH" article)) + +(deffoo nndb-request-update-mark + (group article mark) + "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" + (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) + (nndb-touch-article group article)) + mark) + +;; nndb-request-create-group -- currently this isn't necessary; nndb +;; creates groups on demand. + +;; todo -- use some other time than the creation time of the article +;; best is time since article has been marked as expirable + +(defun nndb-request-expire-articles-local + (articles &optional group server force) + "Let gnus do the date check and issue the delete commands." + (let (msg art delete-list (num-delete 0) rest) + (nntp-possibly-change-group group server) + (while articles + (setq art (pop articles)) + (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) + (setq msg (nndb-status-message)) + (if (string-match "^423" msg) + () + (or (string-match "'\\(.+\\)'" msg) + (error "Not a valid response for X-DATE command: %s" + msg)) + (if (nnmail-expired-article-p + group + (gnus-encode-date + (substring msg (match-beginning 1) (match-end 1))) + force) + (progn + (setq delete-list (concat delete-list " " (int-to-string art))) + (setq num-delete (1+ num-delete))) + (push art rest)))) + (if (> (length delete-list) 0) + (progn + (nnheader-message 5 "Deleting %s article(s) from %s" + (int-to-string num-delete) group) + (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) + ) + + (message "") + (nconc rest articles))) + +(defun nndb-get-remote-expire-response () + (let (list) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (looking-at "^[34]") + ;; x-expire returned error--presume no articles were expirable) + (setq list nil) + ;; otherwise, pull all of the following numbers into the list + (re-search-forward "follows\r?\n?" nil t) + (while (re-search-forward "^[0-9]+$" nil t) + (push (string-to-int (match-string 0)) list))) + list)) + +(defun nndb-request-expire-articles-remote + (articles &optional group server force) + "Let the nndb backend expire articles" + (let (days art-string delete-list (num-delete 0)) + (nntp-possibly-change-group group server) + + ;; first calculate the wait period in days + (setq days (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function group)) + nnmail-expiry-wait)) + ;; now handle the special cases + (cond (force + (setq days 0)) + ((eq days 'never) + ;; This isn't an expirable group. + (setq days -1)) + ((eq days 'immediate) + (setq days 0))) + + + ;; build article string + (setq art-string (concat days " " (nndb-build-article-string articles))) + (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) + + (setq delete-list (nndb-get-remote-expire-response)) + (setq num-delete (length delete-list)) + (if (> num-delete 0) + (nnheader-message 5 "Deleting %s article(s) from %s" + (int-to-string num-delete) group)) + + (nndb-build-expire-rest-list articles delete-list))) + +(deffoo nndb-request-expire-articles + (articles &optional group server force) + "Expires ARTICLES from GROUP on SERVER. +If FORCE, delete regardless of exiration date, otherwise use normal +expiry mechanism." + (if nndb-server-side-expiry + (nndb-request-expire-articles-remote articles group server force) + (nndb-request-expire-articles-local articles group server force))) + +(deffoo nndb-request-move-article + (article group server accept-form &optional last) + "Move ARTICLE (a number) from GROUP on SERVER. +Evals ACCEPT-FORM in current buffer, where the article is. +Optional LAST is ignored." + ;; we guess that the second arg in accept-form is the new group, + ;; which it will be for nndb, which is all that matters anyway + (let ((new-group (nth 1 accept-form)) result) + (nntp-possibly-change-group group server) + + ;; use the move command for nndb-to-nndb moves + (if (string-match "^nndb" new-group) + (let ((new-group-name (gnus-group-real-name new-group))) + (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) + (cons new-group article)) + ;; else move normally + (let ((artbuf (get-buffer-create " *nndb move*"))) + (and + (nndb-request-article article group server artbuf) + (save-excursion + (set-buffer artbuf) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (nndb-request-expire-articles (list article) + group + server + t)) + result) + ))) + +(deffoo nndb-request-accept-article (group server &optional last) + "The article in the current buffer is put into GROUP." + (nntp-possibly-change-group group server) + (let (art msg) + (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) + (nnheader-insert "") + (nntp-send-buffer "^[23].*\n")) + + (set-buffer nntp-server-buffer) + (setq msg (buffer-string (point-min) (point-max))) + (or (string-match "^\\([0-9]+\\)" msg) + (error "nndb: %s" msg)) + (setq art (substring msg (match-beginning 1) (match-end 1))) + (message "nndb: accepted %s" art) + (list art))) + +(deffoo nndb-request-replace-article (article group buffer) + "ARTICLE is the number of the article in GROUP to be replaced +with the contents of the BUFFER." + (set-buffer buffer) + (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) + (nnheader-insert "") + (nntp-send-buffer "^[23.*\n") + (list (int-to-string article)))) + +; nndb-request-delete-group does not exist +; todo -- maybe later + +; nndb-request-rename-group does not exist +; todo -- maybe later + +;; -- standard compatability functions + +(deffoo nndb-status-message (&optional server) + "Return server status as a string." + (set-buffer nntp-server-buffer) + (buffer-string (point-min) (point-max))) + +;; Import stuff from nntp + +(nnoo-import nndb + (nntp)) + +(provide 'nndb) + + + diff --git a/lisp/nndir.el b/lisp/nndir.el new file mode 100644 index 0000000..89d4954 --- /dev/null +++ b/lisp/nndir.el @@ -0,0 +1,99 @@ +;;; nndir.el --- single directory newsgroup access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nnmh) +(require 'nnml) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nndir + nnml nnmh) + +(defvoo nndir-directory nil + "Where nndir will look for groups." + nnml-current-directory nnmh-current-directory) + +(defvoo nndir-nov-is-evil nil + "*Non-nil means that nndir will never retrieve NOV headers." + nnml-nov-is-evil) + + + +(defvoo nndir-current-group "" nil nnml-current-group nnmh-current-group) +(defvoo nndir-top-directory nil nil nnml-directory nnmh-directory) +(defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail) + +(defvoo nndir-status-string "" nil nnmh-status-string) +(defconst nndir-version "nndir 1.0") + + + +;;; Interface functions. + +(nnoo-define-basics nndir) + +(deffoo nndir-open-server (server &optional defs) + (setq nndir-directory + (or (cadr (assq 'nndir-directory defs)) + server)) + (unless (assq 'nndir-directory defs) + (push `(nndir-directory ,server) defs)) + (push `(nndir-current-group + ,(file-name-nondirectory (directory-file-name nndir-directory))) + defs) + (push `(nndir-top-directory + ,(file-name-directory (directory-file-name nndir-directory))) + defs) + (nnoo-change-server 'nndir server defs) + (let (err) + (cond + ((not (condition-case arg + (file-exists-p nndir-directory) + (ftp-error (setq err (format "%s" arg))))) + (nndir-close-server) + (nnheader-report + 'nndir (or err "No such file or directory: %s" nndir-directory))) + ((not (file-directory-p (file-truename nndir-directory))) + (nndir-close-server) + (nnheader-report 'nndir "Not a directory: %s" nndir-directory)) + (t + (nnheader-report 'nndir "Opened server %s using directory %s" + server nndir-directory) + t)))) + +(nnoo-map-functions nndir + (nnml-retrieve-headers 0 nndir-current-group 0 0) + (nnmh-request-article 0 nndir-current-group 0 0) + (nnmh-request-group nndir-current-group 0 0) + (nnml-close-group nndir-current-group 0) + (nnmh-request-list (nnoo-current-server 'nndir) nndir-directory) + (nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory)) + +(provide 'nndir) + +;;; nndir.el ends here diff --git a/lisp/nndoc.el b/lisp/nndoc.el new file mode 100644 index 0000000..396de86 --- /dev/null +++ b/lisp/nndoc.el @@ -0,0 +1,628 @@ +;;; nndoc.el --- single file access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'message) +(require 'nnmail) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nndoc) + +(defvoo nndoc-article-type 'guess + "*Type of the file. +One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', +`rfc934', `rfc822-forward', `mime-digest', `standard-digest', +`slack-digest', `clari-briefs' or `guess'.") + +(defvoo nndoc-post-type 'mail + "*Whether the nndoc group is `mail' or `post'.") + +(defvar nndoc-type-alist + `((mmdf + (article-begin . "^\^A\^A\^A\^A\n") + (body-end . "^\^A\^A\^A\^A\n")) + (news + (article-begin . "^Path:")) + (rnews + (article-begin . "^#! *rnews +\\([0-9]+\\) *\n") + (body-end-function . nndoc-rnews-body-end)) + (mbox + (article-begin-function . nndoc-mbox-article-begin) + (body-end-function . nndoc-mbox-body-end)) + (babyl + (article-begin . "\^_\^L *\n") + (body-end . "\^_") + (body-begin-function . nndoc-babyl-body-begin) + (head-begin-function . nndoc-babyl-head-begin)) + (forward + (article-begin . "^-+ Start of forwarded message -+\n+") + (body-end . "^-+ End of forwarded message -+$") + (prepare-body-function . nndoc-unquote-dashes)) + (rfc934 + (article-begin . "^--.*\n+") + (body-end . "^--.*$") + (prepare-body-function . nndoc-unquote-dashes)) + (clari-briefs + (article-begin . "^ \\*") + (body-end . "^\t------*[ \t]^*\n^ \\*") + (body-begin . "^\t") + (head-end . "^\t") + (generate-head-function . nndoc-generate-clari-briefs-head) + (article-transform-function . nndoc-transform-clari-briefs)) + (mime-digest + (article-begin . "") + (head-end . "^ ?$") + (body-end . "") + (file-end . "") + (subtype digest guess)) + (standard-digest + (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) + (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n\n+")) + (prepare-body-function . nndoc-unquote-dashes) + (body-end-function . nndoc-digest-body-end) + (head-end . "^ ?$") + (body-begin . "^ ?\n") + (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$") + (subtype digest guess)) + (slack-digest + (article-begin . "^------------------------------*[\n \t]+") + (head-end . "^ ?$") + (body-end-function . nndoc-digest-body-end) + (body-begin . "^ ?$") + (file-end . "^End of") + (prepare-body-function . nndoc-unquote-dashes) + (subtype digest guess)) + (lanl-gov-announce + (article-begin . "^\\\\\\\\\n") + (head-begin . "^Paper.*:") + (head-end . "\\(^\\\\\\\\.*\n\\|-----------------\\)") + (body-begin . "") + (body-end . "-------------------------------------------------") + (file-end . "^Title: Recent Seminal") + (generate-head-function . nndoc-generate-lanl-gov-head) + (article-transform-function . nndoc-transform-lanl-gov-announce) + (subtype preprints guess)) + (rfc822-forward + (article-begin . "^\n") + (body-end-function . nndoc-rfc822-forward-body-end-function)) + (guess + (guess . t) + (subtype nil)) + (digest + (guess . t) + (subtype nil)) + (preprints + (guess . t) + (subtype nil)))) + + + +(defvoo nndoc-file-begin nil) +(defvoo nndoc-first-article nil) +(defvoo nndoc-article-end nil) +(defvoo nndoc-article-begin nil) +(defvoo nndoc-head-begin nil) +(defvoo nndoc-head-end nil) +(defvoo nndoc-file-end nil) +(defvoo nndoc-body-begin nil) +(defvoo nndoc-body-end-function nil) +(defvoo nndoc-body-begin-function nil) +(defvoo nndoc-head-begin-function nil) +(defvoo nndoc-body-end nil) +(defvoo nndoc-dissection-alist nil) +(defvoo nndoc-prepare-body-function nil) +(defvoo nndoc-generate-head-function nil) +(defvoo nndoc-article-transform-function nil) +(defvoo nndoc-article-begin-function nil) + +(defvoo nndoc-status-string "") +(defvoo nndoc-group-alist nil) +(defvoo nndoc-current-buffer nil + "Current nndoc news buffer.") +(defvoo nndoc-address nil) + +(defconst nndoc-version "nndoc 1.0" + "nndoc version.") + + + +;;; Interface functions + +(nnoo-define-basics nndoc) + +(deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old) + (when (nndoc-possibly-change-buffer newsgroup server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (article entry) + (if (stringp (car articles)) + 'headers + (while articles + (when (setq entry (cdr (assq (setq article (pop articles)) + nndoc-dissection-alist))) + (insert (format "221 %d Article retrieved.\n" article)) + (if nndoc-generate-head-function + (funcall nndoc-generate-head-function article) + (insert-buffer-substring + nndoc-current-buffer (car entry) (nth 1 entry))) + (goto-char (point-max)) + (unless (= (char-after (1- (point))) ?\n) + (insert "\n")) + (insert (format "Lines: %d\n" (nth 4 entry))) + (insert ".\n"))) + + (nnheader-fold-continuation-lines) + 'headers))))) + +(deffoo nndoc-request-article (article &optional newsgroup server buffer) + (nndoc-possibly-change-buffer newsgroup server) + (save-excursion + (let ((buffer (or buffer nntp-server-buffer)) + (entry (cdr (assq article nndoc-dissection-alist))) + beg) + (set-buffer buffer) + (erase-buffer) + (when entry + (if (stringp article) + nil + (insert-buffer-substring + nndoc-current-buffer (car entry) (nth 1 entry)) + (insert "\n") + (setq beg (point)) + (insert-buffer-substring + nndoc-current-buffer (nth 2 entry) (nth 3 entry)) + (goto-char beg) + (when nndoc-prepare-body-function + (funcall nndoc-prepare-body-function)) + (when nndoc-article-transform-function + (funcall nndoc-article-transform-function article)) + t))))) + +(deffoo nndoc-request-group (group &optional server dont-check) + "Select news GROUP." + (let (number) + (cond + ((not (nndoc-possibly-change-buffer group server)) + (nnheader-report 'nndoc "No such file or buffer: %s" + nndoc-address)) + (dont-check + (nnheader-report 'nndoc "Selected group %s" group) + t) + ((zerop (setq number (length nndoc-dissection-alist))) + (nndoc-close-group group) + (nnheader-report 'nndoc "No articles in group %s" group)) + (t + (nnheader-insert "211 %d %d %d %s\n" number 1 number group))))) + +(deffoo nndoc-request-type (group &optional article) + (cond ((not article) 'unknown) + (nndoc-post-type nndoc-post-type) + (t 'unknown))) + +(deffoo nndoc-close-group (group &optional server) + (nndoc-possibly-change-buffer group server) + (and nndoc-current-buffer + (buffer-name nndoc-current-buffer) + (kill-buffer nndoc-current-buffer)) + (setq nndoc-group-alist (delq (assoc group nndoc-group-alist) + nndoc-group-alist)) + (setq nndoc-current-buffer nil) + (nnoo-close-server 'nndoc server) + (setq nndoc-dissection-alist nil) + t) + +(deffoo nndoc-request-list (&optional server) + nil) + +(deffoo nndoc-request-newgroups (date &optional server) + nil) + +(deffoo nndoc-request-list-newsgroups (&optional server) + nil) + + +;;; Internal functions. + +(defun nndoc-possibly-change-buffer (group source) + (let (buf) + (cond + ;; The current buffer is this group's buffer. + ((and nndoc-current-buffer + (buffer-name nndoc-current-buffer) + (eq nndoc-current-buffer + (setq buf (cdr (assoc group nndoc-group-alist)))))) + ;; We change buffers by taking an old from the group alist. + ;; `source' is either a string (a file name) or a buffer object. + (buf + (setq nndoc-current-buffer buf)) + ;; It's a totally new group. + ((or (and (bufferp nndoc-address) + (buffer-name nndoc-address)) + (and (stringp nndoc-address) + (file-exists-p nndoc-address) + (not (file-directory-p nndoc-address)))) + (push (cons group (setq nndoc-current-buffer + (get-buffer-create + (concat " *nndoc " group "*")))) + nndoc-group-alist) + (setq nndoc-dissection-alist nil) + (save-excursion + (set-buffer nndoc-current-buffer) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (if (stringp nndoc-address) + (nnheader-insert-file-contents nndoc-address) + (insert-buffer-substring nndoc-address))))) + ;; Initialize the nndoc structures according to this new document. + (when (and nndoc-current-buffer + (not nndoc-dissection-alist)) + (save-excursion + (set-buffer nndoc-current-buffer) + (nndoc-set-delims) + (nndoc-dissect-buffer))) + (unless nndoc-current-buffer + (nndoc-close-server)) + ;; Return whether we managed to select a file. + nndoc-current-buffer)) + +;;; +;;; Deciding what document type we have +;;; + +(defun nndoc-set-delims () + "Set the nndoc delimiter variables according to the type of the document." + (let ((vars '(nndoc-file-begin + nndoc-first-article + nndoc-article-end nndoc-head-begin nndoc-head-end + nndoc-file-end nndoc-article-begin + nndoc-body-begin nndoc-body-end-function nndoc-body-end + nndoc-prepare-body-function nndoc-article-transform-function + nndoc-generate-head-function nndoc-body-begin-function + nndoc-head-begin-function))) + (while vars + (set (pop vars) nil))) + (let (defs) + ;; Guess away until we find the real file type. + (while (assq 'guess (setq defs (cdr (assq nndoc-article-type + nndoc-type-alist)))) + (setq nndoc-article-type (nndoc-guess-type nndoc-article-type))) + ;; Set the nndoc variables. + (while defs + (set (intern (format "nndoc-%s" (caar defs))) + (cdr (pop defs)))))) + +(defun nndoc-guess-type (subtype) + (let ((alist nndoc-type-alist) + results result entry) + (while (and (not result) + (setq entry (pop alist))) + (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess))) + (goto-char (point-min)) + (when (numberp (setq result (funcall (intern + (format "nndoc-%s-type-p" + (car entry)))))) + (push (cons result entry) results) + (setq result nil)))) + (unless (or result results) + (error "Document is not of any recognized type")) + (if result + (car entry) + (cadar (sort results 'car-less-than-car))))) + +;;; +;;; Built-in type predicates and functions +;;; + +(defun nndoc-mbox-type-p () + (when (looking-at message-unix-mail-delimiter) + t)) + +(defun nndoc-mbox-article-begin () + (when (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) + (goto-char (match-beginning 0)))) + +(defun nndoc-mbox-body-end () + (let ((beg (point)) + len end) + (when + (save-excursion + (and (re-search-backward + (concat "^" message-unix-mail-delimiter) nil t) + (setq end (point)) + (search-forward "\n\n" beg t) + (re-search-backward + "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t) + (setq len (string-to-int (match-string 1))) + (search-forward "\n\n" beg t) + (unless (= (setq len (+ (point) len)) (point-max)) + (and (< len (point-max)) + (goto-char len) + (looking-at message-unix-mail-delimiter))))) + (goto-char len)))) + +(defun nndoc-mmdf-type-p () + (when (looking-at "\^A\^A\^A\^A$") + t)) + +(defun nndoc-news-type-p () + (when (looking-at "^Path:.*\n") + t)) + +(defun nndoc-rnews-type-p () + (when (looking-at "#! *rnews") + t)) + +(defun nndoc-rnews-body-end () + (and (re-search-backward nndoc-article-begin nil t) + (forward-line 1) + (goto-char (+ (point) (string-to-int (match-string 1)))))) + +(defun nndoc-babyl-type-p () + (when (re-search-forward "\^_\^L *\n" nil t) + t)) + +(defun nndoc-babyl-body-begin () + (re-search-forward "^\n" nil t) + (when (looking-at "\*\*\* EOOH \*\*\*") + (let ((next (or (save-excursion + (re-search-forward nndoc-article-begin nil t)) + (point-max)))) + (unless (re-search-forward "^\n" next t) + (goto-char next) + (forward-line -1) + (insert "\n") + (forward-line -1))))) + +(defun nndoc-babyl-head-begin () + (when (re-search-forward "^[0-9].*\n" nil t) + (when (looking-at "\*\*\* EOOH \*\*\*") + (forward-line 1)) + t)) + +(defun nndoc-forward-type-p () + (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t) + (not (re-search-forward "^Subject:.*digest" nil t)) + (not (re-search-backward "^From:" nil t 2)) + (not (re-search-forward "^From:" nil t 2))) + t)) + +(defun nndoc-rfc934-type-p () + (when (and (re-search-forward "^-+ Start of forwarded.*\n+" nil t) + (not (re-search-forward "^Subject:.*digest" nil t)) + (not (re-search-backward "^From:" nil t 2)) + (not (re-search-forward "^From:" nil t 2))) + t)) + +(defun nndoc-rfc822-forward-type-p () + (save-restriction + (message-narrow-to-head) + (when (re-search-forward "^Content-Type: *message/rfc822" nil t) + t))) + +(defun nndoc-rfc822-forward-body-end-function () + (goto-char (point-max))) + +(defun nndoc-clari-briefs-type-p () + (when (let ((case-fold-search nil)) + (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) + t)) + +(defun nndoc-transform-clari-briefs (article) + (goto-char (point-min)) + (when (looking-at " *\\*\\(.*\\)\n") + (replace-match "" t t)) + (nndoc-generate-clari-briefs-head article)) + +(defun nndoc-generate-clari-briefs-head (article) + (let ((entry (cdr (assq article nndoc-dissection-alist))) + subject from) + (save-excursion + (set-buffer nndoc-current-buffer) + (save-restriction + (narrow-to-region (car entry) (nth 3 entry)) + (goto-char (point-min)) + (when (looking-at " *\\*\\(.*\\)$") + (setq subject (match-string 1)) + (when (string-match "[ \t]+$" subject) + (setq subject (substring subject 0 (match-beginning 0))))) + (when + (let ((case-fold-search nil)) + (re-search-forward + "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t)) + (setq from (match-string 1))))) + (insert "From: " "clari@clari.net (" (or from "unknown") ")" + "\nSubject: " (or subject "(no subject)") "\n"))) + +(defun nndoc-mime-digest-type-p () + (let ((case-fold-search t) + boundary-id b-delimiter entry) + (when (and + (re-search-forward + (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" + "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"") + nil t) + (match-beginning 1)) + (setq boundary-id (match-string 1) + b-delimiter (concat "\n--" boundary-id "[\n \t]+")) + (setq entry (assq 'mime-digest nndoc-type-alist)) + (setcdr entry + (list + (cons 'head-end "^ ?$") + (cons 'body-begin "^ ?\n") + (cons 'article-begin b-delimiter) + (cons 'body-end-function 'nndoc-digest-body-end) + (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$")))) + t))) + +(defun nndoc-standard-digest-type-p () + (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t) + (re-search-forward + (concat "\n\n" (make-string 30 ?-) "\n\n") nil t)) + t)) + +(defun nndoc-digest-body-end () + (and (re-search-forward nndoc-article-begin nil t) + (goto-char (match-beginning 0)))) + +(defun nndoc-slack-digest-type-p () + 0) + +(defun nndoc-lanl-gov-announce-type-p () + (when (let ((case-fold-search nil)) + (re-search-forward "^\\\\\\\\\nPaper: [a-z-]+/[0-9]+" nil t)) + t)) + +(defun nndoc-transform-lanl-gov-announce (article) + (goto-char (point-max)) + (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t) + (replace-match "\n\nGet it at \\1 (\\2)" t nil)) + ;; (when (re-search-backward "^\\\\\\\\$" nil t) + ;; (replace-match "" t t)) + ) + +(defun nndoc-generate-lanl-gov-head (article) + (let ((entry (cdr (assq article nndoc-dissection-alist))) + (e-mail "no address given") + subject from) + (save-excursion + (set-buffer nndoc-current-buffer) + (save-restriction + (narrow-to-region (car entry) (nth 1 entry)) + (goto-char (point-min)) + (when (looking-at "^Paper.*: \\([a-z-]+/[0-9]+\\)") + (setq subject (concat " (" (match-string 1) ")")) + (when (re-search-forward "^From: \\([^ ]+\\)" nil t) + (setq e-mail (match-string 1))) + (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)" + nil t) + (setq subject (concat (match-string 1) subject)) + (setq from (concat (match-string 2) " <" e-mail ">")))) + )) + (while (and from (string-match "(\[^)\]*)" from)) + (setq from (replace-match "" t t from))) + (insert "From: " (or from "unknown") + "\nSubject: " (or subject "(no subject)") "\n"))) + + + +;;; +;;; Functions for dissecting the documents +;;; + +(defun nndoc-search (regexp) + (prog1 + (re-search-forward regexp nil t) + (beginning-of-line))) + +(defun nndoc-dissect-buffer () + "Go through the document and partition it into heads/bodies/articles." + (let ((i 0) + (first t) + head-begin head-end body-begin body-end) + (setq nndoc-dissection-alist nil) + (save-excursion + (set-buffer nndoc-current-buffer) + (goto-char (point-min)) + ;; Find the beginning of the file. + (when nndoc-file-begin + (nndoc-search nndoc-file-begin)) + ;; Go through the file. + (while (if (and first nndoc-first-article) + (nndoc-search nndoc-first-article) + (nndoc-article-begin)) + (setq first nil) + (cond (nndoc-head-begin-function + (funcall nndoc-head-begin-function)) + (nndoc-head-begin + (nndoc-search nndoc-head-begin))) + (if (or (>= (point) (point-max)) + (and nndoc-file-end + (looking-at nndoc-file-end))) + (goto-char (point-max)) + (setq head-begin (point)) + (nndoc-search (or nndoc-head-end "^$")) + (setq head-end (point)) + (if nndoc-body-begin-function + (funcall nndoc-body-begin-function) + (nndoc-search (or nndoc-body-begin "^\n"))) + (setq body-begin (point)) + (or (and nndoc-body-end-function + (funcall nndoc-body-end-function)) + (and nndoc-body-end + (nndoc-search nndoc-body-end)) + (nndoc-article-begin) + (progn + (goto-char (point-max)) + (when nndoc-file-end + (and (re-search-backward nndoc-file-end nil t) + (beginning-of-line))))) + (setq body-end (point)) + (push (list (incf i) head-begin head-end body-begin body-end + (count-lines body-begin body-end)) + nndoc-dissection-alist)))))) + +(defun nndoc-article-begin () + (if nndoc-article-begin-function + (funcall nndoc-article-begin-function) + (ignore-errors + (nndoc-search nndoc-article-begin)))) + +(defun nndoc-unquote-dashes () + "Unquote quoted non-separators in digests." + (while (re-search-forward "^- -"nil t) + (replace-match "-" t t))) + +;;;###autoload +(defun nndoc-add-type (definition &optional position) + "Add document DEFINITION to the list of nndoc document definitions. +If POSITION is nil or `last', the definition will be added +as the last checked definition, if t or `first', add as the +first definition, and if any other symbol, add after that +symbol in the alist." + ;; First remove any old instances. + (setq nndoc-type-alist + (delq (assq (car definition) nndoc-type-alist) + nndoc-type-alist)) + ;; Then enter the new definition in the proper place. + (cond + ((or (null position) (eq position 'last)) + (setq nndoc-type-alist (nconc nndoc-type-alist (list definition)))) + ((or (eq position t) (eq position 'first)) + (push definition nndoc-type-alist)) + (t + (let ((list (memq (assq position nndoc-type-alist) + nndoc-type-alist))) + (unless list + (error "No such position: %s" position)) + (setcdr list (cons definition (cdr list))))))) + +(provide 'nndoc) + +;;; nndoc.el ends here diff --git a/lisp/nndraft.el b/lisp/nndraft.el new file mode 100644 index 0000000..31eaf32 --- /dev/null +++ b/lisp/nndraft.el @@ -0,0 +1,250 @@ +;;; nndraft.el --- draft article access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nnmail) +(require 'gnus-start) +(require 'nnmh) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nndraft + nnmh) + +(defvoo nndraft-directory (nnheader-concat gnus-directory "drafts/") + "Where nndraft will store its files." + nnmh-directory) + + + +(defvoo nndraft-current-group "" nil nnmh-current-group) +(defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail) +(defvoo nndraft-current-directory nil nil nnmh-current-directory) + +(defconst nndraft-version "nndraft 1.0") +(defvoo nndraft-status-string "" nil nnmh-status-string) + + + +;;; Interface functions. + +(nnoo-define-basics nndraft) + +(deffoo nndraft-open-server (server &optional defs) + (nnoo-change-server 'nndraft server defs) + (cond + ((not (file-exists-p nndraft-directory)) + (nndraft-close-server) + (nnheader-report 'nndraft "No such file or directory: %s" + nndraft-directory)) + ((not (file-directory-p (file-truename nndraft-directory))) + (nndraft-close-server) + (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory)) + (t + (nnheader-report 'nndraft "Opened server %s using directory %s" + server nndraft-directory) + t))) + +(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old) + (nndraft-possibly-change-group group) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let* ((buf (get-buffer-create " *draft headers*")) + article) + (set-buffer buf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + ;; We don't support fetching by Message-ID. + (if (stringp (car articles)) + 'headers + (while articles + (set-buffer buf) + (when (nndraft-request-article + (setq article (pop articles)) group server (current-buffer)) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (forward-line -1) + (goto-char (point-max))) + (delete-region (point) (point-max)) + (set-buffer nntp-server-buffer) + (goto-char (point-max)) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring buf) + (insert ".\n"))) + + (nnheader-fold-continuation-lines) + 'headers)))) + +(deffoo nndraft-request-article (id &optional group server buffer) + (nndraft-possibly-change-group group) + (when (numberp id) + ;; We get the newest file of the auto-saved file and the + ;; "real" file. + (let* ((file (nndraft-article-filename id)) + (auto (nndraft-auto-save-file-name file)) + (newest (if (file-newer-than-file-p file auto) file auto)) + (nntp-server-buffer (or buffer nntp-server-buffer))) + (when (and (file-exists-p newest) + (nnmail-find-file newest)) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + ;; If there's a mail header separator in this file, + ;; we remove it. + (when (re-search-forward + (concat "^" mail-header-separator "$") nil t) + (replace-match "" t t))) + t)))) + +(deffoo nndraft-request-restore-buffer (article &optional group server) + "Request a new buffer that is restored to the state of ARTICLE." + (nndraft-possibly-change-group group) + (when (nndraft-request-article article group server (current-buffer)) + (let ((gnus-verbose-backends nil)) + (nndraft-request-expire-articles (list article) group server t)) + t)) + +(deffoo nndraft-request-update-info (group info &optional server) + (nndraft-possibly-change-group group) + (gnus-info-set-read + info + (gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft "")) + (nndraft-articles) t)) + (let (marks) + (when (setq marks (nth 3 info)) + (setcar (nthcdr 3 info) + (if (assq 'unsend marks) + (list (assq 'unsend marks)) + nil)))) + t) + +(deffoo nndraft-request-associate-buffer (group) + "Associate the current buffer with some article in the draft group." + (nndraft-possibly-change-group group) + (let ((gnus-verbose-backends nil) + (buf (current-buffer)) + article file) + (nnheader-temp-write nil + (insert-buffer buf) + (setq article (nndraft-request-accept-article + group (nnoo-current-server 'nndraft) t 'noinsert)) + (setq file (nndraft-article-filename article))) + (setq buffer-file-name file) + (setq buffer-auto-save-file-name (make-auto-save-file-name)) + (clear-visited-file-modtime) + article)) + +(deffoo nndraft-request-expire-articles (articles group &optional server force) + (nndraft-possibly-change-group group) + (let* ((nnmh-allow-delete-final t) + (res (nndraft-execute-nnmh-command + `(nnmh-request-expire-articles + ',articles group ,server ,force))) + article) + ;; Delete all the "state" files of articles that have been expired. + (while articles + (unless (memq (setq article (pop articles)) res) + (let ((auto (nndraft-auto-save-file-name + (nndraft-article-filename article)))) + (when (file-exists-p auto) + (funcall nnmail-delete-file-function auto))))) + res)) + +(deffoo nndraft-request-accept-article (group &optional server last noinsert) + (nndraft-possibly-change-group group) + (let ((gnus-verbose-backends nil)) + (nndraft-execute-nnmh-command + `(nnmh-request-accept-article group ,server ,last noinsert)))) + +(deffoo nndraft-request-create-group (group &optional server args) + (nndraft-possibly-change-group group) + (if (file-exists-p nndraft-current-directory) + (if (file-directory-p nndraft-current-directory) + t + nil) + (condition-case () + (progn + (gnus-make-directory nndraft-current-directory) + t) + (file-error nil)))) + + +;;; Low-Level Interface + +(defun nndraft-possibly-change-group (group) + (when (and group + (not (equal group nndraft-current-group))) + (setq nndraft-current-group group) + (setq nndraft-current-directory + (nnheader-concat nndraft-directory group)))) + +(defun nndraft-execute-nnmh-command (command) + (let* ((dir (directory-file-name + (expand-file-name nndraft-current-directory))) + (group (file-name-nondirectory dir)) + (nnmh-directory (file-name-directory dir)) + (nnmail-keep-last-article nil) + (nnmh-get-new-mail nil)) + (eval command))) + +(defun nndraft-article-filename (article &rest args) + (apply 'concat + (file-name-as-directory nndraft-current-directory) + (int-to-string article) + args)) + +(defun nndraft-auto-save-file-name (file) + (save-excursion + (prog1 + (progn + (set-buffer (get-buffer-create " *draft tmp*")) + (setq buffer-file-name file) + (make-auto-save-file-name)) + (kill-buffer (current-buffer))))) + +(defun nndraft-articles () + "Return the list of messages in the group." + (gnus-make-directory nndraft-current-directory) + (sort + (mapcar 'string-to-int + (directory-files nndraft-current-directory nil "\\`[0-9]+\\'" t)) + '<)) + +(nnoo-import nndraft + (nnmh + nnmh-retrieve-headers + nnmh-request-group + nnmh-close-group + nnmh-request-list + nnmh-request-newsgroups + nnmh-request-move-article + nnmh-request-replace-article)) + +(provide 'nndraft) + +;;; nndraft.el ends here diff --git a/lisp/nneething.el b/lisp/nneething.el new file mode 100644 index 0000000..af38dfa --- /dev/null +++ b/lisp/nneething.el @@ -0,0 +1,352 @@ +;;; nneething.el --- random file access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'nnheader) +(require 'nnmail) +(require 'nnoo) +(require 'gnus-util) + +(nnoo-declare nneething) + +(defvoo nneething-map-file-directory "~/.nneething/" + "Where nneething stores the map files.") + +(defvoo nneething-map-file ".nneething" + "Name of the map files.") + +(defvoo nneething-exclude-files nil + "Regexp saying what files to exclude from the group. +If this variable is nil, no files will be excluded.") + + + +;;; Internal variables. + +(defconst nneething-version "nneething 1.0" + "nneething version.") + +(defvoo nneething-current-directory nil + "Current news group directory.") + +(defvoo nneething-status-string "") + +(defvoo nneething-message-id-number 0) +(defvoo nneething-work-buffer " *nneething work*") + +(defvoo nneething-group nil) +(defvoo nneething-map nil) +(defvoo nneething-read-only nil) +(defvoo nneething-active nil) +(defvoo nneething-directory nil) + + + +;;; Interface functions. + +(nnoo-define-basics nneething) + +(deffoo nneething-retrieve-headers (articles &optional group server fetch-old) + (nneething-possibly-change-directory group) + + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let* ((number (length articles)) + (count 0) + (large (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup))) + article file) + + (if (stringp (car articles)) + 'headers + + (while (setq article (pop articles)) + (setq file (nneething-file-name article)) + + (when (and (file-exists-p file) + (or (file-directory-p file) + (not (zerop (nnheader-file-size file))))) + (insert (format "221 %d Article retrieved.\n" article)) + (nneething-insert-head file) + (insert ".\n")) + + (incf count) + + (and large + (zerop (% count 20)) + (message "nneething: Receiving headers... %d%%" + (/ (* count 100) number)))) + + (when large + (message "nneething: Receiving headers...done")) + + (nnheader-fold-continuation-lines) + 'headers)))) + +(deffoo nneething-request-article (id &optional group server buffer) + (nneething-possibly-change-directory group) + (let ((file (unless (stringp id) + (nneething-file-name id))) + (nntp-server-buffer (or buffer nntp-server-buffer))) + (and (stringp file) ; We did not request by Message-ID. + (file-exists-p file) ; The file exists. + (not (file-directory-p file)) ; It's not a dir. + (save-excursion + (nnmail-find-file file) ; Insert the file in the nntp buf. + (unless (nnheader-article-p) ; Either it's a real article... + (goto-char (point-min)) + (nneething-make-head file (current-buffer)) ; ... or we fake some headers. + (insert "\n")) + t)))) + +(deffoo nneething-request-group (group &optional server dont-check) + (nneething-possibly-change-directory group server) + (unless dont-check + (nneething-create-mapping) + (if (> (car nneething-active) (cdr nneething-active)) + (nnheader-insert "211 0 1 0 %s\n" group) + (nnheader-insert + "211 %d %d %d %s\n" + (- (1+ (cdr nneething-active)) (car nneething-active)) + (car nneething-active) (cdr nneething-active) + group))) + t) + +(deffoo nneething-request-list (&optional server dir) + (nnheader-report 'nneething "LIST is not implemented.")) + +(deffoo nneething-request-newgroups (date &optional server) + (nnheader-report 'nneething "NEWSGROUPS is not implemented.")) + +(deffoo nneething-request-type (group &optional article) + 'unknown) + +(deffoo nneething-close-group (group &optional server) + (setq nneething-current-directory nil) + t) + +(deffoo nneething-open-server (server &optional defs) + (nnheader-init-server-buffer) + (if (nneething-server-opened server) + t + (unless (assq 'nneething-directory defs) + (setq defs (append defs (list (list 'nneething-directory server))))) + (nnoo-change-server 'nneething server defs))) + + +;;; Internal functions. + +(defun nneething-possibly-change-directory (group &optional server) + (when (and server + (not (nneething-server-opened server))) + (nneething-open-server server)) + (when (and group + (not (equal nneething-group group))) + (setq nneething-group group) + (setq nneething-map nil) + (setq nneething-active (cons 1 0)) + (nneething-create-mapping))) + +(defun nneething-map-file () + ;; We make sure that the .nneething directory exists. + (gnus-make-directory nneething-map-file-directory) + ;; We store it in a special directory under the user's home dir. + (concat (file-name-as-directory nneething-map-file-directory) + nneething-group nneething-map-file)) + +(defun nneething-create-mapping () + ;; Read nneething-active and nneething-map. + (when (file-exists-p nneething-directory) + (let ((map-file (nneething-map-file)) + (files (directory-files nneething-directory)) + touched map-files) + (when (file-exists-p map-file) + (ignore-errors + (load map-file nil t t))) + (unless nneething-active + (setq nneething-active (cons 1 0))) + ;; Old nneething had a different map format. + (when (and (cdar nneething-map) + (atom (cdar nneething-map))) + (setq nneething-map + (mapcar (lambda (n) + (list (cdr n) (car n) + (nth 5 (file-attributes + (nneething-file-name (car n)))))) + nneething-map))) + ;; Remove files matching the exclusion regexp. + (when nneething-exclude-files + (let ((f files) + prev) + (while f + (if (string-match nneething-exclude-files (car f)) + (if prev (setcdr prev (cdr f)) + (setq files (cdr files))) + (setq prev f)) + (setq f (cdr f))))) + ;; Remove deleted files from the map. + (let ((map nneething-map) + prev) + (while map + (if (and (member (cadar map) files) + ;; We also remove files that have changed mod times. + (equal (nth 5 (file-attributes + (nneething-file-name (cadar map)))) + (caddar map))) + (progn + (push (cadar map) map-files) + (setq prev map)) + (setq touched t) + (if prev + (setcdr prev (cdr map)) + (setq nneething-map (cdr nneething-map)))) + (setq map (cdr map)))) + ;; Find all new files and enter them into the map. + (while files + (unless (member (car files) map-files) + ;; This file is not in the map, so we enter it. + (setq touched t) + (setcdr nneething-active (1+ (cdr nneething-active))) + (push (list (cdr nneething-active) (car files) + (nth 5 (file-attributes + (nneething-file-name (car files))))) + nneething-map)) + (setq files (cdr files))) + (when (and touched + (not nneething-read-only)) + (nnheader-temp-write map-file + (insert "(setq nneething-map '") + (gnus-prin1 nneething-map) + (insert ")\n(setq nneething-active '") + (gnus-prin1 nneething-active) + (insert ")\n")))))) + +(defun nneething-insert-head (file) + "Insert the head of FILE." + (when (nneething-get-head file) + (insert-buffer-substring nneething-work-buffer) + (goto-char (point-max)))) + +(defun nneething-make-head (file &optional buffer) + "Create a head by looking at the file attributes of FILE." + (let ((atts (file-attributes file))) + (insert + "Subject: " (file-name-nondirectory file) "\n" + "Message-ID: \n" + (if (equal '(0 0) (nth 5 atts)) "" + (concat "Date: " (current-time-string (nth 5 atts)) "\n")) + (or (when buffer + (save-excursion + (set-buffer buffer) + (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) + (concat "From: " (match-string 0) "\n")))) + (nneething-from-line (nth 2 atts) file)) + (if (> (string-to-int (int-to-string (nth 7 atts))) 0) + (concat "Chars: " (int-to-string (nth 7 atts)) "\n") + "") + (if buffer + (save-excursion + (set-buffer buffer) + (concat "Lines: " (int-to-string + (count-lines (point-min) (point-max))) + "\n")) + "") + ))) + +(defun nneething-from-line (uid &optional file) + "Return a From header based of UID." + (let* ((login (condition-case nil + (user-login-name uid) + (error + (cond ((= uid (user-uid)) (user-login-name)) + ((zerop uid) "root") + (t (int-to-string uid)))))) + (name (condition-case nil + (user-full-name uid) + (error + (cond ((= uid (user-uid)) (user-full-name)) + ((zerop uid) "Ms. Root"))))) + (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) + (prog1 + (substring file + (match-beginning 1) + (match-end 1)) + (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file) + (setq login (substring file + (match-beginning 2) + (match-end 2)) + name nil))) + (system-name)))) + (concat "From: " login "@" host + (if name (concat " (" name ")") "") "\n"))) + +(defun nneething-get-head (file) + "Either find the head in FILE or make a head for FILE." + (save-excursion + (set-buffer (get-buffer-create nneething-work-buffer)) + (setq case-fold-search nil) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (cond + ((not (file-exists-p file)) + ;; The file do not exist. + nil) + ((or (file-directory-p file) + (file-symlink-p file)) + ;; It's a dir, so we fudge a head. + (nneething-make-head file) t) + (t + ;; We examine the file. + (nnheader-insert-head file) + (if (nnheader-article-p) + (delete-region + (progn + (goto-char (point-min)) + (or (and (search-forward "\n\n" nil t) + (1- (point))) + (point-max))) + (point-max)) + (goto-char (point-min)) + (nneething-make-head file (current-buffer)) + (delete-region (point) (point-max))) + t)))) + +(defun nneething-file-name (article) + "Return the file name of ARTICLE." + (concat (file-name-as-directory nneething-directory) + (if (numberp article) + (cadr (assq article nneething-map)) + article))) + +(provide 'nneething) + +;;; nneething.el ends here diff --git a/lisp/nnfolder.el b/lisp/nnfolder.el new file mode 100644 index 0000000..d6dad19 --- /dev/null +++ b/lisp/nnfolder.el @@ -0,0 +1,782 @@ +;;; nnfolder.el --- mail folder access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Scott Byer +;; Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'message) +(require 'nnmail) +(require 'nnoo) +(require 'cl) +(require 'gnus-util) + +(nnoo-declare nnfolder) + +(defvoo nnfolder-directory (expand-file-name message-directory) + "The name of the nnfolder directory.") + +(defvoo nnfolder-active-file + (nnheader-concat nnfolder-directory "active") + "The name of the active file.") + +;; I renamed this variable to something more in keeping with the general GNU +;; style. -SLB + +(defvoo nnfolder-ignore-active-file nil + "If non-nil, causes nnfolder to do some extra work in order to determine +the true active ranges of an mbox file. Note that the active file is still +saved, but it's values are not used. This costs some extra time when +scanning an mbox when opening it.") + +(defvoo nnfolder-distrust-mbox nil + "If non-nil, causes nnfolder to not trust the user with respect to +inserting unaccounted for mail in the middle of an mbox file. This can greatly +slow down scans, which now must scan the entire file for unmarked messages. +When nil, scans occur forward from the last marked message, a huge +time saver for large mailboxes.") + +(defvoo nnfolder-newsgroups-file + (concat (file-name-as-directory nnfolder-directory) "newsgroups") + "Mail newsgroups description file.") + +(defvoo nnfolder-get-new-mail t + "If non-nil, nnfolder will check the incoming mail file and split the mail.") + +(defvoo nnfolder-prepare-save-mail-hook nil + "Hook run narrowed to an article before saving.") + +(defvoo nnfolder-save-buffer-hook nil + "Hook run before saving the nnfolder mbox buffer.") + +(defvoo nnfolder-inhibit-expiry nil + "If non-nil, inhibit expiry.") + + + +(defconst nnfolder-version "nnfolder 1.0" + "nnfolder version.") + +(defconst nnfolder-article-marker "X-Gnus-Article-Number: " + "String used to demarcate what the article number for a message is.") + +(defvoo nnfolder-current-group nil) +(defvoo nnfolder-current-buffer nil) +(defvoo nnfolder-status-string "") +(defvoo nnfolder-group-alist nil) +(defvoo nnfolder-buffer-alist nil) +(defvoo nnfolder-scantime-alist nil) +(defvoo nnfolder-active-timestamp nil) + + + +;;; Interface functions + +(nnoo-define-basics nnfolder) + +(deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (article art-string start stop) + (nnfolder-possibly-change-group group server) + (when nnfolder-current-buffer + (set-buffer nnfolder-current-buffer) + (goto-char (point-min)) + (if (stringp (car articles)) + 'headers + (while articles + (setq article (car articles)) + (setq art-string (nnfolder-article-string article)) + (set-buffer nnfolder-current-buffer) + (when (or (search-forward art-string nil t) + ;; Don't search the whole file twice! Also, articles + ;; probably have some locality by number, so searching + ;; backwards will be faster. Especially if we're at the + ;; beginning of the buffer :-). -SLB + (search-backward art-string nil t)) + (nnmail-search-unix-mail-delim-backward) + (setq start (point)) + (search-forward "\n\n" nil t) + (setq stop (1- (point))) + (set-buffer nntp-server-buffer) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring nnfolder-current-buffer start stop) + (goto-char (point-max)) + (insert ".\n")) + (setq articles (cdr articles))) + + (set-buffer nntp-server-buffer) + (nnheader-fold-continuation-lines) + 'headers))))) + +(deffoo nnfolder-open-server (server &optional defs) + (nnoo-change-server 'nnfolder server defs) + (nnmail-activate 'nnfolder t) + (gnus-make-directory nnfolder-directory) + (cond + ((not (file-exists-p nnfolder-directory)) + (nnfolder-close-server) + (nnheader-report 'nnfolder "Couldn't create directory: %s" + nnfolder-directory)) + ((not (file-directory-p (file-truename nnfolder-directory))) + (nnfolder-close-server) + (nnheader-report 'nnfolder "Not a directory: %s" nnfolder-directory)) + (t + (nnmail-activate 'nnfolder) + (nnheader-report 'nnfolder "Opened server %s using directory %s" + server nnfolder-directory) + t))) + +(deffoo nnfolder-request-close () + (let ((alist nnfolder-buffer-alist)) + (while alist + (nnfolder-close-group (caar alist) nil t) + (setq alist (cdr alist)))) + (nnoo-close-server 'nnfolder) + (setq nnfolder-buffer-alist nil + nnfolder-group-alist nil)) + +(deffoo nnfolder-request-article (article &optional group server buffer) + (nnfolder-possibly-change-group group server) + (save-excursion + (set-buffer nnfolder-current-buffer) + (goto-char (point-min)) + (when (search-forward (nnfolder-article-string article) nil t) + (let (start stop) + (nnmail-search-unix-mail-delim-backward) + (setq start (point)) + (forward-line 1) + (unless (and (nnmail-search-unix-mail-delim) + (forward-line -1)) + (goto-char (point-max))) + (setq stop (point)) + (let ((nntp-server-buffer (or buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring nnfolder-current-buffer start stop) + (goto-char (point-min)) + (while (looking-at "From ") + (delete-char 5) + (insert "X-From-Line: ") + (forward-line 1)) + (if (numberp article) + (cons nnfolder-current-group article) + (goto-char (point-min)) + (search-forward (concat "\n" nnfolder-article-marker)) + (cons nnfolder-current-group + (string-to-int + (buffer-substring + (point) (progn (end-of-line) (point))))))))))) + +(deffoo nnfolder-request-group (group &optional server dont-check) + (nnfolder-possibly-change-group group server t) + (save-excursion + (if (not (assoc group nnfolder-group-alist)) + (nnheader-report 'nnfolder "No such group: %s" group) + (if dont-check + (progn + (nnheader-report 'nnfolder "Selected group %s" group) + t) + (let* ((active (assoc group nnfolder-group-alist)) + (group (car active)) + (range (cadr active))) + (cond + ((null active) + (nnheader-report 'nnfolder "No such group: %s" group)) + ((null nnfolder-current-group) + (nnheader-report 'nnfolder "Empty group: %s" group)) + (t + (nnheader-report 'nnfolder "Selected group %s" group) + (nnheader-insert "211 %d %d %d %s\n" + (1+ (- (cdr range) (car range))) + (car range) (cdr range) group)))))))) + +(deffoo nnfolder-request-scan (&optional group server) + (nnfolder-possibly-change-group nil server) + (when nnfolder-get-new-mail + (nnfolder-possibly-change-group group server) + (nnmail-get-new-mail + 'nnfolder + (lambda () + (let ((bufs nnfolder-buffer-alist)) + (save-excursion + (while bufs + (if (not (gnus-buffer-live-p (nth 1 (car bufs)))) + (setq nnfolder-buffer-alist + (delq (car bufs) nnfolder-buffer-alist)) + (set-buffer (nth 1 (car bufs))) + (nnfolder-save-buffer) + (kill-buffer (current-buffer))) + (setq bufs (cdr bufs)))))) + nnfolder-directory + group))) + +;; Don't close the buffer if we're not shutting down the server. This way, +;; we can keep the buffer in the group buffer cache, and not have to grovel +;; over the buffer again unless we add new mail to it or modify it in some +;; way. + +(deffoo nnfolder-close-group (group &optional server force) + ;; Make sure we _had_ the group open. + (when (or (assoc group nnfolder-buffer-alist) + (equal group nnfolder-current-group)) + (let ((inf (assoc group nnfolder-buffer-alist))) + (when inf + (when (and nnfolder-current-group + nnfolder-current-buffer) + (push (list nnfolder-current-group nnfolder-current-buffer) + nnfolder-buffer-alist)) + (setq nnfolder-buffer-alist + (delq inf nnfolder-buffer-alist)) + (setq nnfolder-current-buffer (cadr inf) + nnfolder-current-group (car inf)))) + (when (and nnfolder-current-buffer + (buffer-name nnfolder-current-buffer)) + (save-excursion + (set-buffer nnfolder-current-buffer) + ;; If the buffer was modified, write the file out now. + (nnfolder-save-buffer) + ;; If we're shutting the server down, we need to kill the + ;; buffer and remove it from the open buffer list. Or, of + ;; course, if we're trying to minimize our space impact. + (kill-buffer (current-buffer)) + (setq nnfolder-buffer-alist (delq (assoc group nnfolder-buffer-alist) + nnfolder-buffer-alist))))) + (setq nnfolder-current-group nil + nnfolder-current-buffer nil) + t) + +(deffoo nnfolder-request-create-group (group &optional server args) + (nnfolder-possibly-change-group nil server) + (nnmail-activate 'nnfolder) + (when group + (unless (assoc group nnfolder-group-alist) + (push (list group (cons 1 0)) nnfolder-group-alist) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + (nnfolder-read-folder group))) + t) + +(deffoo nnfolder-request-list (&optional server) + (nnfolder-possibly-change-group nil server) + (save-excursion + (let ((nnmail-file-coding-system nnmail-active-file-coding-system) + (pathname-coding-system 'binary)) + (nnmail-find-file nnfolder-active-file) + (setq nnfolder-group-alist (nnmail-get-active))) + t)) + +(deffoo nnfolder-request-newgroups (date &optional server) + (nnfolder-possibly-change-group nil server) + (nnfolder-request-list server)) + +(deffoo nnfolder-request-list-newsgroups (&optional server) + (nnfolder-possibly-change-group nil server) + (save-excursion + (nnmail-find-file nnfolder-newsgroups-file))) + +(deffoo nnfolder-request-expire-articles + (articles newsgroup &optional server force) + (nnfolder-possibly-change-group newsgroup server) + (let* ((is-old t) + rest) + (nnmail-activate 'nnfolder) + + (save-excursion + (set-buffer nnfolder-current-buffer) + (while (and articles is-old) + (goto-char (point-min)) + (when (search-forward (nnfolder-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) + force nnfolder-inhibit-expiry)) + (progn + (nnheader-message 5 "Deleting article %d..." + (car articles) newsgroup) + (nnfolder-delete-mail)) + (push (car articles) rest))) + (setq articles (cdr articles))) + (unless nnfolder-inhibit-expiry + (nnheader-message 5 "Deleting articles...done")) + (nnfolder-save-buffer) + (nnfolder-adjust-min-active newsgroup) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + (nconc rest articles)))) + +(deffoo nnfolder-request-move-article + (article group server accept-form &optional last) + (let ((buf (get-buffer-create " *nnfolder move*")) + result) + (and + (nnfolder-request-article article group server) + (save-excursion + (set-buffer buf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring nntp-server-buffer) + (goto-char (point-min)) + (while (re-search-forward + (concat "^" nnfolder-article-marker) + (save-excursion (search-forward "\n\n" nil t) (point)) t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + (setq result (eval accept-form)) + (kill-buffer buf) + result) + (save-excursion + (nnfolder-possibly-change-group group server) + (set-buffer nnfolder-current-buffer) + (goto-char (point-min)) + (when (search-forward (nnfolder-article-string article) nil t) + (nnfolder-delete-mail)) + (when last + (nnfolder-save-buffer) + (nnfolder-adjust-min-active group) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))) + result)) + +(deffoo nnfolder-request-accept-article (group &optional server last) + (nnfolder-possibly-change-group group server) + (nnmail-check-syntax) + (let ((buf (current-buffer)) + result art-group) + (goto-char (point-min)) + (when (looking-at "X-From-Line: ") + (replace-match "From ")) + (and + (nnfolder-request-list) + (save-excursion + (set-buffer buf) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (forward-line -1) + (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) + (delete-region (point) (progn (forward-line 1) (point)))) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (setq result (if (stringp group) + (list (cons group (nnfolder-active-number group))) + (setq art-group + (nnmail-article-group 'nnfolder-active-number)))) + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result + (car (nnfolder-save-mail result))))) + (when last + (save-excursion + (nnfolder-possibly-change-folder (or (caar art-group) group)) + (nnfolder-save-buffer) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-close))))) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + (unless result + (nnheader-report 'nnfolder "Couldn't store article")) + result)) + +(deffoo nnfolder-request-replace-article (article group buffer) + (nnfolder-possibly-change-group group) + (save-excursion + (set-buffer nnfolder-current-buffer) + (goto-char (point-min)) + (if (not (search-forward (nnfolder-article-string article) nil t)) + nil + (nnfolder-delete-mail t t) + (insert-buffer-substring buffer) + (nnfolder-save-buffer) + t))) + +(deffoo nnfolder-request-delete-group (group &optional force server) + (nnfolder-close-group group server t) + ;; Delete all articles in GROUP. + (if (not force) + () ; Don't delete the articles. + ;; Delete the file that holds the group. + (ignore-errors + (delete-file (nnfolder-group-pathname group)))) + ;; Remove the group from all structures. + (setq nnfolder-group-alist + (delq (assoc group nnfolder-group-alist) nnfolder-group-alist) + nnfolder-current-group nil + nnfolder-current-buffer nil) + ;; Save the active file. + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + t) + +(deffoo nnfolder-request-rename-group (group new-name &optional server) + (nnfolder-possibly-change-group group server) + (save-excursion + (set-buffer nnfolder-current-buffer) + (and (file-writable-p buffer-file-name) + (ignore-errors + (rename-file + buffer-file-name + (nnfolder-group-pathname new-name)) + t) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnfolder-group-alist))) + (and entry (setcar entry new-name)) + (setq nnfolder-current-buffer nil + nnfolder-current-group nil) + ;; Save the new group alist. + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + ;; We kill the buffer instead of renaming it and stuff. + (kill-buffer (current-buffer)) + t)))) + +(defun nnfolder-request-regenerate (server) + (nnfolder-possibly-change-group nil server) + (nnfolder-generate-active-file) + t) + + +;;; Internal functions. + +(defun nnfolder-adjust-min-active (group) + ;; Find the lowest active article in this group. + (let* ((active (cadr (assoc group nnfolder-group-alist))) + (marker (concat "\n" nnfolder-article-marker)) + (number "[0-9]+") + (activemin (cdr active))) + (save-excursion + (set-buffer nnfolder-current-buffer) + (goto-char (point-min)) + (while (and (search-forward marker nil t) + (re-search-forward number nil t)) + (setq activemin (min activemin + (string-to-number (buffer-substring + (match-beginning 0) + (match-end 0)))))) + (setcar active activemin)))) + +(defun nnfolder-article-string (article) + (if (numberp article) + (concat "\n" nnfolder-article-marker (int-to-string article) " ") + (concat "\nMessage-ID: " article))) + +(defun nnfolder-delete-mail (&optional force leave-delim) + "Delete the message that point is in." + (save-excursion + (delete-region + (save-excursion + (nnmail-search-unix-mail-delim-backward) + (if leave-delim (progn (forward-line 1) (point)) + (point))) + (progn + (forward-line 1) + (if (nnmail-search-unix-mail-delim) + (if (and (not (bobp)) leave-delim) + (progn (forward-line -2) (point)) + (point)) + (point-max)))))) + +(defun nnfolder-possibly-change-group (group &optional server dont-check) + ;; Change servers. + (when (and server + (not (nnfolder-server-opened server))) + (nnfolder-open-server server)) + (unless (gnus-buffer-live-p nnfolder-current-buffer) + (setq nnfolder-current-buffer nil + nnfolder-current-group nil)) + ;; Change group. + (when (and group + (not (equal group nnfolder-current-group))) + (let ((pathname-coding-system 'binary)) + (nnmail-activate 'nnfolder) + (when (and (not (assoc group nnfolder-group-alist)) + (not (file-exists-p + (nnfolder-group-pathname group)))) + ;; The group doesn't exist, so we create a new entry for it. + (push (list group (cons 1 0)) nnfolder-group-alist) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file)) + + (if dont-check + (setq nnfolder-current-group group + nnfolder-current-buffer nil) + (let (inf file) + ;; If we have to change groups, see if we don't already have the + ;; folder in memory. If we do, verify the modtime and destroy + ;; the folder if needed so we can rescan it. + (setq nnfolder-current-buffer + (nth 1 (assoc group nnfolder-buffer-alist))) + + ;; If the buffer is not live, make sure it isn't in the alist. If it + ;; is live, verify that nobody else has touched the file since last + ;; time. + (when (and nnfolder-current-buffer + (not (gnus-buffer-live-p nnfolder-current-buffer))) + (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist) + nnfolder-current-buffer nil)) + + (setq nnfolder-current-group group) + + (when (or (not nnfolder-current-buffer) + (not (verify-visited-file-modtime nnfolder-current-buffer))) + (save-excursion + (setq file (nnfolder-group-pathname group)) + ;; See whether we need to create the new file. + (unless (file-exists-p file) + (gnus-make-directory (file-name-directory file)) + (nnmail-write-region 1 1 file t 'nomesg)) + (when (setq nnfolder-current-buffer (nnfolder-read-folder group)) + (set-buffer nnfolder-current-buffer) + (push (list group nnfolder-current-buffer) + nnfolder-buffer-alist))))))))) + +(defun nnfolder-save-mail (group-art-list) + "Called narrowed to an article." + (let* (save-list group-art) + (goto-char (point-min)) + ;; The From line may have been quoted by movemail. + (when (looking-at (concat ">" message-unix-mail-delimiter)) + (delete-char 1)) + ;; This might come from somewhere else. + (unless (looking-at message-unix-mail-delimiter) + (insert "From nobody " (current-time-string) "\n") + (goto-char (point-min))) + ;; Quote all "From " lines in the article. + (forward-line 1) + (let (case-fold-search) + (while (re-search-forward "^From " nil t) + (beginning-of-line) + (insert "> "))) + (setq save-list group-art-list) + (nnmail-insert-lines) + (nnmail-insert-xref group-art-list) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnfolder-prepare-save-mail-hook) + + ;; Insert the mail into each of the destination groups. + (while (setq group-art (pop group-art-list)) + ;; Kill any previous newsgroup markers. + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (forward-line -1) + (while (search-backward (concat "\n" nnfolder-article-marker) nil t) + (delete-region (1+ (point)) (progn (forward-line 2) (point)))) + + ;; Insert the new newsgroup marker. + (nnfolder-insert-newsgroup-line group-art) + + (save-excursion + (let ((beg (point-min)) + (end (point-max)) + (obuf (current-buffer))) + (nnfolder-possibly-change-folder (car group-art)) + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (unless (eolp) + (insert "\n")) + (unless (bobp) + (insert "\n")) + (insert-buffer-substring obuf beg end))))) + + ;; Did we save it anywhere? + save-list)) + +(defun nnfolder-insert-newsgroup-line (group-art) + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (insert (format (concat nnfolder-article-marker "%d %s\n") + (cdr group-art) (current-time-string)))))) + +(defun nnfolder-active-number (group) + ;; Find the next article number in GROUP. + (let ((active (cadr (assoc group nnfolder-group-alist)))) + (if active + (setcdr active (1+ (cdr active))) + ;; This group is new, so we create a new entry for it. + ;; This might be a bit naughty... creating groups on the drop of + ;; a hat, but I don't know... + (push (list group (setq active (cons 1 1))) + nnfolder-group-alist)) + (cdr active))) + +(defun nnfolder-possibly-change-folder (group) + (let ((inf (assoc group nnfolder-buffer-alist))) + (if (and inf + (gnus-buffer-live-p (cadr inf))) + (set-buffer (cadr inf)) + (when inf + (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist))) + (when nnfolder-group-alist + (nnmail-save-active nnfolder-group-alist nnfolder-active-file)) + (push (list group (nnfolder-read-folder group)) + nnfolder-buffer-alist)))) + +;; This method has a problem if you've accidentally let the active list get +;; out of sync with the files. This could happen, say, if you've +;; accidentally gotten new mail with something other than Gnus (but why +;; would _that_ ever happen? :-). In that case, we will be in the middle of +;; processing the file, ready to add new X-Gnus article number markers, and +;; we'll run across a message with no ID yet - the active list _may_not_ be +;; ready for us yet. + +;; To handle this, I'm modifying this routine to maintain the maximum ID seen +;; so far, and when we hit a message with no ID, we will _manually_ scan the +;; rest of the message looking for any more, possibly higher IDs. We'll +;; assume the maximum that we find is the highest active. Note that this +;; shouldn't cost us much extra time at all, but will be a lot less +;; vulnerable to glitches between the mbox and the active file. + +(defun nnfolder-read-folder (group) + (let* ((file (nnfolder-group-pathname group)) + (buffer (set-buffer (nnheader-find-file-noselect file)))) + (if (equal (cadr (assoc group nnfolder-scantime-alist)) + (nth 5 (file-attributes file))) + ;; This looks up-to-date, so we don't do any scanning. + buffer + ;; Parse the damn thing. + (save-excursion + (nnmail-activate 'nnfolder) + ;; Read in the file. + (let ((delim (concat "^" message-unix-mail-delimiter)) + (marker (concat "\n" nnfolder-article-marker)) + (number "[0-9]+") + (active (or (cadr (assoc group nnfolder-group-alist)) + (cons 1 0))) + (scantime (assoc group nnfolder-scantime-alist)) + (minid (lsh -1 -1)) + maxid start end newscantime + buffer-read-only) + (buffer-disable-undo (current-buffer)) + (setq maxid (cdr active)) + (goto-char (point-min)) + + ;; Anytime the active number is 1 or 0, it is suspect. In that + ;; case, search the file manually to find the active number. Or, + ;; of course, if we're being paranoid. (This would also be the + ;; place to build other lists from the header markers, such as + ;; expunge lists, etc., if we ever desired to abandon the active + ;; file entirely for mboxes.) + (when (or nnfolder-ignore-active-file + (< maxid 2)) + (while (and (search-forward marker nil t) + (re-search-forward number nil t)) + (let ((newnum (string-to-number (match-string 0)))) + (setq maxid (max maxid newnum)) + (setq minid (min minid newnum)))) + (setcar active (max 1 (min minid maxid))) + (setcdr active (max maxid (cdr active))) + (goto-char (point-min))) + + ;; As long as we trust that the user will only insert unmarked mail + ;; at the end, go to the end and search backwards for the last + ;; marker. Find the start of that message, and begin to search for + ;; unmarked messages from there. + (when (not (or nnfolder-distrust-mbox + (< maxid 2))) + (goto-char (point-max)) + (unless (re-search-backward marker nil t) + (goto-char (point-min))) + (when (nnmail-search-unix-mail-delim) + (goto-char (point-min)))) + + ;; Keep track of the active number on our own, and insert it back + ;; into the active list when we're done. Also, prime the pump to + ;; cut down on the number of searches we do. + (unless (nnmail-search-unix-mail-delim) + (goto-char (point-max))) + (setq end (point-marker)) + (while (not (= end (point-max))) + (setq start (marker-position end)) + (goto-char end) + ;; There may be more than one "From " line, so we skip past + ;; them. + (while (looking-at delim) + (forward-line 1)) + (set-marker end (if (nnmail-search-unix-mail-delim) + (point) + (point-max))) + (goto-char start) + (when (not (search-forward marker end t)) + (narrow-to-region start end) + (nnmail-insert-lines) + (nnfolder-insert-newsgroup-line + (cons nil (nnfolder-active-number nnfolder-current-group))) + (widen))) + + (set-marker end nil) + ;; Make absolutely sure that the active list reflects reality! + (nnmail-save-active nnfolder-group-alist nnfolder-active-file) + ;; Set the scantime for this group. + (setq newscantime (visited-file-modtime)) + (if scantime + (setcdr scantime (list newscantime)) + (push (list nnfolder-current-group newscantime) + nnfolder-scantime-alist)) + (current-buffer)))))) + +;;;###autoload +(defun nnfolder-generate-active-file () + "Look for mbox folders in the nnfolder directory and make them into groups." + (interactive) + (nnmail-activate 'nnfolder) + (let ((files (directory-files nnfolder-directory)) + file) + (while (setq file (pop files)) + (when (and (not (backup-file-name-p file)) + (message-mail-file-mbox-p + (nnheader-concat nnfolder-directory file))) + (let ((oldgroup (assoc file nnfolder-group-alist))) + (if oldgroup + (nnheader-message 5 "Refreshing group %s..." file) + (nnheader-message 5 "Adding group %s..." file)) + (if oldgroup + (setq nnfolder-group-alist + (delq oldgroup (copy-sequence nnfolder-group-alist)))) + (push (list file (cons 1 0)) nnfolder-group-alist) + (nnfolder-possibly-change-folder file) + (nnfolder-possibly-change-group file) + (nnfolder-close-group file)))) + (message ""))) + +(defun nnfolder-group-pathname (group) + "Make pathname for GROUP." + (setq group (gnus-encode-coding-string group nnmail-pathname-coding-system)) + (let ((dir (file-name-as-directory (expand-file-name nnfolder-directory)))) + ;; If this file exists, we use it directly. + (if (or nnmail-use-long-file-names + (file-exists-p (concat dir group))) + (concat dir group) + ;; If not, we translate dots into slashes. + (concat dir (nnheader-replace-chars-in-string group ?. ?/))))) + +(defun nnfolder-save-buffer () + "Save the buffer." + (when (buffer-modified-p) + (run-hooks 'nnfolder-save-buffer-hook) + (gnus-make-directory (file-name-directory (buffer-file-name))) + (save-buffer))) + +(provide 'nnfolder) + +;;; nnfolder.el ends here diff --git a/lisp/nngateway.el b/lisp/nngateway.el new file mode 100644 index 0000000..28fd245 --- /dev/null +++ b/lisp/nngateway.el @@ -0,0 +1,82 @@ +;;; nngateway.el --- posting news via mail gateways +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnoo) +(require 'message) + +(nnoo-declare nngateway) + +(defvoo nngateway-address nil + "Address of the mail-to-news gateway.") + +(defvoo nngateway-header-transformation 'nngateway-simple-header-transformation + "Function to be called to rewrite the news headers into mail headers. +It is called narrowed to the headers to be transformed with one +parameter -- the gateway address.") + +;;; Interface functions + +(nnoo-define-basics nngateway) + +(deffoo nngateway-open-server (server &optional defs) + (if (nngateway-server-opened server) + t + (unless (assq 'nngateway-address defs) + (setq defs (append defs (list (list 'nngateway-address server))))) + (nnoo-change-server 'nngateway server defs))) + +(deffoo nngateway-request-post (&optional server) + (when (or (nngateway-server-opened server) + (nngateway-open-server server)) + ;; Rewrite the header. + (let ((buf (current-buffer))) + (nnheader-temp-write nil + (insert-buffer-substring buf) + (message-narrow-to-head) + (funcall nngateway-header-transformation nngateway-address) + (goto-char (point-max)) + (insert mail-header-separator "\n") + (widen) + (let (message-required-mail-headers) + (funcall message-send-mail-function)))))) + +;;; Internal functions + +(defun nngateway-simple-header-transformation (gateway) + "Transform the headers to use GATEWAY." + (let ((newsgroups (mail-fetch-field "newsgroups"))) + (message-remove-header "to") + (message-remove-header "cc") + (goto-char (point-min)) + (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-) + "@" gateway "\n"))) + +(nnoo-define-skeleton nngateway) + +(provide 'nngateway) + +;;; nngateway.el ends here diff --git a/lisp/nnheader.el b/lisp/nnheader.el new file mode 100644 index 0000000..97c842b --- /dev/null +++ b/lisp/nnheader.el @@ -0,0 +1,840 @@ +;;; nnheader.el --- header access macros for Gnus and its backends +;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; These macros may look very much like the ones in GNUS 4.1. They +;; are, in a way, but you should note that the indices they use have +;; been changed from the internal GNUS format to the NOV format. The +;; makes it possible to read headers from XOVER much faster. +;; +;; The format of a header is now: +;; [number subject from date id references chars lines xref] +;; +;; (That last entry is defined as "misc" in the NOV format, but Gnus +;; uses it for xrefs.) + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'mail-utils) + +(defvar nnheader-max-head-length 4096 + "*Max length of the head of articles.") + +(defvar nnheader-head-chop-length 2048 + "*Length of each read operation when trying to fetch HEAD headers.") + +(defvar nnheader-file-name-translation-alist nil + "*Alist that says how to translate characters in file names. +For instance, if \":\" is illegal as a file character in file names +on your system, you could say something like: + +\(setq nnheader-file-name-translation-alist '((?: . ?_)))") + +(eval-and-compile + (autoload 'nnmail-message-id "nnmail") + (autoload 'mail-position-on-field "sendmail") + (autoload 'message-remove-header "message") + (autoload 'cancel-function-timers "timers") + (autoload 'gnus-point-at-eol "gnus-util")) + +;;; Header access macros. + +(defmacro mail-header-number (header) + "Return article number in HEADER." + `(aref ,header 0)) + +(defmacro mail-header-set-number (header number) + "Set article number of HEADER to NUMBER." + `(aset ,header 0 ,number)) + +(defmacro mail-header-subject (header) + "Return subject string in HEADER." + `(aref ,header 1)) + +(defmacro mail-header-set-subject (header subject) + "Set article subject of HEADER to SUBJECT." + `(aset ,header 1 ,subject)) + +(defmacro mail-header-from (header) + "Return author string in HEADER." + `(aref ,header 2)) + +(defmacro mail-header-set-from (header from) + "Set article author of HEADER to FROM." + `(aset ,header 2 ,from)) + +(defmacro mail-header-date (header) + "Return date in HEADER." + `(aref ,header 3)) + +(defmacro mail-header-set-date (header date) + "Set article date of HEADER to DATE." + `(aset ,header 3 ,date)) + +(defalias 'mail-header-message-id 'mail-header-id) +(defmacro mail-header-id (header) + "Return Id in HEADER." + `(aref ,header 4)) + +(defalias 'mail-header-set-message-id 'mail-header-set-id) +(defmacro mail-header-set-id (header id) + "Set article Id of HEADER to ID." + `(aset ,header 4 ,id)) + +(defmacro mail-header-references (header) + "Return references in HEADER." + `(aref ,header 5)) + +(defmacro mail-header-set-references (header ref) + "Set article references of HEADER to REF." + `(aset ,header 5 ,ref)) + +(defmacro mail-header-chars (header) + "Return number of chars of article in HEADER." + `(aref ,header 6)) + +(defmacro mail-header-set-chars (header chars) + "Set number of chars in article of HEADER to CHARS." + `(aset ,header 6 ,chars)) + +(defmacro mail-header-lines (header) + "Return lines in HEADER." + `(aref ,header 7)) + +(defmacro mail-header-set-lines (header lines) + "Set article lines of HEADER to LINES." + `(aset ,header 7 ,lines)) + +(defmacro mail-header-xref (header) + "Return xref string in HEADER." + `(aref ,header 8)) + +(defmacro mail-header-set-xref (header xref) + "Set article xref of HEADER to xref." + `(aset ,header 8 ,xref)) + +(defun make-mail-header (&optional init) + "Create a new mail header structure initialized with INIT." + (make-vector 9 init)) + +(defun make-full-mail-header (&optional number subject from date id + references chars lines xref) + "Create a new mail header structure initialized with the parameters given." + (vector number subject from date id references chars lines xref)) + +;; fake message-ids: generation and detection + +(defvar nnheader-fake-message-id 1) + +(defsubst nnheader-generate-fake-message-id () + (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id)))) + +(defsubst nnheader-fake-message-id-p (id) + (save-match-data ; regular message-id's are <.*> + (string-match "\\`fake\\+none\\+[0-9]+\\'" id))) + +;; Parsing headers and NOV lines. + +(defsubst nnheader-header-value () + (buffer-substring (match-end 0) (gnus-point-at-eol))) + +(defun nnheader-parse-head (&optional naked) + (let ((case-fold-search t) + (cur (current-buffer)) + (buffer-read-only nil) + in-reply-to lines p) + (goto-char (point-min)) + (when naked + (insert "\n")) + ;; Search to the beginning of the next header. Error messages + ;; do not begin with 2 or 3. + (prog1 + (when (or naked (re-search-forward "^[23][0-9]+ " nil t)) + ;; This implementation of this function, with nine + ;; search-forwards instead of the one re-search-forward and + ;; a case (which basically was the old function) is actually + ;; about twice as fast, even though it looks messier. You + ;; can't have everything, I guess. Speed and elegance + ;; don't always go hand in hand. + (vector + ;; Number. + (if naked + (progn + (setq p (point-min)) + 0) + (prog1 + (read cur) + (end-of-line) + (setq p (point)) + (narrow-to-region (point) + (or (and (search-forward "\n.\n" nil t) + (- (point) 2)) + (point))))) + ;; Subject. + (progn + (goto-char p) + (if (search-forward "\nsubject: " nil t) + (nnheader-header-value) "(none)")) + ;; From. + (progn + (goto-char p) + (if (search-forward "\nfrom: " nil t) + (nnheader-header-value) "(nobody)")) + ;; Date. + (progn + (goto-char p) + (if (search-forward "\ndate: " nil t) + (nnheader-header-value) "")) + ;; Message-ID. + (progn + (goto-char p) + (if (search-forward "\nmessage-id:" nil t) + (buffer-substring + (1- (or (search-forward "<" nil t) (point))) + (or (search-forward ">" nil t) (point))) + ;; If there was no message-id, we just fake one to make + ;; subsequent routines simpler. + (nnheader-generate-fake-message-id))) + ;; References. + (progn + (goto-char p) + (if (search-forward "\nreferences: " nil t) + (nnheader-header-value) + ;; Get the references from the in-reply-to header if there + ;; were no references and the in-reply-to header looks + ;; promising. + (if (and (search-forward "\nin-reply-to: " nil t) + (setq in-reply-to (nnheader-header-value)) + (string-match "<[^>]+>" in-reply-to)) + (substring in-reply-to (match-beginning 0) + (match-end 0)) + ""))) + ;; Chars. + 0 + ;; Lines. + (progn + (goto-char p) + (if (search-forward "\nlines: " nil t) + (if (numberp (setq lines (read cur))) + lines 0) + 0)) + ;; Xref. + (progn + (goto-char p) + (and (search-forward "\nxref: " nil t) + (nnheader-header-value))))) + (when naked + (goto-char (point-min)) + (delete-char 1))))) + +(defmacro nnheader-nov-skip-field () + '(search-forward "\t" eol 'move)) + +(defmacro nnheader-nov-field () + '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol))) + +(defmacro nnheader-nov-read-integer () + '(prog1 + (if (= (following-char) ?\t) + 0 + (let ((num (ignore-errors (read (current-buffer))))) + (if (numberp num) num 0))) + (or (eobp) (forward-char 1)))) + +;; (defvar nnheader-none-counter 0) + +(defun nnheader-parse-nov () + (let ((eol (gnus-point-at-eol))) + (vector + (nnheader-nov-read-integer) ; number + (nnheader-nov-field) ; subject + (nnheader-nov-field) ; from + (nnheader-nov-field) ; date + (or (nnheader-nov-field) + (nnheader-generate-fake-message-id)) ; id + (nnheader-nov-field) ; refs + (nnheader-nov-read-integer) ; chars + (nnheader-nov-read-integer) ; lines + (if (= (following-char) ?\n) + nil + (nnheader-nov-field)) ; misc + ))) + +(defun nnheader-insert-nov (header) + (princ (mail-header-number header) (current-buffer)) + (insert + "\t" + (or (mail-header-subject header) "(none)") "\t" + (or (mail-header-from header) "(nobody)") "\t" + (or (mail-header-date header) "") "\t" + (or (mail-header-id header) + (nnmail-message-id)) + "\t" + (or (mail-header-references header) "") "\t") + (princ (or (mail-header-chars header) 0) (current-buffer)) + (insert "\t") + (princ (or (mail-header-lines header) 0) (current-buffer)) + (insert "\t") + (when (mail-header-xref header) + (insert "Xref: " (mail-header-xref header) "\t")) + (insert "\n")) + +(defun nnheader-insert-article-line (article) + (goto-char (point-min)) + (insert "220 ") + (princ article (current-buffer)) + (insert " Article retrieved.\n") + (search-forward "\n\n" nil 'move) + (delete-region (point) (point-max)) + (forward-char -1) + (insert ".")) + +(defun nnheader-nov-delete-outside-range (beg end) + "Delete all NOV lines that lie outside the BEG to END range." + ;; First we find the first wanted line. + (nnheader-find-nov-line beg) + (delete-region (point-min) (point)) + ;; Then we find the last wanted line. + (when (nnheader-find-nov-line end) + (forward-line 1)) + (delete-region (point) (point-max))) + +(defun nnheader-find-nov-line (article) + "Put point at the NOV line that start with ARTICLE. +If ARTICLE doesn't exist, put point where that line +would have been. The function will return non-nil if +the line could be found." + ;; This function basically does a binary search. + (let ((max (point-max)) + (min (goto-char (point-min))) + (cur (current-buffer)) + (prev (point-min)) + num found) + (while (not found) + (goto-char (/ (+ max min) 2)) + (beginning-of-line) + (if (or (= (point) prev) + (eobp)) + (setq found t) + (setq prev (point)) + (while (and (not (numberp (setq num (read cur)))) + (not (eobp))) + (gnus-delete-line)) + (cond ((> num article) + (setq max (point))) + ((< num article) + (setq min (point))) + (t + (setq found 'yes))))) + ;; We may be at the first line. + (when (and (not num) + (not (eobp))) + (setq num (read cur))) + ;; Now we may have found the article we're looking for, or we + ;; may be somewhere near it. + (when (and (not (eq found 'yes)) + (not (eq num article))) + (setq found (point)) + (while (and (< (point) max) + (or (not (numberp num)) + (< num article))) + (forward-line 1) + (setq found (point)) + (or (eobp) + (= (setq num (read cur)) article))) + (unless (eq num article) + (goto-char found))) + (beginning-of-line) + (eq num article))) + +;; Various cruft the backends and Gnus need to communicate. + +(defvar nntp-server-buffer nil) +(defvar gnus-verbose-backends 7 + "*A number that says how talkative the Gnus backends should be.") +(defvar gnus-nov-is-evil nil + "If non-nil, Gnus backends will never output headers in the NOV format.") +(defvar news-reply-yank-from nil) +(defvar news-reply-yank-message-id nil) + +(defvar nnheader-callback-function nil) + +(defun nnheader-init-server-buffer () + "Initialize the Gnus-backend communication buffer." + (save-excursion + (unless (gnus-buffer-live-p nntp-server-buffer) + (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) + (set-buffer nntp-server-buffer) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (kill-all-local-variables) + (setq case-fold-search t) ;Should ignore case. + t)) + +;;; Various functions the backends use. + +(defun nnheader-file-error (file) + "Return a string that says what is wrong with FILE." + (format + (cond + ((not (file-exists-p file)) + "%s does not exist") + ((file-directory-p file) + "%s is a directory") + ((not (file-readable-p file)) + "%s is not readable")) + file)) + +(defun nnheader-insert-head (file) + "Insert the head of the article." + (when (file-exists-p file) + (if (eq nnheader-max-head-length t) + ;; Just read the entire file. + (nnheader-insert-file-contents file) + ;; Read 1K blocks until we find a separator. + (let ((beg 0) + format-alist) + (while (and (eq nnheader-head-chop-length + (nth 1 (nnheader-insert-file-contents + file nil beg + (incf beg nnheader-head-chop-length)))) + (prog1 (not (search-forward "\n\n" nil t)) + (goto-char (point-max))) + (or (null nnheader-max-head-length) + (< beg nnheader-max-head-length)))))) + t)) + +(defun nnheader-article-p () + "Say whether the current buffer looks like an article." + (goto-char (point-min)) + (if (not (search-forward "\n\n" nil t)) + nil + (narrow-to-region (point-min) (1- (point))) + (goto-char (point-min)) + (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n") + (goto-char (match-end 0))) + (prog1 + (eobp) + (widen)))) + +(defun nnheader-insert-references (references message-id) + "Insert a References header based on REFERENCES and MESSAGE-ID." + (if (and (not references) (not message-id)) + () ; This is illegal, but not all articles have Message-IDs. + (mail-position-on-field "References") + (let ((begin (save-excursion (beginning-of-line) (point))) + (fill-column 78) + (fill-prefix "\t")) + (when references + (insert references)) + (when (and references message-id) + (insert " ")) + (when message-id + (insert message-id)) + ;; Fold long References lines to conform to RFC1036 (sort of). + ;; The region must end with a newline to fill the region + ;; without inserting extra newline. + (fill-region-as-paragraph begin (1+ (point)))))) + +(defun nnheader-replace-header (header new-value) + "Remove HEADER and insert the NEW-VALUE." + (save-excursion + (save-restriction + (nnheader-narrow-to-headers) + (prog1 + (message-remove-header header) + (goto-char (point-max)) + (insert header ": " new-value "\n"))))) + +(defun nnheader-narrow-to-headers () + "Narrow to the head of an article." + (widen) + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (goto-char (point-min))) + +(defun nnheader-set-temp-buffer (name &optional noerase) + "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." + (set-buffer (get-buffer-create name)) + (buffer-disable-undo (current-buffer)) + (unless noerase + (erase-buffer)) + (current-buffer)) + +(defmacro nnheader-temp-write (file &rest forms) + "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. +Return the value of FORMS. +If FILE is nil, just evaluate FORMS and don't save anything. +If FILE is t, return the buffer contents as a string." + (let ((temp-file (make-symbol "temp-file")) + (temp-buffer (make-symbol "temp-buffer")) + (temp-results (make-symbol "temp-results"))) + `(save-excursion + (let* ((,temp-file ,file) + (default-major-mode 'fundamental-mode) + (,temp-buffer + (set-buffer + (get-buffer-create + (generate-new-buffer-name " *nnheader temp*")))) + ,temp-results) + (unwind-protect + (progn + (setq ,temp-results (progn ,@forms)) + (cond + ;; Don't save anything. + ((null ,temp-file) + ,temp-results) + ;; Return the buffer contents. + ((eq ,temp-file t) + (set-buffer ,temp-buffer) + (buffer-string)) + ;; Save a file. + (t + (set-buffer ,temp-buffer) + ;; Make sure the directory where this file is + ;; to be saved exists. + (when (not (file-directory-p + (file-name-directory ,temp-file))) + (make-directory (file-name-directory ,temp-file) t)) + ;; Save the file. + (write-region (point-min) (point-max) + ,temp-file nil 'nomesg) + ,temp-results))) + ;; Kill the buffer. + (when (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer))))))) + +(put 'nnheader-temp-write 'lisp-indent-function 1) +(put 'nnheader-temp-write 'edebug-form-spec '(form body)) + +(defvar jka-compr-compression-info-list) +(defvar nnheader-numerical-files + (if (boundp 'jka-compr-compression-info-list) + (concat "\\([0-9]+\\)\\(" + (mapconcat (lambda (i) (aref i 0)) + jka-compr-compression-info-list "\\|") + "\\)?") + "[0-9]+$") + "Regexp that match numerical files.") + +(defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files) + "Regexp that matches numerical file names.") + +(defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files) + "Regexp that matches numerical full file paths.") + +(defsubst nnheader-file-to-number (file) + "Take a file name and return the article number." + (if (not (boundp 'jka-compr-compression-info-list)) + (string-to-int file) + (string-match nnheader-numerical-short-files file) + (string-to-int (match-string 0 file)))) + +(defun nnheader-directory-files-safe (&rest args) + ;; It has been reported numerous times that `directory-files' + ;; fails with an alarming frequency on NFS mounted file systems. + ;; This function executes that function twice and returns + ;; the longest result. + (let ((first (apply 'directory-files args)) + (second (apply 'directory-files args))) + (if (> (length first) (length second)) + first + second))) + +(defun nnheader-directory-articles (dir) + "Return a list of all article files in a directory." + (mapcar 'nnheader-file-to-number + (nnheader-directory-files-safe + dir nil nnheader-numerical-short-files t))) + +(defun nnheader-article-to-file-alist (dir) + "Return an alist of article/file pairs in DIR." + (mapcar (lambda (file) (cons (nnheader-file-to-number file) file)) + (nnheader-directory-files-safe + dir nil nnheader-numerical-short-files t))) + +(defun nnheader-fold-continuation-lines () + "Fold continuation lines in the current buffer." + (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " ")) + +(defun nnheader-translate-file-chars (file) + (if (null nnheader-file-name-translation-alist) + ;; No translation is necessary. + file + ;; We translate -- but only the file name. We leave the directory + ;; alone. + (let* ((i 0) + trans leaf path len) + (if (string-match "/[^/]+\\'" file) + ;; This is needed on NT's and stuff. + (setq leaf (substring file (1+ (match-beginning 0))) + path (substring file 0 (1+ (match-beginning 0)))) + ;; Fall back on this. + (setq leaf (file-name-nondirectory file) + path (file-name-directory file))) + (setq len (length leaf)) + (while (< i len) + (when (setq trans (cdr (assq (aref leaf i) + nnheader-file-name-translation-alist))) + (aset leaf i trans)) + (incf i)) + (concat path leaf)))) + +(defun nnheader-report (backend &rest args) + "Report an error from the BACKEND. +The first string in ARGS can be a format string." + (set (intern (format "%s-status-string" backend)) + (if (< (length args) 2) + (car args) + (apply 'format args))) + nil) + +(defun nnheader-get-report (backend) + "Get the most recent report from BACKEND." + (condition-case () + (message "%s" (symbol-value (intern (format "%s-status-string" + backend)))) + (error (message "")))) + +(defun nnheader-insert (format &rest args) + "Clear the communication buffer and insert FORMAT and ARGS into the buffer. +If FORMAT isn't a format string, it and all ARGS will be inserted +without formatting." + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (if (string-match "%" format) + (insert (apply 'format format args)) + (apply 'insert format args)) + t)) + +(defun nnheader-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string)) + +(defun nnheader-file-to-group (file &optional top) + "Return a group name based on FILE and TOP." + (nnheader-replace-chars-in-string + (if (not top) + file + (condition-case () + (substring (expand-file-name file) + (length + (expand-file-name + (file-name-as-directory top)))) + (error ""))) + ?/ ?.)) + +(defun nnheader-message (level &rest args) + "Message if the Gnus backends are talkative." + (if (or (not (numberp gnus-verbose-backends)) + (<= level gnus-verbose-backends)) + (apply 'message args) + (apply 'format args))) + +(defun nnheader-be-verbose (level) + "Return whether the backends should be verbose on LEVEL." + (or (not (numberp gnus-verbose-backends)) + (<= level gnus-verbose-backends))) + +(defvar nnheader-pathname-coding-system 'iso-8859-1 + "*Coding system for pathname.") + +(defun nnheader-group-pathname (group dir &optional file) + "Make pathname for GROUP." + (concat + (let ((dir (file-name-as-directory (expand-file-name dir)))) + ;; If this directory exists, we use it directly. + (if (file-directory-p (concat dir group)) + (concat dir group "/") + ;; If not, we translate dots into slashes. + (concat dir + (gnus-encode-coding-string + (nnheader-replace-chars-in-string group ?. ?/) + nnheader-pathname-coding-system) + "/"))) + (cond ((null file) "") + ((numberp file) (int-to-string file)) + (t file)))) + +(defun nnheader-functionp (form) + "Return non-nil if FORM is funcallable." + (or (and (symbolp form) (fboundp form)) + (and (listp form) (eq (car form) 'lambda)))) + +(defun nnheader-concat (dir &rest files) + "Concat DIR as directory to FILE." + (apply 'concat (file-name-as-directory dir) files)) + +(defun nnheader-ms-strip-cr () + "Strip ^M from the end of all lines." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\r$" nil t) + (delete-backward-char 1)))) + +(defun nnheader-file-size (file) + "Return the file size of FILE or 0." + (or (nth 7 (file-attributes file)) 0)) + +(defun nnheader-find-etc-directory (package &optional file) + "Go through the path and find the \".../etc/PACKAGE\" directory. +If FILE, find the \".../etc/PACKAGE\" file instead." + (let ((path load-path) + dir result) + ;; We try to find the dir by looking at the load path, + ;; stripping away the last component and adding "etc/". + (while path + (if (and (car path) + (file-exists-p + (setq dir (concat + (file-name-directory + (directory-file-name (car path))) + "etc/" package + (if file "" "/")))) + (or file (file-directory-p dir))) + (setq result dir + path nil) + (setq path (cdr path)))) + result)) + +(defvar ange-ftp-path-format) +(defvar efs-path-regexp) +(defun nnheader-re-read-dir (path) + "Re-read directory PATH if PATH is on a remote system." + (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp)) + (when (string-match efs-path-regexp path) + (efs-re-read-dir path)) + (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format)) + (when (string-match (car ange-ftp-path-format) path) + (ange-ftp-re-read-dir path))))) + +;; 1997/5/4 by MORIOKA Tomohiko +(defvar nnheader-file-coding-system nil + "Coding system used in file backends of Gnus.") + +(defun nnheader-insert-file-contents (filename &optional visit beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let ((format-alist nil) + (auto-mode-alist (nnheader-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (after-insert-file-functions nil) + ;; 1997/5/4 by MORIOKA Tomohiko + (coding-system-for-read nnheader-file-coding-system)) + (insert-file-contents filename visit beg end replace))) + +(defun nnheader-find-file-noselect (&rest args) + (let ((format-alist nil) + (auto-mode-alist (nnheader-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (enable-local-variables nil) + (after-insert-file-functions nil) + ;; 1997/5/16 by MORIOKA Tomohiko + (coding-system-for-read nnheader-file-coding-system)) + (apply 'find-file-noselect args))) + +(defun nnheader-auto-mode-alist () + "Return an `auto-mode-alist' with only the .gz (etc) thingies." + (let ((alist auto-mode-alist) + out) + (while alist + (when (listp (cdar alist)) + (push (car alist) out)) + (pop alist)) + (nreverse out))) + +(defun nnheader-directory-regular-files (dir) + "Return a list of all regular files in DIR." + (let ((files (directory-files dir t)) + out) + (while files + (when (file-regular-p (car files)) + (push (car files) out)) + (pop files)) + (nreverse out))) + +(defmacro nnheader-skeleton-replace (from &optional to regexp) + `(let ((new (generate-new-buffer " *nnheader replace*")) + (cur (current-buffer)) + (start (point-min))) + (set-buffer new) + (buffer-disable-undo (current-buffer)) + (set-buffer cur) + (goto-char (point-min)) + (while (,(if regexp 're-search-forward 'search-forward) + ,from nil t) + (insert-buffer-substring + cur start (prog1 (match-beginning 0) (set-buffer new))) + (goto-char (point-max)) + ,(when to `(insert ,to)) + (set-buffer cur) + (setq start (point))) + (insert-buffer-substring + cur start (prog1 (point-max) (set-buffer new))) + (copy-to-buffer cur (point-min) (point-max)) + (kill-buffer (current-buffer)) + (set-buffer cur))) + +(defun nnheader-replace-string (from to) + "Do a fast replacement of FROM to TO from point to point-max." + (nnheader-skeleton-replace from to)) + +(defun nnheader-replace-regexp (from to) + "Do a fast regexp replacement of FROM to TO from point to point-max." + (nnheader-skeleton-replace from to t)) + +(defun nnheader-strip-cr () + "Strip all \r's from the current buffer." + (nnheader-skeleton-replace "\r")) + +(fset 'nnheader-run-at-time 'run-at-time) +(fset 'nnheader-cancel-timer 'cancel-timer) +(fset 'nnheader-cancel-function-timers 'cancel-function-timers) + +(when (string-match "XEmacs\\|Lucid" emacs-version) + (require 'nnheaderxm)) + +(run-hooks 'nnheader-load-hook) + +(provide 'nnheader) + +;;; nnheader.el ends here diff --git a/lisp/nnheaderxm.el b/lisp/nnheaderxm.el new file mode 100644 index 0000000..0a5fc99 --- /dev/null +++ b/lisp/nnheaderxm.el @@ -0,0 +1,41 @@ +;;; nnheaderxm.el --- making Gnus backends work under XEmacs +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(defun nnheader-xmas-run-at-time (time repeat function &rest args) + (start-itimer + "nnheader-run-at-time" + `(lambda () + (,function ,@args)) + time repeat)) + +(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time) +(fset 'nnheader-cancel-timer 'delete-itimer) +(fset 'nnheader-cancel-function-timers 'ignore) + +(provide 'nnheaderxm) + +;;; nnheaderxm.el ends here. diff --git a/lisp/nnkiboze.el b/lisp/nnkiboze.el new file mode 100644 index 0000000..2d8de2e --- /dev/null +++ b/lisp/nnkiboze.el @@ -0,0 +1,356 @@ +;;; nnkiboze.el --- select virtual news access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The other access methods (nntp, nnspool, etc) are general news +;; access methods. This module relies on Gnus and can't be used +;; separately. + +;;; Code: + +(require 'nntp) +(require 'nnheader) +(require 'gnus) +(require 'gnus-score) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnkiboze) +(defvoo nnkiboze-directory (nnheader-concat gnus-directory "kiboze/") + "nnkiboze will put its files in this directory.") + +(defvoo nnkiboze-level 9 + "The maximum level to be searched for articles.") + +(defvoo nnkiboze-remove-read-articles t + "If non-nil, nnkiboze will remove read articles from the kiboze group.") + +(defvoo nnkiboze-ephemeral nil + "If non-nil, don't store any data anywhere.") + +(defvoo nnkiboze-scores nil + "Score rules for generating the nnkiboze group.") + +(defvoo nnkiboze-regexp nil + "Regexp for matching component groups.") + + + +(defconst nnkiboze-version "nnkiboze 1.0") + +(defvoo nnkiboze-current-group nil) +(defvoo nnkiboze-status-string "") + +(defvoo nnkiboze-headers nil) + + + +;;; Interface functions. + +(nnoo-define-basics nnkiboze) + +(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old) + (nnkiboze-possibly-change-group group) + (unless gnus-nov-is-evil + (if (stringp (car articles)) + 'headers + (let ((nov (nnkiboze-nov-file-name))) + (when (file-exists-p nov) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (nnheader-insert-file-contents nov) + (nnheader-nov-delete-outside-range + (car articles) (car (last articles))) + 'nov)))))) + +(deffoo nnkiboze-request-article (article &optional newsgroup server buffer) + (nnkiboze-possibly-change-group newsgroup) + (if (not (numberp article)) + ;; This is a real kludge. It might not work at times, but it + ;; does no harm I think. The only alternative is to offer no + ;; article fetching by message-id at all. + (nntp-request-article article newsgroup gnus-nntp-server buffer) + (let* ((header (gnus-summary-article-header article)) + (xref (mail-header-xref header))) + (unless xref + (error "nnkiboze: No xref")) + (unless (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref) + (error "nnkiboze: Malformed xref")) + (gnus-request-article (string-to-int (match-string 2 xref)) + (match-string 1 xref) + buffer)))) + +(deffoo nnkiboze-request-scan (&optional group server) + (nnkiboze-generate-group (concat "nnkiboze:" group))) + +(deffoo nnkiboze-request-group (group &optional server dont-check) + "Make GROUP the current newsgroup." + (nnkiboze-possibly-change-group group) + (if dont-check + t + (let ((nov-file (nnkiboze-nov-file-name)) + beg end total) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (if (not (file-exists-p nov-file)) + (nnheader-report 'nnkiboze "Can't select group %s" group) + (nnheader-insert-file-contents nov-file) + (if (zerop (buffer-size)) + (nnheader-insert "211 0 0 0 %s\n" group) + (goto-char (point-min)) + (when (looking-at "[0-9]+") + (setq beg (read (current-buffer)))) + (goto-char (point-max)) + (when (re-search-backward "^[0-9]" nil t) + (setq end (read (current-buffer)))) + (setq total (count-lines (point-min) (point-max))) + (nnheader-insert "211 %d %d %d %s\n" total beg end group))))))) + +(deffoo nnkiboze-close-group (group &optional server) + (nnkiboze-possibly-change-group group) + ;; Remove NOV lines of articles that are marked as read. + (when (and (file-exists-p (nnkiboze-nov-file-name)) + nnkiboze-remove-read-articles) + (nnheader-temp-write (nnkiboze-nov-file-name) + (let ((cur (current-buffer))) + (nnheader-insert-file-contents (nnkiboze-nov-file-name)) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (gnus-article-read-p (read cur))) + (forward-line 1) + (gnus-delete-line)))))) + (setq nnkiboze-current-group nil)) + +(deffoo nnkiboze-open-server (server &optional defs) + (unless (assq 'nnkiboze-regexp defs) + (push `(nnkiboze-regexp ,server) + defs)) + (nnoo-change-server 'nnkiboze server defs)) + +(deffoo nnkiboze-request-delete-group (group &optional force server) + (nnkiboze-possibly-change-group group) + (when force + (let ((files (list (nnkiboze-nov-file-name) + (concat nnkiboze-directory + (nnheader-translate-file-chars + (concat group ".newsrc"))) + (nnkiboze-score-file group)))) + (while files + (and (file-exists-p (car files)) + (file-writable-p (car files)) + (delete-file (car files))) + (setq files (cdr files))))) + (setq nnkiboze-current-group nil)) + +(nnoo-define-skeleton nnkiboze) + + +;;; Internal functions. + +(defun nnkiboze-possibly-change-group (group) + (setq nnkiboze-current-group group)) + +(defun nnkiboze-prefixed-name (group) + (gnus-group-prefixed-name group '(nnkiboze ""))) + +;;;###autoload +(defun nnkiboze-generate-groups () + "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups +Finds out what articles are to be part of the nnkiboze groups." + (interactive) + (let ((nnmail-spool-file nil) + (gnus-use-dribble-file nil) + (gnus-read-active-file t) + (gnus-expert-user t)) + (gnus)) + (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist)) + (newsrc (cdr gnus-newsrc-alist)) + gnus-newsrc-hashtb info) + (gnus-make-hashtable-from-newsrc-alist) + ;; We have copied all the newsrc alist info over to local copies + ;; so that we can mess all we want with these lists. + (while (setq info (pop newsrc)) + (when (string-match "nnkiboze" (gnus-info-group info)) + ;; For each kiboze group, we call this function to generate + ;; it. + (nnkiboze-generate-group (gnus-info-group info)))))) + +(defun nnkiboze-score-file (group) + (list (expand-file-name + (concat (file-name-as-directory gnus-kill-files-directory) + (nnheader-translate-file-chars + (concat (nnkiboze-prefixed-name nnkiboze-current-group) + "." gnus-score-file-suffix)))))) + +(defun nnkiboze-generate-group (group) + (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) + (newsrc-file (concat nnkiboze-directory + (nnheader-translate-file-chars + (concat group ".newsrc")))) + (nov-file (concat nnkiboze-directory + (nnheader-translate-file-chars + (concat group ".nov")))) + method nnkiboze-newsrc gname newsrc active + ginfo lowest glevel orig-info nov-buffer + ;; Bind various things to nil to make group entry faster. + (gnus-expert-user t) + (gnus-large-newsgroup nil) + (gnus-score-find-score-files-function 'nnkiboze-score-file) + (gnus-verbose (min gnus-verbose 3)) + gnus-select-group-hook gnus-summary-prepare-hook + gnus-thread-sort-functions gnus-show-threads + gnus-visual gnus-suppress-duplicates) + (unless info + (error "No such group: %s" group)) + ;; Load the kiboze newsrc file for this group. + (when (file-exists-p newsrc-file) + (load newsrc-file)) + (nnheader-temp-write nov-file + (when (file-exists-p nov-file) + (insert-file-contents nov-file)) + (setq nov-buffer (current-buffer)) + ;; Go through the active hashtb and add new all groups that match the + ;; kiboze regexp. + (mapatoms + (lambda (group) + (and (string-match nnkiboze-regexp + (setq gname (symbol-name group))) ; Match + (not (assoc gname nnkiboze-newsrc)) ; It isn't registered + (numberp (car (symbol-value group))) ; It is active + (or (> nnkiboze-level 7) + (and (setq glevel (nth 1 (nth 2 (gnus-gethash + gname gnus-newsrc-hashtb)))) + (>= nnkiboze-level glevel))) + (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes + (push (cons gname (1- (car (symbol-value group)))) + nnkiboze-newsrc))) + gnus-active-hashtb) + ;; `newsrc' is set to the list of groups that possibly are + ;; component groups to this kiboze group. This list has elements + ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest + ;; number that has been kibozed in GROUP in this kiboze group. + (setq newsrc nnkiboze-newsrc) + (while newsrc + (if (not (setq active (gnus-gethash + (caar newsrc) gnus-active-hashtb))) + ;; This group isn't active after all, so we remove it from + ;; the list of component groups. + (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) + (setq lowest (cdar newsrc)) + ;; Ok, we have a valid component group, so we jump to it. + (switch-to-buffer gnus-group-buffer) + (gnus-group-jump-to-group (caar newsrc)) + (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) + (setq ginfo (gnus-get-info (gnus-group-group-name)) + orig-info (gnus-copy-sequence ginfo)) + (unwind-protect + (progn + ;; We set all list of article marks to nil. Since we operate + ;; on copies of the real lists, we can destroy anything we + ;; want here. + (when (nth 3 ginfo) + (setcar (nthcdr 3 ginfo) nil)) + ;; We set the list of read articles to be what we expect for + ;; this kiboze group -- either nil or `(1 . LOWEST)'. + (when ginfo + (setcar (nthcdr 2 ginfo) + (and (not (= lowest 1)) (cons 1 lowest)))) + (when (and (or (not ginfo) + (> (length (gnus-list-of-unread-articles + (car ginfo))) + 0)) + (progn + (ignore-errors + (gnus-group-select-group nil)) + (eq major-mode 'gnus-summary-mode))) + ;; We are now in the group where we want to be. + (setq method (gnus-find-method-for-group + gnus-newsgroup-name)) + (when (eq method gnus-select-method) + (setq method nil)) + ;; We go through the list of scored articles. + (while gnus-newsgroup-scored + (when (> (caar gnus-newsgroup-scored) lowest) + ;; If it has a good score, then we enter this article + ;; into the kiboze group. + (nnkiboze-enter-nov + nov-buffer + (gnus-summary-article-header + (caar gnus-newsgroup-scored)) + gnus-newsgroup-name)) + (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) + ;; That's it. We exit this group. + (gnus-summary-exit-no-update))) + ;; Restore the proper info. + (when ginfo + (setcdr ginfo (cdr orig-info))))) + (setcdr (car newsrc) (car active)) + (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) + (setq newsrc (cdr newsrc)))) + ;; We save the kiboze newsrc for this group. + (nnheader-temp-write newsrc-file + (insert "(setq nnkiboze-newsrc '") + (gnus-prin1 nnkiboze-newsrc) + (insert ")\n")) + t)) + +(defun nnkiboze-enter-nov (buffer header group) + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (let ((xref (mail-header-xref header)) + (prefix (gnus-group-real-prefix group)) + (oheader (copy-sequence header)) + (first t) + article) + (if (zerop (forward-line -1)) + (progn + (setq article (1+ (read (current-buffer)))) + (forward-line 1)) + (setq article 1)) + (mail-header-set-number oheader article) + (nnheader-insert-nov oheader) + (search-backward "\t" nil t 2) + (if (re-search-forward " [^ ]+:[0-9]+" nil t) + (goto-char (match-beginning 0)) + (forward-char 1)) + ;; The first Xref has to be the group this article + ;; really came for - this is the article nnkiboze + ;; will request when it is asked for the article. + (insert group ":" + (int-to-string (mail-header-number header)) " ") + (while (re-search-forward " [^ ]+:[0-9]+" nil t) + (goto-char (1+ (match-beginning 0))) + (insert prefix))))) + +(defun nnkiboze-nov-file-name () + (concat (file-name-as-directory nnkiboze-directory) + (nnheader-translate-file-chars + (concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov")))) + +(provide 'nnkiboze) + +;;; nnkiboze.el ends here diff --git a/lisp/nnmail.el b/lisp/nnmail.el new file mode 100644 index 0000000..200d060 --- /dev/null +++ b/lisp/nnmail.el @@ -0,0 +1,1756 @@ +;;; nnmail.el --- mail support functions for the Gnus mail backends +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'nnheader) +(require 'timezone) +(require 'message) +(require 'custom) + +(eval-and-compile + (autoload 'gnus-error "gnus-util")) + +(defgroup nnmail nil + "Reading mail with Gnus." + :group 'gnus) + +(defgroup nnmail-retrieve nil + "Retrieving new mail." + :group 'nnmail) + +(defgroup nnmail-prepare nil + "Preparing (or mangling) new mail after retrival." + :group 'nnmail) + +(defgroup nnmail-duplicate nil + "Handling of duplicate mail messages." + :group 'nnmail) + +(defgroup nnmail-split nil + "Organizing the incomming mail in folders." + :group 'nnmail) + +(defgroup nnmail-files nil + "Mail files." + :group 'gnus-files + :group 'nnmail) + +(defgroup nnmail-expire nil + "Expiring old mail." + :group 'nnmail) + +(defgroup nnmail-procmail nil + "Interfacing with procmail and other mail agents." + :group 'nnmail) + +(defgroup nnmail-various nil + "Various mail options." + :group 'nnmail) + +(defcustom nnmail-split-methods + '(("mail.misc" "")) + "Incoming mail will be split according to this variable. + +If you'd like, for instance, one mail group for mail from the +\"4ad-l\" mailing list, one group for junk mail and one for everything +else, you could do something like this: + + (setq nnmail-split-methods + '((\"mail.4ad\" \"From:.*4ad\") + (\"mail.junk\" \"From:.*Lars\\\\|Subject:.*buy\") + (\"mail.misc\" \"\"))) + +As you can see, this variable is a list of lists, where the first +element in each \"rule\" is the name of the group (which, by the way, +does not have to be called anything beginning with \"mail\", +\"yonka.zow\" is a fine, fine name), and the second is a regexp that +nnmail will try to match on the header to find a fit. + +The second element can also be a function. In that case, it will be +called narrowed to the headers with the first element of the rule as +the argument. It should return a non-nil value if it thinks that the +mail belongs in that group. + +The last element should always have \"\" as the regexp. + +This variable can also have a function as its value." + :group 'nnmail-split + :type '(choice (repeat :tag "Alist" (group (string :tag "Name") regexp)) + (function-item nnmail-split-fancy) + (function :tag "Other"))) + +;; Suggested by Erik Selberg . +(defcustom nnmail-crosspost t + "If non-nil, do crossposting if several split methods match the mail. +If nil, the first match found will be used." + :group 'nnmail-split + :type 'boolean) + +;; Added by gord@enci.ucalgary.ca (Gordon Matzigkeit). +(defcustom nnmail-keep-last-article nil + "If non-nil, nnmail will never delete/move a group's last article. +It can be marked expirable, so it will be deleted when it is no longer last. + +You may need to set this variable if other programs are putting +new mail into folder numbers that Gnus has marked as expired." + :group 'nnmail-procmail + :group 'nnmail-various + :type 'boolean) + +(defcustom nnmail-use-long-file-names nil + "If non-nil the mail backends will use long file and directory names. +If nil, groups like \"mail.misc\" will end up in directories like +\"mail/misc/\"." + :group 'nnmail-files + :type 'boolean) + +(defcustom nnmail-default-file-modes 384 + "Set the mode bits of all new mail files to this integer." + :group 'nnmail-files + :type 'integer) + +(defcustom nnmail-expiry-wait 7 + "*Expirable articles that are older than this will be expired. +This variable can either be a number (which will be interpreted as a +number of days) -- this doesn't have to be an integer. This variable +can also be `immediate' and `never'." + :group 'nnmail-expire + :type '(choice (const immediate) + (integer :tag "days") + (const never))) + +(defcustom nnmail-expiry-wait-function nil + "Variable that holds function to specify how old articles should be before they are expired. + The function will be called with the name of the group that the +expiry is to be performed in, and it should return an integer that +says how many days an article can be stored before it is considered +\"old\". It can also return the values `never' and `immediate'. + +Eg.: + +\(setq nnmail-expiry-wait-function + (lambda (newsgroup) + (cond ((string-match \"private\" newsgroup) 31) + ((string-match \"junk\" newsgroup) 1) + ((string-match \"important\" newsgroup) 'never) + (t 7))))" + :group 'nnmail-expire + :type '(choice (const :tag "nnmail-expiry-wait" nil) + (function :format "%v" nnmail-))) + +(defcustom nnmail-cache-accepted-message-ids nil + "If non-nil, put Message-IDs of Gcc'd articles into the duplicate cache." + :group 'nnmail + :type 'boolean) + +(defcustom nnmail-spool-file + (or (getenv "MAIL") + (concat "/usr/spool/mail/" (user-login-name))) + "Where the mail backends will look for incoming mail. +This variable is \"/usr/spool/mail/$user\" by default. +If this variable is nil, no mail backends will read incoming mail. +If this variable is a list, all files mentioned in this list will be +used as incoming mailboxes. +If this variable is a directory (i. e., it's name ends with a \"/\"), +treat all files in that directory as incoming spool files." + :group 'nnmail-files + :type 'file) + +(defcustom nnmail-crash-box "~/.gnus-crash-box" + "File where Gnus will store mail while processing it." + :group 'nnmail-files + :type 'file) + +(defcustom nnmail-use-procmail nil + "*If non-nil, the mail backends will look in `nnmail-procmail-directory' for spool files. +The file(s) in `nnmail-spool-file' will also be read." + :group 'nnmail-procmail + :type 'boolean) + +(defcustom nnmail-procmail-directory "~/incoming/" + "*When using procmail (and the like), incoming mail is put in this directory. +The Gnus mail backends will read the mail from this directory." + :group 'nnmail-procmail + :type 'directory) + +(defcustom nnmail-procmail-suffix "\\.spool" + "*Suffix of files created by procmail (and the like). +This variable might be a suffix-regexp to match the suffixes of +several files - eg. \".spool[0-9]*\"." + :group 'nnmail-procmail + :type 'regexp) + +(defcustom nnmail-resplit-incoming nil + "*If non-nil, re-split incoming procmail sorted mail." + :group 'nnmail-procmail + :type 'boolean) + +(defcustom nnmail-delete-file-function 'delete-file + "Function called to delete files in some mail backends." + :group 'nnmail-files + :type 'function) + +(defcustom nnmail-crosspost-link-function + (if (string-match "windows-nt\\|emx" (format "%s" system-type)) + 'copy-file + 'add-name-to-file) + "Function called to create a copy of a file. +This is `add-name-to-file' by default, which means that crossposts +will use hard links. If your file system doesn't allow hard +links, you could set this variable to `copy-file' instead." + :group 'nnmail-files + :type '(radio (function-item add-name-to-file) + (function-item copy-file) + (function :tag "Other"))) + +(defcustom nnmail-movemail-program "movemail" + "*A command to be executed to move mail from the inbox. +The default is \"movemail\". + +This can also be a function. In that case, the function will be +called with two parameters -- the name of the INBOX file, and the file +to be moved to." + :group 'nnmail-files + :group 'nnmail-retrieve + :type 'string) + +(defcustom nnmail-pop-password-required nil + "*Non-nil if a password is required when reading mail using POP." + :group 'nnmail-retrieve + :type 'boolean) + +(defcustom nnmail-read-incoming-hook + (if (eq system-type 'windows-nt) + '(nnheader-ms-strip-cr) + nil) + "Hook that will be run after the incoming mail has been transferred. +The incoming mail is moved from `nnmail-spool-file' (which normally is +something like \"/usr/spool/mail/$user\") to the user's home +directory. This hook is called after the incoming mail box has been +emptied, and can be used to call any mail box programs you have +running (\"xwatch\", etc.) + +Eg. + +\(add-hook 'nnmail-read-incoming-hook + (lambda () + (start-process \"mailsend\" nil + \"/local/bin/mailsend\" \"read\" \"mbox\"))) + +If you have xwatch running, this will alert it that mail has been +read. + +If you use `display-time', you could use something like this: + +\(add-hook 'nnmail-read-incoming-hook + (lambda () + ;; Update the displayed time, since that will clear out + ;; the flag that says you have mail. + (when (eq (process-status \"display-time\") 'run) + (display-time-filter display-time-process \"\"))))" + :group 'nnmail-prepare + :type 'hook) + +;; Suggested by Erik Selberg . +(defcustom nnmail-prepare-incoming-hook nil + "Hook called before treating incoming mail. +The hook is run in a buffer with all the new, incoming mail." + :group 'nnmail-prepare + :type 'hook) + +(defcustom nnmail-prepare-incoming-header-hook nil + "Hook called narrowed to the headers of each message. +This can be used to remove excessive spaces (and stuff like +that) from the headers before splitting and saving the messages." + :group 'nnmail-prepare + :type 'hook) + +(defcustom nnmail-prepare-incoming-message-hook nil + "Hook called narrowed to each message." + :group 'nnmail-prepare + :type 'hook) + +(defcustom nnmail-list-identifiers nil + "Regexp that matches list identifiers to be removed. +This can also be a list of regexps." + :group 'nnmail-prepare + :type '(choice (const :tag "none" nil) + regexp + (repeat regexp))) + +(defcustom nnmail-pre-get-new-mail-hook nil + "Hook called just before starting to handle new incoming mail." + :group 'nnmail-retrieve + :type 'hook) + +(defcustom nnmail-post-get-new-mail-hook nil + "Hook called just after finishing handling new incoming mail." + :group 'nnmail-retrieve + :type 'hook) + +(defcustom nnmail-split-hook nil + "Hook called before deciding where to split an article. +The functions in this hook are free to modify the buffer +contents in any way they choose -- the buffer contents are +discarded after running the split process." + :group 'nnmail-split + :type 'hook) + +;; Suggested by Mejia Pablo J . +(defcustom nnmail-tmp-directory nil + "*If non-nil, use this directory for temporary storage. +Used when reading incoming mail." + :group 'nnmail-files + :group 'nnmail-retrieve + :type '(choice (const :tag "default" nil) + (directory :format "%v"))) + +(defcustom nnmail-large-newsgroup 50 + "*The number of the articles which indicates a large newsgroup. +If the number of the articles is greater than the value, verbose +messages will be shown to indicate the current status." + :group 'nnmail-various + :type 'integer) + +(defcustom nnmail-split-fancy "mail.misc" + "Incoming mail can be split according to this fancy variable. +To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. + +The format is this variable is SPLIT, where SPLIT can be one of +the following: + +GROUP: Mail will be stored in GROUP (a string). + +\(FIELD VALUE SPLIT): If the message field FIELD (a regexp) contains + VALUE (a regexp), store the messages as specified by SPLIT. + +\(| SPLIT...): Process each SPLIT expression until one of them matches. + A SPLIT expression is said to match if it will cause the mail + message to be stored in one or more groups. + +\(& SPLIT...): Process each SPLIT expression. + +\(: FUNCTION optional args): Call FUNCTION with the optional args, in + the buffer containing the message headers. The return value FUNCTION + should be a split, which is then recursively processed. + +FIELD must match a complete field name. VALUE must match a complete +word according to the `nnmail-split-fancy-syntax-table' syntax table. +You can use \".*\" in the regexps to match partial field names or words. + +FIELD and VALUE can also be lisp symbols, in that case they are expanded +as specified in `nnmail-split-abbrev-alist'. + +GROUP can contain \\& and \\N which will substitute from matching +\\(\\) patterns in the previous VALUE. + +Example: + +\(setq nnmail-split-methods 'nnmail-split-fancy + nnmail-split-fancy + ;; Messages from the mailer daemon are not crossposted to any of + ;; the ordinary groups. Warnings are put in a separate group + ;; from real errors. + '(| (\"from\" mail (| (\"subject\" \"warn.*\" \"mail.warning\") + \"mail.misc\")) + ;; Non-error messages are crossposted to all relevant + ;; groups, but we don't crosspost between the group for the + ;; (ding) list and the group for other (ding) related mail. + (& (| (any \"ding@ifi\\\\.uio\\\\.no\" \"ding.list\") + (\"subject\" \"ding\" \"ding.misc\")) + ;; Other mailing lists... + (any \"procmail@informatik\\\\.rwth-aachen\\\\.de\" \"procmail.list\") + (any \"SmartList@informatik\\\\.rwth-aachen\\\\.de\" \"SmartList.list\") + ;; People... + (any \"larsi@ifi\\\\.uio\\\\.no\" \"people.Lars Magne Ingebrigtsen\")) + ;; Unmatched mail goes to the catch all group. + \"misc.misc\"))" + :group 'nnmail-split + ;; Sigh! + :type 'sexp) + +(defcustom nnmail-split-abbrev-alist + '((any . "from\\|to\\|cc\\|sender\\|apparently-to\\|resent-from\\|resent-to\\|resent-cc") + (mail . "mailer-daemon\\|postmaster\\|uucp") + (to . "to\\|cc\\|apparently-to\\|resent-to\\|resent-cc") + (from . "from\\|sender\\|resent-from") + (nato . "to\\|cc\\|resent-to\\|resent-cc") + (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) + "Alist of abbreviations allowed in `nnmail-split-fancy'." + :group 'nnmail-split + :type '(repeat (cons :format "%v" symbol regexp))) + +(defcustom nnmail-delete-incoming t + "*If non-nil, the mail backends will delete incoming files after +splitting." + :group 'nnmail-retrieve + :type 'boolean) + +(defcustom nnmail-message-id-cache-length 1000 + "*The approximate number of Message-IDs nnmail will keep in its cache. +If this variable is nil, no checking on duplicate messages will be +performed." + :group 'nnmail-duplicate + :type '(choice (const :tag "disable" nil) + (integer :format "%v"))) + +(defcustom nnmail-message-id-cache-file "~/.nnmail-cache" + "*The file name of the nnmail Message-ID cache." + :group 'nnmail-duplicate + :group 'nnmail-files + :type 'file) + +(defcustom nnmail-treat-duplicates 'warn + "*If non-nil, nnmail keep a cache of Message-IDs to discover mail duplicates. +Three values are legal: nil, which means that nnmail is not to keep a +Message-ID cache; `warn', which means that nnmail should insert extra +headers to warn the user about the duplication (this is the default); +and `delete', which means that nnmail will delete duplicated mails. + +This variable can also be a function. It will be called from a buffer +narrowed to the article in question with the Message-ID as a +parameter. It should return nil, `warn' or `delete'." + :group 'nnmail-duplicate + :type '(choice (const :tag "off" nil) + (const warn) + (const delete))) + +;;; Internal variables. + +(defvar nnmail-split-history nil + "List of group/article elements that say where the previous split put messages.") + +(defvar nnmail-pop-password nil + "*Password to use when reading mail from a POP server, if required.") + +(defvar nnmail-split-fancy-syntax-table nil + "Syntax table used by `nnmail-split-fancy'.") +(unless (syntax-table-p nnmail-split-fancy-syntax-table) + (setq nnmail-split-fancy-syntax-table + (copy-syntax-table (standard-syntax-table))) + ;; support the %-hack + (modify-syntax-entry ?\% "." nnmail-split-fancy-syntax-table)) + +(defvar nnmail-prepare-save-mail-hook nil + "Hook called before saving mail.") + +(defvar nnmail-moved-inboxes nil + "List of inboxes that have been moved.") + +(defvar nnmail-internal-password nil) + + + +(defconst nnmail-version "nnmail 1.0" + "nnmail version.") + + + +(defun nnmail-request-post (&optional server) + (mail-send-and-exit nil)) + +;; 1997/5/4 by MORIOKA Tomohiko +(defvar nnmail-file-coding-system nil + "Coding system used in nnmail.") + +(defun nnmail-find-file (file) + "Insert FILE in server buffer safely." + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((format-alist nil) + (after-insert-file-functions nil)) + (condition-case () + ;; 1997/5/4 by MORIOKA Tomohiko + (let ((coding-system-for-read nnmail-file-coding-system) + ;; 1997/8/12 by MORIOKA Tomohiko + ;; for XEmacs/mule. + (pathname-coding-system 'binary)) + (insert-file-contents file) + t) + (file-error nil)))) + +;; 1997/8/10 by MORIOKA Tomohiko +(defvar nnmail-pathname-coding-system + 'iso-8859-1 + "*Coding system for pathname.") + +(defun nnmail-group-pathname (group dir &optional file) + "Make pathname for GROUP." + (concat + (let ((dir (file-name-as-directory (expand-file-name dir)))) + ;; If this directory exists, we use it directly. + (if (or nnmail-use-long-file-names + (file-directory-p (concat dir group))) + (concat dir group "/") + ;; If not, we translate dots into slashes. + (concat dir + (gnus-encode-coding-string + (nnheader-replace-chars-in-string group ?. ?/) + nnmail-pathname-coding-system) + "/"))) + (or file ""))) + +(defun nnmail-date-to-time (date) + "Convert DATE into time." + (condition-case () + (let* ((d1 (timezone-parse-date date)) + (t1 (timezone-parse-time (aref d1 3)))) + (apply 'encode-time + (mapcar (lambda (el) + (and el (string-to-number el))) + (list + (aref t1 2) (aref t1 1) (aref t1 0) + (aref d1 2) (aref d1 1) (aref d1 0) + (number-to-string + (* 60 (timezone-zone-to-minute (aref d1 4)))))))) + ;; If we get an error, then we just return a 0 time. + (error (list 0 0)))) + +(defun nnmail-time-less (t1 t2) + "Say whether time T1 is less than time T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(defun nnmail-days-to-time (days) + "Convert DAYS into time." + (let* ((seconds (* 1.0 days 60 60 24)) + (rest (expt 2 16)) + (ms (condition-case nil (round (/ seconds rest)) + (range-error (expt 2 16))))) + (list ms (condition-case nil (round (- seconds (* ms rest))) + (range-error (expt 2 16)))))) + +(defun nnmail-time-since (time) + "Return the time since TIME, which is either an internal time or a date." + (when (stringp time) + ;; Convert date strings to internal time. + (setq time (nnmail-date-to-time time))) + (let* ((current (current-time)) + (rest (when (< (nth 1 current) (nth 1 time)) + (expt 2 16)))) + (list (- (+ (car current) (if rest -1 0)) (car time)) + (- (+ (or rest 0) (nth 1 current)) (nth 1 time))))) + +;; Function rewritten from rmail.el. +(defun nnmail-move-inbox (inbox) + "Move INBOX to `nnmail-crash-box'." + (if (not (file-writable-p nnmail-crash-box)) + (gnus-error 1 "Can't write to crash box %s. Not moving mail" + nnmail-crash-box) + ;; If the crash box exists and is empty, we delete it. + (when (and (file-exists-p nnmail-crash-box) + (zerop (nnheader-file-size (file-truename nnmail-crash-box)))) + (delete-file nnmail-crash-box)) + (let ((tofile (file-truename (expand-file-name nnmail-crash-box))) + (popmail (string-match "^po:" inbox)) + movemail errors result) + (unless popmail + (setq inbox (file-truename (expand-file-name inbox))) + (setq movemail t) + ;; On some systems, /usr/spool/mail/foo is a directory + ;; and the actual inbox is /usr/spool/mail/foo/foo. + (when (file-directory-p inbox) + (setq inbox (expand-file-name (user-login-name) inbox)))) + (if (member inbox nnmail-moved-inboxes) + ;; We don't try to move an already moved inbox. + nil + (if popmail + (progn + (when (and nnmail-pop-password + (not nnmail-internal-password)) + (setq nnmail-internal-password nnmail-pop-password)) + (when (and nnmail-pop-password-required + (not nnmail-internal-password)) + (setq nnmail-internal-password + (nnmail-read-passwd + (format "Password for %s: " + (substring inbox (+ popmail 3)))))) + (message "Getting mail from the post office...")) + (when (or (and (file-exists-p tofile) + (/= 0 (nnheader-file-size tofile))) + (and (file-exists-p inbox) + (/= 0 (nnheader-file-size inbox)))) + (message "Getting mail from %s..." inbox))) + ;; Set TOFILE if have not already done so, and + ;; rename or copy the file INBOX to TOFILE if and as appropriate. + (cond + ((file-exists-p tofile) + ;; The crash box exists already. + t) + ((and (not popmail) + (not (file-exists-p inbox))) + ;; There is no inbox. + (setq tofile nil)) + (t + ;; If getting from mail spool directory, use movemail to move + ;; rather than just renaming, so as to interlock with the + ;; mailer. + (unwind-protect + (save-excursion + (setq errors (generate-new-buffer " *nnmail loss*")) + (buffer-disable-undo errors) + (let ((default-directory "/")) + (if (nnheader-functionp nnmail-movemail-program) + (condition-case err + (progn + (funcall nnmail-movemail-program inbox tofile) + (setq result 0)) + (error + (save-excursion + (set-buffer errors) + (insert (prin1-to-string err)) + (setq result 255)))) + (setq result + (apply + 'call-process + (append + (list + (expand-file-name + nnmail-movemail-program exec-directory) + nil errors nil inbox tofile) + (when nnmail-internal-password + (list nnmail-internal-password))))))) + (if (and (not (buffer-modified-p errors)) + (zerop result)) + ;; No output => movemail won + (progn + (unless popmail + (when (file-exists-p tofile) + (set-file-modes tofile nnmail-default-file-modes))) + (push inbox nnmail-moved-inboxes)) + (set-buffer errors) + ;; There may be a warning about older revisions. We + ;; ignore those. + (goto-char (point-min)) + (if (search-forward "older revision" nil t) + (progn + (unless popmail + (when (file-exists-p tofile) + (set-file-modes tofile nnmail-default-file-modes))) + (push inbox nnmail-moved-inboxes)) + ;; Probably a real error. + (subst-char-in-region (point-min) (point-max) ?\n ?\ ) + (goto-char (point-max)) + (skip-chars-backward " \t") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (when (looking-at "movemail: ") + (delete-region (point-min) (match-end 0))) + (unless (yes-or-no-p + (format "movemail: %s (%d return). Continue? " + (buffer-string) result)) + (error "%s" (buffer-string))) + (setq tofile nil))))))) + (message "Getting mail from %s...done" inbox) + (and errors + (buffer-name errors) + (kill-buffer errors)) + tofile)))) + +(defun nnmail-get-active () + "Returns an assoc of group names and active ranges. +nn*-request-list should have been called before calling this function." + (let (group-assoc) + ;; Go through all groups from the active list. + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while (re-search-forward + "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)" nil t) + ;; We create an alist with `(GROUP (LOW . HIGH))' elements. + (push (list (match-string 1) + (cons (string-to-int (match-string 3)) + (string-to-int (match-string 2)))) + group-assoc))) + group-assoc)) + +;; 1997/8/12 by MORIOKA Tomohiko +(defvar nnmail-active-file-coding-system + 'iso-8859-1 + "*Coding system for active file.") + +(defun nnmail-save-active (group-assoc file-name) + "Save GROUP-ASSOC in ACTIVE-FILE." + (let ((coding-system-for-write nnmail-active-file-coding-system)) + (when file-name + (nnheader-temp-write file-name + (nnmail-generate-active group-assoc))))) + +(defun nnmail-generate-active (alist) + "Generate an active file from group-alist ALIST." + (erase-buffer) + (let (group) + (while (setq group (pop alist)) + (insert (format "%s %d %d y\n" (car group) (cdadr group) + (caadr group)))))) + +(defun nnmail-get-split-group (file group) + "Find out whether this FILE is to be split into GROUP only. +If GROUP is non-nil and we are using procmail, return the group name +only when the file is the correct procmail file. When GROUP is nil, +return nil if FILE is a spool file or the procmail group for which it +is a spool. If not using procmail, return GROUP." + (if (or (eq nnmail-spool-file 'procmail) + nnmail-use-procmail) + (if (string-match (concat "^" (expand-file-name + (file-name-as-directory + nnmail-procmail-directory)) + "\\([^/]*\\)" nnmail-procmail-suffix "$") + (expand-file-name file)) + (let ((procmail-group (substring (expand-file-name file) + (match-beginning 1) + (match-end 1)))) + (if group + (if (string-equal group procmail-group) + group + nil) + procmail-group)) + nil) + group)) + +(defun nnmail-process-babyl-mail-format (func artnum-func) + (let ((case-fold-search t) + start message-id content-length do-search end) + (goto-char (point-min)) + (while (not (eobp)) + (re-search-forward + " \n0, *unseen,+\n\\(\\*\\*\\* EOOH \\*\\*\\*\n\\)?" nil t) + (goto-char (match-end 0)) + (delete-region (match-beginning 0) (match-end 0)) + (narrow-to-region + (setq start (point)) + (progn + ;; Skip all the headers in case there are more "From "s... + (or (search-forward "\n\n" nil t) + (search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t) + (search-forward " ")) + (point))) + ;; Unquote the ">From " line, if any. + (goto-char (point-min)) + (when (looking-at ">From ") + (replace-match "X-From-Line: ") ) + (run-hooks 'nnmail-prepare-incoming-header-hook) + (goto-char (point-max)) + ;; Find the Message-ID header. + (save-excursion + (if (re-search-backward + "^Message-ID[ \t]*:[ \n\t]*\\(<[^>]*>\\)" nil t) + (setq message-id (buffer-substring (match-beginning 1) + (match-end 1))) + ;; There is no Message-ID here, so we create one. + (save-excursion + (when (re-search-backward "^Message-ID[ \t]*:" nil t) + (beginning-of-line) + (insert "Original-"))) + (forward-line -1) + (insert "Message-ID: " (setq message-id (nnmail-message-id)) + "\n"))) + ;; Look for a Content-Length header. + (if (not (save-excursion + (and (re-search-backward + "^Content-Length:[ \t]*\\([0-9]+\\)" start t) + (setq content-length (string-to-int + (buffer-substring + (match-beginning 1) + (match-end 1)))) + ;; We destroy the header, since none of + ;; the backends ever use it, and we do not + ;; want to confuse other mailers by having + ;; a (possibly) faulty header. + (progn (insert "X-") t)))) + (setq do-search t) + (widen) + (if (or (= (+ (point) content-length) (point-max)) + (save-excursion + (goto-char (+ (point) content-length)) + (looking-at ""))) + (progn + (goto-char (+ (point) content-length)) + (setq do-search nil)) + (setq do-search t))) + (widen) + ;; Go to the beginning of the next article - or to the end + ;; of the buffer. + (when do-search + (if (re-search-forward "^" nil t) + (goto-char (match-beginning 0)) + (goto-char (1- (point-max))))) + (delete-char 1) ; delete ^_ + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (goto-char (point-min)) + (nnmail-check-duplication message-id func artnum-func) + (setq end (point-max)))) + (goto-char end)))) + +(defsubst nnmail-search-unix-mail-delim () + "Put point at the beginning of the next Unix mbox message." + ;; Algorithm used to find the the next article in the + ;; brain-dead Unix mbox format: + ;; + ;; 1) Search for "^From ". + ;; 2) If we find it, then see whether the previous + ;; line is blank and the next line looks like a header. + ;; Then it's possible that this is a mail delim, and we use it. + (let ((case-fold-search nil) + found) + (while (not found) + (if (not (re-search-forward "^From " nil t)) + (setq found 'no) + (save-excursion + (beginning-of-line) + (when (and (or (bobp) + (save-excursion + (forward-line -1) + (= (following-char) ?\n))) + (save-excursion + (forward-line 1) + (while (looking-at ">From \\|From ") + (forward-line 1)) + (looking-at "[^ \n\t:]+[ \n\t]*:"))) + (setq found 'yes))))) + (beginning-of-line) + (eq found 'yes))) + +(defun nnmail-search-unix-mail-delim-backward () + "Put point at the beginning of the current Unix mbox message." + ;; Algorithm used to find the the next article in the + ;; brain-dead Unix mbox format: + ;; + ;; 1) Search for "^From ". + ;; 2) If we find it, then see whether the previous + ;; line is blank and the next line looks like a header. + ;; Then it's possible that this is a mail delim, and we use it. + (let ((case-fold-search nil) + found) + (while (not found) + (if (not (re-search-backward "^From " nil t)) + (setq found 'no) + (save-excursion + (beginning-of-line) + (when (and (or (bobp) + (save-excursion + (forward-line -1) + (= (following-char) ?\n))) + (save-excursion + (forward-line 1) + (while (looking-at ">From \\|From ") + (forward-line 1)) + (looking-at "[^ \n\t:]+[ \n\t]*:"))) + (setq found 'yes))))) + (beginning-of-line) + (eq found 'yes))) + +(defun nnmail-process-unix-mail-format (func artnum-func) + (let ((case-fold-search t) + start message-id content-length end skip head-end) + (goto-char (point-min)) + (if (not (and (re-search-forward "^From " nil t) + (goto-char (match-beginning 0)))) + ;; Possibly wrong format? + (error "Error, unknown mail format! (Possibly corrupted.)") + ;; Carry on until the bitter end. + (while (not (eobp)) + (setq start (point) + end nil) + ;; Find the end of the head. + (narrow-to-region + start + (if (search-forward "\n\n" nil t) + (1- (point)) + ;; This will never happen, but just to be on the safe side -- + ;; if there is no head-body delimiter, we search a bit manually. + (while (and (looking-at "From \\|[^ \t]+:") + (not (eobp))) + (forward-line 1)) + (point))) + ;; Find the Message-ID header. + (goto-char (point-min)) + (if (re-search-forward "^Message-ID[ \t]*:[ \n\t]*\\(<[^>]+>\\)" nil t) + (setq message-id (match-string 1)) + (save-excursion + (when (re-search-forward "^Message-ID[ \t]*:" nil t) + (beginning-of-line) + (insert "Original-"))) + ;; There is no Message-ID here, so we create one. + (forward-line 1) + (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n")) + ;; Look for a Content-Length header. + (goto-char (point-min)) + (if (not (re-search-forward + "^Content-Length:[ \t]*\\([0-9]+\\)" nil t)) + (setq content-length nil) + (setq content-length (string-to-int (match-string 1))) + ;; We destroy the header, since none of the backends ever + ;; use it, and we do not want to confuse other mailers by + ;; having a (possibly) faulty header. + (beginning-of-line) + (insert "X-")) + (run-hooks 'nnmail-prepare-incoming-header-hook) + ;; Find the end of this article. + (goto-char (point-max)) + (widen) + (setq head-end (point)) + ;; We try the Content-Length value. The idea: skip over the header + ;; separator, then check what happens content-length bytes into the + ;; message body. This should be either the end ot the buffer, the + ;; message separator or a blank line followed by the separator. + ;; The blank line should probably be deleted. If neither of the + ;; three is met, the content-length header is probably invalid. + (when content-length + (forward-line 1) + (setq skip (+ (point) content-length)) + (goto-char skip) + (cond ((or (= skip (point-max)) + (= (1+ skip) (point-max))) + (setq end (point-max))) + ((looking-at "From ") + (setq end skip)) + ((looking-at "[ \t]*\n\\(From \\)") + (setq end (match-beginning 1))) + (t (setq end nil)))) + (if end + (goto-char end) + ;; No Content-Length, so we find the beginning of the next + ;; article or the end of the buffer. + (goto-char head-end) + (or (nnmail-search-unix-mail-delim) + (goto-char (point-max)))) + ;; Allow the backend to save the article. + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (goto-char (point-min)) + (nnmail-check-duplication message-id func artnum-func) + (setq end (point-max)))) + (goto-char end))))) + +(defun nnmail-process-mmdf-mail-format (func artnum-func) + (let ((delim "^\^A\^A\^A\^A$") + (case-fold-search t) + start message-id end) + (goto-char (point-min)) + (if (not (and (re-search-forward delim nil t) + (forward-line 1))) + ;; Possibly wrong format? + (error "Error, unknown mail format! (Possibly corrupted.)") + ;; Carry on until the bitter end. + (while (not (eobp)) + (setq start (point)) + ;; Find the end of the head. + (narrow-to-region + start + (if (search-forward "\n\n" nil t) + (1- (point)) + ;; This will never happen, but just to be on the safe side -- + ;; if there is no head-body delimiter, we search a bit manually. + (while (and (looking-at "From \\|[^ \t]+:") + (not (eobp))) + (forward-line 1)) + (point))) + ;; Find the Message-ID header. + (goto-char (point-min)) + (if (re-search-forward "^Message-ID[ \t]*:[ \n\t]*\\(<[^>]+>\\)" nil t) + (setq message-id (match-string 1)) + ;; There is no Message-ID here, so we create one. + (save-excursion + (when (re-search-backward "^Message-ID[ \t]*:" nil t) + (beginning-of-line) + (insert "Original-"))) + (forward-line 1) + (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n")) + (run-hooks 'nnmail-prepare-incoming-header-hook) + ;; Find the end of this article. + (goto-char (point-max)) + (widen) + (if (re-search-forward delim nil t) + (beginning-of-line) + (goto-char (point-max))) + ;; Allow the backend to save the article. + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (goto-char (point-min)) + (nnmail-check-duplication message-id func artnum-func) + (setq end (point-max)))) + (goto-char end) + (forward-line 2))))) + +(defun nnmail-split-incoming (incoming func &optional exit-func + group artnum-func) + "Go through the entire INCOMING file and pick out each individual mail. +FUNC will be called with the buffer narrowed to each mail." + (let (;; If this is a group-specific split, we bind the split + ;; methods to just this group. + (nnmail-split-methods (if (and group + (or (eq nnmail-spool-file 'procmail) + nnmail-use-procmail) + (not nnmail-resplit-incoming)) + (list (list group "")) + nnmail-split-methods))) + (save-excursion + ;; Insert the incoming file. + (set-buffer (get-buffer-create " *nnmail incoming*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (nnheader-insert-file-contents incoming) + (unless (zerop (buffer-size)) + (goto-char (point-min)) + (save-excursion (run-hooks 'nnmail-prepare-incoming-hook)) + ;; Handle both babyl, MMDF and unix mail formats, since movemail will + ;; use the former when fetching from a mailbox, the latter when + ;; fetching from a file. + (cond ((or (looking-at "\^L") + (looking-at "BABYL OPTIONS:")) + (nnmail-process-babyl-mail-format func artnum-func)) + ((looking-at "\^A\^A\^A\^A") + (nnmail-process-mmdf-mail-format func artnum-func)) + (t + (nnmail-process-unix-mail-format func artnum-func)))) + (when exit-func + (funcall exit-func)) + (kill-buffer (current-buffer))))) + +;; Mail crossposts suggested by Brian Edmonds . +(defun nnmail-article-group (func) + "Look at the headers and return an alist of groups that match. +FUNC will be called with the group name to determine the article number." + (let ((methods nnmail-split-methods) + (obuf (current-buffer)) + (beg (point-min)) + end group-art method) + (if (and (sequencep methods) (= (length methods) 1)) + ;; If there is only just one group to put everything in, we + ;; just return a list with just this one method in. + (setq group-art + (list (cons (caar methods) (funcall func (caar methods))))) + ;; We do actual comparison. + (save-excursion + ;; Find headers. + (goto-char beg) + (setq end (if (search-forward "\n\n" nil t) (point) (point-max))) + (set-buffer nntp-server-buffer) + (erase-buffer) + ;; Copy the headers into the work buffer. + (insert-buffer-substring obuf beg end) + ;; Fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + ;; Allow washing. + (run-hooks 'nnmail-split-hook) + (if (and (symbolp nnmail-split-methods) + (fboundp nnmail-split-methods)) + (let ((split + (condition-case nil + ;; `nnmail-split-methods' is a function, so we + ;; just call this function here and use the + ;; result. + (or (funcall nnmail-split-methods) + '("bogus")) + (error + (message + "Error in `nnmail-split-methods'; using `bogus' mail group") + (sit-for 1) + '("bogus"))))) + ;; The article may be "cross-posted" to `junk'. What + ;; to do? Just remove the `junk' spec. Don't really + ;; see anything else to do... + (let (elem) + (while (setq elem (car (memq 'junk split))) + (setq split (delq elem split)))) + (when split + (setq group-art + (mapcar + (lambda (group) (cons group (funcall func group))) + split)))) + ;; Go through the split methods to find a match. + (while (and methods (or nnmail-crosspost (not group-art))) + (goto-char (point-max)) + (setq method (pop methods)) + (if (or methods + (not (equal "" (nth 1 method)))) + (when (and + (ignore-errors + (if (stringp (nth 1 method)) + (re-search-backward (cadr method) nil t) + ;; Function to say whether this is a match. + (funcall (nth 1 method) (car method)))) + ;; Don't enter the article into the same + ;; group twice. + (not (assoc (car method) group-art))) + (push (cons (car method) (funcall func (car method))) + group-art)) + ;; This is the final group, which is used as a + ;; catch-all. + (unless group-art + (setq group-art + (list (cons (car method) + (funcall func (car method))))))))) + ;; See whether the split methods returned `junk'. + (if (equal group-art '(junk)) + nil + ;; The article may be "cross-posted" to `junk'. What + ;; to do? Just remove the `junk' spec. Don't really + ;; see anything else to do... + (let (elem) + (while (setq elem (car (memq 'junk group-art))) + (setq group-art (delq elem group-art))) + (nreverse group-art))))))) + +(defun nnmail-insert-lines () + "Insert how many lines there are in the body of the mail. +Return the number of characters in the body." + (let (lines chars) + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (setq chars (- (point-max) (point))) + (setq lines (count-lines (point) (point-max))) + (forward-char -1) + (save-excursion + (when (re-search-backward "^Lines: " nil t) + (delete-region (point) (progn (forward-line 1) (point))))) + (beginning-of-line) + (insert (format "Lines: %d\n" (max lines 0))) + chars)))) + +(defun nnmail-insert-xref (group-alist) + "Insert an Xref line based on the (group . article) alist." + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (when (re-search-backward "^Xref: " nil t) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + (insert (format "Xref: %s" (system-name))) + (while group-alist + (insert (format " %s:%d" + (gnus-encode-coding-string (caar group-alist) + nnmail-pathname-coding-system) + (cdar group-alist))) + (setq group-alist (cdr group-alist))) + (insert "\n")))) + +;;; Message washing functions + +(defun nnmail-remove-leading-whitespace () + "Remove excessive whitespace from all headers." + (goto-char (point-min)) + (while (re-search-forward "^\\([^ :]+: \\) +" nil t) + (replace-match "\\1" t))) + +(defun nnmail-remove-list-identifiers () + "Remove list identifiers from Subject headers." + (let ((regexp (if (stringp nnmail-list-identifiers) nnmail-list-identifiers + (mapconcat 'identity nnmail-list-identifiers "\\|")))) + (when regexp + (goto-char (point-min)) + (when (re-search-forward + (concat "^Subject: +\\(Re: +\\)?\\(" regexp "\\) *") + nil t) + (delete-region (match-beginning 2) (match-end 0)))))) + +(defun nnmail-remove-tabs () + "Translate TAB characters into SPACE characters." + (subst-char-in-region (point-min) (point-max) ?\t ? t)) + +;;; Utility functions + +;; Written by byer@mv.us.adobe.com (Scott Byer). +(defun nnmail-make-complex-temp-name (prefix) + (let ((newname (make-temp-name prefix)) + (newprefix prefix)) + (while (file-exists-p newname) + (setq newprefix (concat newprefix "x")) + (setq newname (make-temp-name newprefix))) + newname)) + +;; Written by Per Abrahamsen . + +(defun nnmail-split-fancy () + "Fancy splitting method. +See the documentation for the variable `nnmail-split-fancy' for documentation." + (let ((syntab (syntax-table))) + (unwind-protect + (progn + (set-syntax-table nnmail-split-fancy-syntax-table) + (nnmail-split-it nnmail-split-fancy)) + (set-syntax-table syntab)))) + +(defvar nnmail-split-cache nil) +;; Alist of split expressions their equivalent regexps. + +(defun nnmail-split-it (split) + ;; Return a list of groups matching SPLIT. + (cond + ;; nil split + ((null split) + nil) + + ;; A group name. Do the \& and \N subs into the string. + ((stringp split) + (list (nnmail-expand-newtext split))) + + ;; Junk the message. + ((eq split 'junk) + (list 'junk)) + + ;; Builtin & operation. + ((eq (car split) '&) + (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) + + ;; Builtin | operation. + ((eq (car split) '|) + (let (done) + (while (and (not done) (cdr split)) + (setq split (cdr split) + done (nnmail-split-it (car split)))) + done)) + + ;; Builtin : operation. + ((eq (car split) ':) + (nnmail-split-it (eval (cdr split)))) + + ;; Check the cache for the regexp for this split. + ;; FIX FIX FIX could avoid calling assq twice here + ((assq split nnmail-split-cache) + (goto-char (point-max)) + ;; FIX FIX FIX problem with re-search-backward is that if you have + ;; a split: (from "foo-\\(bar\\|baz\\)@gnus.org "mail.foo.\\1") + ;; and someone mails a message with 'To: foo-bar@gnus.org' and + ;; 'CC: foo-baz@gnus.org', we'll pick 'mail.foo.baz' as the group + ;; if the cc line is a later header, even though the other choice + ;; is probably better. Also, this routine won't do a crosspost + ;; when there are two different matches. + ;; I guess you could just make this more determined, and it could + ;; look for still more matches prior to this one, and recurse + ;; on each of the multiple matches hit. Of course, then you'd + ;; want to make sure that nnmail-article-group or nnmail-split-fancy + ;; removed duplicates, since there might be more of those. + ;; I guess we could also remove duplicates in the & split case, since + ;; that's the only thing that can introduce them. + (when (re-search-backward (cdr (assq split nnmail-split-cache)) nil t) + ;; Someone might want to do a \N sub on this match, so get the + ;; correct match positions. + (goto-char (match-end 0)) + (let ((value (nth 1 split))) + (re-search-backward (if (symbolp value) + (cdr (assq value nnmail-split-abbrev-alist)) + value) + (match-end 1))) + (nnmail-split-it (nth 2 split)))) + + ;; Not in cache, compute a regexp for the field/value pair. + (t + (let* ((field (nth 0 split)) + (value (nth 1 split)) + (regexp (concat "^\\(\\(" + (if (symbolp field) + (cdr (assq field nnmail-split-abbrev-alist)) + field) + "\\):.*\\)\\<\\(" + (if (symbolp value) + (cdr (assq value nnmail-split-abbrev-alist)) + value) + "\\)\\>"))) + (push (cons split regexp) nnmail-split-cache) + ;; Now that it's in the cache, just call nnmail-split-it again + ;; on the same split, which will find it immediately in the cache. + (nnmail-split-it split))))) + +(defun nnmail-expand-newtext (newtext) + (let ((len (length newtext)) + (pos 0) + c expanded beg N did-expand) + (while (< pos len) + (setq beg pos) + (while (and (< pos len) + (not (= (aref newtext pos) ?\\))) + (setq pos (1+ pos))) + (unless (= beg pos) + (push (substring newtext beg pos) expanded)) + (when (< pos len) + ;; we hit a \, expand it. + (setq did-expand t) + (setq pos (1+ pos)) + (setq c (aref newtext pos)) + (if (not (or (= c ?\&) + (and (>= c ?1) + (<= c ?9)))) + ;; \ followed by some character we don't expand + (push (char-to-string c) expanded) + ;; \& or \N + (if (= c ?\&) + (setq N 0) + (setq N (- c ?0))) + (when (match-beginning N) + (push (buffer-substring (match-beginning N) (match-end N)) + expanded)))) + (setq pos (1+ pos))) + (if did-expand + (apply 'concat (nreverse expanded)) + newtext))) + +;; Get a list of spool files to read. +(defun nnmail-get-spool-files (&optional group) + (if (null nnmail-spool-file) + ;; No spool file whatsoever. + nil + (let* ((procmails + ;; If procmail is used to get incoming mail, the files + ;; are stored in this directory. + (and (file-exists-p nnmail-procmail-directory) + (or (eq nnmail-spool-file 'procmail) + nnmail-use-procmail) + (directory-files + nnmail-procmail-directory + t (concat (if group (concat "^" group) "") + nnmail-procmail-suffix "$")))) + (p procmails) + (crash (when (and (file-exists-p nnmail-crash-box) + (> (nnheader-file-size + (file-truename nnmail-crash-box)) + 0)) + (list nnmail-crash-box)))) + ;; Remove any directories that inadvertently match the procmail + ;; suffix, which might happen if the suffix is "". + (while p + (when (file-directory-p (car p)) + (setq procmails (delete (car p) procmails))) + (setq p (cdr p))) + ;; Return the list of spools. + (append + crash + (cond ((and group + (or (eq nnmail-spool-file 'procmail) + nnmail-use-procmail) + procmails) + procmails) + ((and group + (eq nnmail-spool-file 'procmail)) + nil) + ((listp nnmail-spool-file) + (nconc + (apply + 'nconc + (mapcar + (lambda (file) + (if (and (not (string-match "^po:" file)) + (file-directory-p file)) + (nnheader-directory-regular-files file) + (list file))) + nnmail-spool-file)) + procmails)) + ((stringp nnmail-spool-file) + (if (and (not (string-match "^po:" nnmail-spool-file)) + (file-directory-p nnmail-spool-file)) + (nconc + (nnheader-directory-regular-files nnmail-spool-file) + procmails) + (cons nnmail-spool-file procmails))) + ((eq nnmail-spool-file 'pop) + (cons (format "po:%s" (user-login-name)) procmails)) + (t + procmails)))))) + +;; Activate a backend only if it isn't already activated. +;; If FORCE, re-read the active file even if the backend is +;; already activated. +(defun nnmail-activate (backend &optional force) + (nnheader-init-server-buffer) + (let (file timestamp file-time) + (if (or (not (symbol-value (intern (format "%s-group-alist" backend)))) + force + (and (setq file (ignore-errors + (symbol-value (intern (format "%s-active-file" + backend))))) + (setq file-time (nth 5 (file-attributes file))) + (or (not + (setq timestamp + (condition-case () + (symbol-value (intern + (format "%s-active-timestamp" + backend))) + (error 'none)))) + (not (consp timestamp)) + (equal timestamp '(0 0)) + (> (nth 0 file-time) (nth 0 timestamp)) + (and (= (nth 0 file-time) (nth 0 timestamp)) + (> (nth 1 file-time) (nth 1 timestamp)))))) + (save-excursion + (or (eq timestamp 'none) + (set (intern (format "%s-active-timestamp" backend)) + file-time)) + (funcall (intern (format "%s-request-list" backend))))) + t)) + +(defun nnmail-message-id () + (concat "<" (message-unique-id) "@totally-fudged-out-message-id>")) + +;;; +;;; nnmail duplicate handling +;;; + +(defvar nnmail-cache-buffer nil) + +(defun nnmail-cache-open () + (if (or (not nnmail-treat-duplicates) + (and nnmail-cache-buffer + (buffer-name nnmail-cache-buffer))) + () ; The buffer is open. + (save-excursion + (set-buffer + (setq nnmail-cache-buffer + (get-buffer-create " *nnmail message-id cache*"))) + (buffer-disable-undo (current-buffer)) + (when (file-exists-p nnmail-message-id-cache-file) + (nnheader-insert-file-contents nnmail-message-id-cache-file)) + (set-buffer-modified-p nil) + (current-buffer)))) + +(defun nnmail-cache-close () + (when (and nnmail-cache-buffer + nnmail-treat-duplicates + (buffer-name nnmail-cache-buffer) + (buffer-modified-p nnmail-cache-buffer)) + (save-excursion + (set-buffer nnmail-cache-buffer) + ;; Weed out the excess number of Message-IDs. + (goto-char (point-max)) + (when (search-backward "\n" nil t nnmail-message-id-cache-length) + (progn + (beginning-of-line) + (delete-region (point-min) (point)))) + ;; Save the buffer. + (or (file-exists-p (file-name-directory nnmail-message-id-cache-file)) + (make-directory (file-name-directory nnmail-message-id-cache-file) + t)) + (nnmail-write-region (point-min) (point-max) + nnmail-message-id-cache-file nil 'silent) + (set-buffer-modified-p nil) + (setq nnmail-cache-buffer nil) + (kill-buffer (current-buffer))))) + +(defun nnmail-cache-insert (id) + (when nnmail-treat-duplicates + (unless (gnus-buffer-live-p nnmail-cache-buffer) + (nnmail-cache-open)) + (save-excursion + (set-buffer nnmail-cache-buffer) + (goto-char (point-max)) + (insert id "\n")))) + +(defun nnmail-cache-id-exists-p (id) + (when nnmail-treat-duplicates + (save-excursion + (set-buffer nnmail-cache-buffer) + (goto-char (point-max)) + (search-backward id nil t)))) + +(defun nnmail-fetch-field (header) + (save-excursion + (save-restriction + (message-narrow-to-head) + (message-fetch-field header)))) + +(defun nnmail-check-duplication (message-id func artnum-func) + (run-hooks 'nnmail-prepare-incoming-message-hook) + ;; If this is a duplicate message, then we do not save it. + (let* ((duplication (nnmail-cache-id-exists-p message-id)) + (case-fold-search t) + (action (when duplication + (cond + ((memq nnmail-treat-duplicates '(warn delete)) + nnmail-treat-duplicates) + ((nnheader-functionp nnmail-treat-duplicates) + (funcall nnmail-treat-duplicates message-id)) + (t + nnmail-treat-duplicates)))) + group-art) + ;; Let the backend save the article (or not). + (cond + ((not duplication) + (nnmail-cache-insert message-id) + (funcall func (setq group-art + (nreverse (nnmail-article-group artnum-func))))) + ((eq action 'delete) + (setq group-art nil)) + ((eq action 'warn) + ;; We insert a warning. + (let ((case-fold-search t)) + (goto-char (point-min)) + (re-search-forward "^message-id[ \t]*:" nil t) + (beginning-of-line) + (insert + "Gnus-Warning: This is a duplicate of message " message-id "\n") + (funcall func (setq group-art + (nreverse (nnmail-article-group artnum-func)))))) + (t + (funcall func (setq group-art + (nreverse (nnmail-article-group artnum-func)))))) + ;; Add the group-art list to the history list. + (if group-art + (push group-art nnmail-split-history) + (delete-region (point-min) (point-max))))) + +;;; Get new mail. + +(defun nnmail-get-value (&rest args) + (let ((sym (intern (apply 'format args)))) + (when (boundp sym) + (symbol-value sym)))) + +(defun nnmail-get-new-mail (method exit-func temp + &optional group spool-func) + "Read new incoming mail." + ;; Nix out the previous split history. + (unless group + (setq nnmail-split-history nil)) + (let* ((spools (nnmail-get-spool-files group)) + (group-in group) + incoming incomings spool) + (when (and (nnmail-get-value "%s-get-new-mail" method) + nnmail-spool-file) + ;; We first activate all the groups. + (nnmail-activate method) + ;; Allow the user to hook. + (run-hooks 'nnmail-pre-get-new-mail-hook) + ;; Open the message-id cache. + (nnmail-cache-open) + ;; The we go through all the existing spool files and split the + ;; mail from each. + (while spools + (setq spool (pop spools)) + ;; We read each spool file if either the spool is a POP-mail + ;; spool, or the file exists. We can't check for the + ;; existence of POPped mail. + (when (or (string-match "^po:" spool) + (and (file-exists-p (file-truename spool)) + (> (nnheader-file-size (file-truename spool)) 0))) + (nnheader-message 3 "%s: Reading incoming mail..." method) + (when (and (nnmail-move-inbox spool) + (file-exists-p nnmail-crash-box)) + ;; There is new mail. We first find out if all this mail + ;; is supposed to go to some specific group. + (setq group (nnmail-get-split-group spool group-in)) + ;; We split the mail + (nnmail-split-incoming + nnmail-crash-box (intern (format "%s-save-mail" method)) + spool-func group (intern (format "%s-active-number" method))) + ;; Check whether the inbox is to be moved to the special tmp dir. + (setq incoming + (nnmail-make-complex-temp-name + (expand-file-name + (if nnmail-tmp-directory + (concat + (file-name-as-directory nnmail-tmp-directory) + (file-name-nondirectory + (concat (file-name-as-directory temp) "Incoming"))) + (concat (file-name-as-directory temp) "Incoming"))))) + (rename-file nnmail-crash-box incoming t) + (push incoming incomings)))) + ;; If we did indeed read any incoming spools, we save all info. + (when incomings + (nnmail-save-active + (nnmail-get-value "%s-group-alist" method) + (nnmail-get-value "%s-active-file" method)) + (when exit-func + (funcall exit-func)) + (run-hooks 'nnmail-read-incoming-hook) + (nnheader-message 3 "%s: Reading incoming mail...done" method)) + ;; Close the message-id cache. + (nnmail-cache-close) + ;; Allow the user to hook. + (run-hooks 'nnmail-post-get-new-mail-hook) + ;; Delete all the temporary files. + (while incomings + (setq incoming (pop incomings)) + (and nnmail-delete-incoming + (file-exists-p incoming) + (file-writable-p incoming) + (delete-file incoming)))))) + +(defun nnmail-expired-article-p (group time force &optional inhibit) + "Say whether an article that is TIME old in GROUP should be expired." + (if force + t + (let ((days (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function group)) + nnmail-expiry-wait))) + (cond ((or (eq days 'never) + (and (not force) + inhibit)) + ;; This isn't an expirable group. + nil) + ((eq days 'immediate) + ;; We expire all articles on sight. + t) + ((equal time '(0 0)) + ;; This is an ange-ftp group, and we don't have any dates. + nil) + ((numberp days) + (setq days (nnmail-days-to-time days)) + ;; Compare the time with the current time. + (nnmail-time-less days (nnmail-time-since time))))))) + +(defvar nnmail-read-passwd nil) +(defun nnmail-read-passwd (prompt &rest args) + "Read a password using PROMPT. +If ARGS, PROMPT is used as an argument to `format'." + (let ((prompt + (if args + (apply 'format prompt args) + prompt))) + (unless nnmail-read-passwd + (if (load "passwd" t) + (setq nnmail-read-passwd 'read-passwd) + (unless (fboundp 'ange-ftp-read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp")) + (setq nnmail-read-passwd 'ange-ftp-read-passwd))) + (funcall nnmail-read-passwd prompt))) + +(defun nnmail-check-syntax () + "Check (and modify) the syntax of the message in the current buffer." + (save-restriction + (message-narrow-to-head) + (let ((case-fold-search t)) + (unless (re-search-forward "^Message-ID[ \t]*:" nil t) + (insert "Message-ID: " (nnmail-message-id) "\n"))))) + +(defun nnmail-write-region (start end filename &optional append visit lockname) + "Do a `write-region', and then set the file modes." + ;; 1997/5/4 by MORIOKA Tomohiko + (let ((coding-system-for-write nnmail-file-coding-system) + ;; 1997/8/12 by MORIOKA Tomohiko + ;; for XEmacs/mule. + (pathname-coding-system 'binary)) + (write-region start end filename append visit lockname) + (set-file-modes filename nnmail-default-file-modes))) + +;;; +;;; Status functions +;;; + +(defun nnmail-replace-status (name value) + "Make status NAME and VALUE part of the current status line." + (save-restriction + (message-narrow-to-head) + (let ((status (nnmail-decode-status))) + (setq status (delq (member name status) status)) + (when value + (push (cons name value) status)) + (message-remove-header "status") + (goto-char (point-max)) + (insert "Status: " (nnmail-encode-status status) "\n")))) + +(defun nnmail-decode-status () + "Return a status-value alist from STATUS." + (goto-char (point-min)) + (when (re-search-forward "^Status: " nil t) + (let (name value status) + (save-restriction + ;; Narrow to the status. + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil t) + (1- (point)) + (point-max))) + ;; Go through all elements and add them to the list. + (goto-char (point-min)) + (while (re-search-forward "[^ \t=]+" nil t) + (setq name (match-string 0)) + (if (not (= (following-char) ?=)) + ;; Implied "yes". + (setq value "yes") + (forward-char 1) + (if (not (= (following-char) ?\")) + (if (not (looking-at "[^ \t]")) + ;; Implied "no". + (setq value "no") + ;; Unquoted value. + (setq value (match-string 0)) + (goto-char (match-end 0))) + ;; Quoted value. + (setq value (read (current-buffer))))) + (push (cons name value) status))) + status))) + +(defun nnmail-encode-status (status) + "Return a status string from STATUS." + (mapconcat + (lambda (elem) + (concat + (car elem) "=" + (if (string-match "[ \t]" (cdr elem)) + (prin1-to-string (cdr elem)) + (cdr elem)))) + status " ")) + +(defun nnmail-split-history () + "Generate an overview of where the last mail split put articles." + (interactive) + (unless nnmail-split-history + (error "No current split history")) + (with-output-to-temp-buffer "*nnmail split history*" + (let ((history nnmail-split-history) + elem) + (while (setq elem (pop history)) + (princ (mapconcat (lambda (ga) + (concat (car ga) ":" (int-to-string (cdr ga)))) + elem + ", ")) + (princ "\n"))))) + +(defun nnmail-new-mail-p (group) + "Say whether GROUP has new mail." + (let ((his nnmail-split-history) + found) + (while his + (when (assoc group (pop his)) + (setq found t + his nil))) + found)) + +(eval-and-compile + (autoload 'pop3-movemail "pop3")) + +(defun nnmail-pop3-movemail (inbox crashbox) + "Function to move mail from INBOX on a pop3 server to file CRASHBOX." + (let ((pop3-maildrop + (substring inbox (match-end (string-match "^po:" inbox))))) + (pop3-movemail crashbox))) + +(run-hooks 'nnmail-load-hook) + +(provide 'nnmail) + +;;; nnmail.el ends here diff --git a/lisp/nnmbox.el b/lisp/nnmbox.el new file mode 100644 index 0000000..a5c4676 --- /dev/null +++ b/lisp/nnmbox.el @@ -0,0 +1,552 @@ +;;; nnmbox.el --- mail mbox access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; For an overview of what the interface functions do, please see the +;; Gnus sources. + +;;; Code: + +(require 'nnheader) +(require 'message) +(require 'nnmail) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnmbox) + +(defvoo nnmbox-mbox-file (expand-file-name "~/mbox") + "The name of the mail box file in the user's home directory.") + +(defvoo nnmbox-active-file (expand-file-name "~/.mbox-active") + "The name of the active file for the mail box.") + +(defvoo nnmbox-get-new-mail t + "If non-nil, nnmbox will check the incoming mail file and split the mail.") + +(defvoo nnmbox-prepare-save-mail-hook nil + "Hook run narrowed to an article before saving.") + + + +(defconst nnmbox-version "nnmbox 1.0" + "nnmbox version.") + +(defvoo nnmbox-current-group nil + "Current nnmbox news group directory.") + +(defconst nnmbox-mbox-buffer nil) + +(defvoo nnmbox-status-string "") + +(defvoo nnmbox-group-alist nil) +(defvoo nnmbox-active-timestamp nil) + + + +;;; Interface functions + +(nnoo-define-basics nnmbox) + +(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((number (length sequence)) + (count 0) + article art-string start stop) + (nnmbox-possibly-change-newsgroup newsgroup server) + (while sequence + (setq article (car sequence)) + (setq art-string (nnmbox-article-string article)) + (set-buffer nnmbox-mbox-buffer) + (when (or (search-forward art-string nil t) + (progn (goto-char (point-min)) + (search-forward art-string nil t))) + (setq start + (save-excursion + (re-search-backward + (concat "^" message-unix-mail-delimiter) nil t) + (point))) + (search-forward "\n\n" nil t) + (setq stop (1- (point))) + (set-buffer nntp-server-buffer) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring nnmbox-mbox-buffer start stop) + (goto-char (point-max)) + (insert ".\n")) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (zerop (% count 20)) + (nnheader-message 5 "nnmbox: Receiving headers... %d%%" + (/ (* count 100) number)))) + + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (nnheader-message 5 "nnmbox: Receiving headers...done")) + + (set-buffer nntp-server-buffer) + (nnheader-fold-continuation-lines) + 'headers))) + +(deffoo nnmbox-open-server (server &optional defs) + (nnoo-change-server 'nnmbox server defs) + (nnmbox-create-mbox) + (cond + ((not (file-exists-p nnmbox-mbox-file)) + (nnmbox-close-server) + (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file)) + ((file-directory-p nnmbox-mbox-file) + (nnmbox-close-server) + (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file)) + (t + (nnheader-report 'nnmbox "Opened server %s using mbox %s" server + nnmbox-mbox-file) + t))) + +(deffoo nnmbox-close-server (&optional server) + (when (and nnmbox-mbox-buffer + (buffer-name nnmbox-mbox-buffer)) + (kill-buffer nnmbox-mbox-buffer)) + (nnoo-close-server 'nnmbox server) + t) + +(deffoo nnmbox-server-opened (&optional server) + (and (nnoo-current-server-p 'nnmbox server) + nnmbox-mbox-buffer + (buffer-name nnmbox-mbox-buffer) + nntp-server-buffer + (buffer-name nntp-server-buffer))) + +(deffoo nnmbox-request-article (article &optional newsgroup server buffer) + (nnmbox-possibly-change-newsgroup newsgroup server) + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-min)) + (when (search-forward (nnmbox-article-string article) nil t) + (let (start stop) + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (setq start (point)) + (forward-line 1) + (or (and (re-search-forward + (concat "^" message-unix-mail-delimiter) nil t) + (forward-line -1)) + (goto-char (point-max))) + (setq stop (point)) + (let ((nntp-server-buffer (or buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring nnmbox-mbox-buffer start stop) + (goto-char (point-min)) + (while (looking-at "From ") + (delete-char 5) + (insert "X-From-Line: ") + (forward-line 1)) + (if (numberp article) + (cons nnmbox-current-group article) + (nnmbox-article-group-number))))))) + +(deffoo nnmbox-request-group (group &optional server dont-check) + (let ((active (cadr (assoc group nnmbox-group-alist)))) + (cond + ((or (null active) + (null (nnmbox-possibly-change-newsgroup group server))) + (nnheader-report 'nnmbox "No such group: %s" group)) + (dont-check + (nnheader-report 'nnmbox "Selected group %s" group) + (nnheader-insert "")) + (t + (nnheader-report 'nnmbox "Selected group %s" group) + (nnheader-insert "211 %d %d %d %s\n" + (1+ (- (cdr active) (car active))) + (car active) (cdr active) group))))) + +(deffoo nnmbox-request-scan (&optional group server) + (nnmbox-possibly-change-newsgroup group server) + (nnmbox-read-mbox) + (nnmail-get-new-mail + 'nnmbox + (lambda () + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (save-buffer))) + (file-name-directory nnmbox-mbox-file) + group + (lambda () + (save-excursion + (let ((in-buf (current-buffer))) + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-max)) + (insert-buffer-substring in-buf))) + (nnmail-save-active nnmbox-group-alist nnmbox-active-file)))) + +(deffoo nnmbox-close-group (group &optional server) + t) + +(deffoo nnmbox-request-list (&optional server) + (save-excursion + (nnmail-find-file nnmbox-active-file) + (setq nnmbox-group-alist (nnmail-get-active)) + t)) + +(deffoo nnmbox-request-newgroups (date &optional server) + (nnmbox-request-list server)) + +(deffoo nnmbox-request-list-newsgroups (&optional server) + (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented.")) + +(deffoo nnmbox-request-expire-articles + (articles newsgroup &optional server force) + (nnmbox-possibly-change-newsgroup newsgroup server) + (let* ((is-old t) + rest) + (nnmail-activate 'nnmbox) + + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (while (and articles is-old) + (goto-char (point-min)) + (when (search-forward (nnmbox-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) force)) + (progn + (nnheader-message 5 "Deleting article %d in %s..." + (car articles) newsgroup) + (nnmbox-delete-mail)) + (push (car articles) rest))) + (setq articles (cdr articles))) + (save-buffer) + ;; Find the lowest active article in this group. + (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist)))) + (goto-char (point-min)) + (while (and (not (search-forward + (nnmbox-article-string (car active)) nil t)) + (<= (car active) (cdr active))) + (setcar active (1+ (car active))) + (goto-char (point-min)))) + (nnmail-save-active nnmbox-group-alist nnmbox-active-file) + (nconc rest articles)))) + +(deffoo nnmbox-request-move-article + (article group server accept-form &optional last) + (let ((buf (get-buffer-create " *nnmbox move*")) + result) + (and + (nnmbox-request-article article group server) + (save-excursion + (set-buffer buf) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-buffer-substring nntp-server-buffer) + (goto-char (point-min)) + (while (re-search-forward + "^X-Gnus-Newsgroup:" + (save-excursion (search-forward "\n\n" nil t) (point)) t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + (setq result (eval accept-form)) + (kill-buffer buf) + result) + (save-excursion + (nnmbox-possibly-change-newsgroup group server) + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-min)) + (when (search-forward (nnmbox-article-string article) nil t) + (nnmbox-delete-mail)) + (and last (save-buffer)))) + result)) + +(deffoo nnmbox-request-accept-article (group &optional server last) + (nnmbox-possibly-change-newsgroup group server) + (nnmail-check-syntax) + (let ((buf (current-buffer)) + result) + (goto-char (point-min)) + ;; The From line may have been quoted by movemail. + (when (looking-at (concat ">" message-unix-mail-delimiter)) + (delete-char 1)) + (if (looking-at "X-From-Line: ") + (replace-match "From ") + (insert "From nobody " (current-time-string) "\n")) + (and + (nnmail-activate 'nnmbox) + (progn + (set-buffer buf) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (forward-line -1) + (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) + (delete-region (point) (progn (forward-line 1) (point)))) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (setq result (if (stringp group) + (list (cons group (nnmbox-active-number group))) + (nnmail-article-group 'nnmbox-active-number))) + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result (car (nnmbox-save-mail result))))) + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-max)) + (insert-buffer-substring buf) + (when last + (when nnmail-cache-accepted-message-ids + (nnmail-cache-close)) + (nnmail-save-active nnmbox-group-alist nnmbox-active-file) + (save-buffer)))) + result)) + +(deffoo nnmbox-request-replace-article (article group buffer) + (nnmbox-possibly-change-newsgroup group) + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-min)) + (if (not (search-forward (nnmbox-article-string article) nil t)) + nil + (nnmbox-delete-mail t t) + (insert-buffer-substring buffer) + (save-buffer) + t))) + +(deffoo nnmbox-request-delete-group (group &optional force server) + (nnmbox-possibly-change-newsgroup group server) + ;; Delete all articles in GROUP. + (if (not force) + () ; Don't delete the articles. + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-min)) + ;; Delete all articles in this group. + (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) + found) + (while (search-forward ident nil t) + (setq found t) + (nnmbox-delete-mail)) + (when found + (save-buffer))))) + ;; Remove the group from all structures. + (setq nnmbox-group-alist + (delq (assoc group nnmbox-group-alist) nnmbox-group-alist) + nnmbox-current-group nil) + ;; Save the active file. + (nnmail-save-active nnmbox-group-alist nnmbox-active-file) + t) + +(deffoo nnmbox-request-rename-group (group new-name &optional server) + (nnmbox-possibly-change-newsgroup group server) + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (goto-char (point-min)) + (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) + (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) + found) + (while (search-forward ident nil t) + (replace-match new-ident t t) + (setq found t)) + (when found + (save-buffer)))) + (let ((entry (assoc group nnmbox-group-alist))) + (when entry + (setcar entry new-name)) + (setq nnmbox-current-group nil) + ;; Save the new group alist. + (nnmail-save-active nnmbox-group-alist nnmbox-active-file) + t)) + + +;;; Internal functions. + +;; If FORCE, delete article no matter how many X-Gnus-Newsgroup +;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox +;; delimiter line. +(defun nnmbox-delete-mail (&optional force leave-delim) + ;; Delete the current X-Gnus-Newsgroup line. + (or force + (delete-region + (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) + ;; Beginning of the article. + (save-excursion + (save-restriction + (narrow-to-region + (save-excursion + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (if leave-delim (progn (forward-line 1) (point)) + (match-beginning 0))) + (progn + (forward-line 1) + (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) + nil t) + (if (and (not (bobp)) leave-delim) + (progn (forward-line -2) (point)) + (match-beginning 0))) + (point-max)))) + (goto-char (point-min)) + ;; Only delete the article if no other groups owns it as well. + (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (delete-region (point-min) (point-max)))))) + +(defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) + (when (and server + (not (nnmbox-server-opened server))) + (nnmbox-open-server server)) + (when (or (not nnmbox-mbox-buffer) + (not (buffer-name nnmbox-mbox-buffer))) + (save-excursion + (set-buffer (setq nnmbox-mbox-buffer + (nnheader-find-file-noselect + nnmbox-mbox-file nil 'raw))) + (buffer-disable-undo (current-buffer)))) + (when (not nnmbox-group-alist) + (nnmail-activate 'nnmbox)) + (if newsgroup + (when (assoc newsgroup nnmbox-group-alist) + (setq nnmbox-current-group newsgroup)) + t)) + +(defun nnmbox-article-string (article) + (if (numberp article) + (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" + (int-to-string article) " ") + (concat "\nMessage-ID: " article))) + +(defun nnmbox-article-group-number () + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " + nil t) + (cons (buffer-substring (match-beginning 1) (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))))) + +(defun nnmbox-save-mail (group-art) + "Called narrowed to an article." + (let ((delim (concat "^" message-unix-mail-delimiter))) + (goto-char (point-min)) + ;; This might come from somewhere else. + (unless (looking-at delim) + (insert "From nobody " (current-time-string) "\n") + (goto-char (point-min))) + ;; Quote all "From " lines in the article. + (forward-line 1) + (while (re-search-forward delim nil t) + (beginning-of-line) + (insert "> ")) + (nnmail-insert-lines) + (nnmail-insert-xref group-art) + (nnmbox-insert-newsgroup-line group-art) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnmbox-prepare-save-mail-hook) + group-art)) + +(defun nnmbox-insert-newsgroup-line (group-art) + (save-excursion + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (while group-art + (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" + (caar group-art) (cdar group-art) + (current-time-string))) + (setq group-art (cdr group-art)))) + t)) + +(defun nnmbox-active-number (group) + ;; Find the next article number in GROUP. + (let ((active (cadr (assoc group nnmbox-group-alist)))) + (if active + (setcdr active (1+ (cdr active))) + ;; This group is new, so we create a new entry for it. + ;; This might be a bit naughty... creating groups on the drop of + ;; a hat, but I don't know... + (push (list group (setq active (cons 1 1))) + nnmbox-group-alist)) + (cdr active))) + +(defun nnmbox-create-mbox () + (when (not (file-exists-p nnmbox-mbox-file)) + (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg))) + +(defun nnmbox-read-mbox () + (nnmail-activate 'nnmbox) + (nnmbox-create-mbox) + (if (and nnmbox-mbox-buffer + (buffer-name nnmbox-mbox-buffer) + (save-excursion + (set-buffer nnmbox-mbox-buffer) + (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) + () + (save-excursion + (let ((delim (concat "^" message-unix-mail-delimiter)) + (alist nnmbox-group-alist) + start end number) + (set-buffer (setq nnmbox-mbox-buffer + (nnheader-find-file-noselect + nnmbox-mbox-file nil 'raw))) + (buffer-disable-undo (current-buffer)) + + ;; Go through the group alist and compare against + ;; the mbox file. + (while alist + (goto-char (point-max)) + (when (and (re-search-backward + (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " + (caar alist)) nil t) + (>= (setq number + (string-to-number + (buffer-substring + (match-beginning 1) (match-end 1)))) + (cdadar alist))) + (setcdr (cadar alist) (1+ number))) + (setq alist (cdr alist))) + + (goto-char (point-min)) + (while (re-search-forward delim nil t) + (setq start (match-beginning 0)) + (when (not (search-forward "\nX-Gnus-Newsgroup: " + (save-excursion + (setq end + (or + (and + (re-search-forward delim nil t) + (match-beginning 0)) + (point-max)))) + t)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (nnmbox-save-mail + (nnmail-article-group 'nnmbox-active-number))))) + (goto-char end)))))) + +(provide 'nnmbox) + +;;; nnmbox.el ends here diff --git a/lisp/nnmh.el b/lisp/nnmh.el new file mode 100644 index 0000000..6db83bd --- /dev/null +++ b/lisp/nnmh.el @@ -0,0 +1,563 @@ +;;; nnmh.el --- mhspool access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Based on nnspool.el by Masanobu UMEDA . +;; For an overview of what the interface functions do, please see the +;; Gnus sources. + +;;; Code: + +(require 'nnheader) +(require 'nnmail) +(require 'gnus-start) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnmh) + +(defvoo nnmh-directory message-directory + "*Mail spool directory.") + +(defvoo nnmh-get-new-mail t + "*If non-nil, nnmh will check the incoming mail file and split the mail.") + +(defvoo nnmh-prepare-save-mail-hook nil + "*Hook run narrowed to an article before saving.") + +(defvoo nnmh-be-safe nil + "*If non-nil, nnmh will check all articles to make sure whether they are new or not.") + + + +(defconst nnmh-version "nnmh 1.0" + "nnmh version.") + +(defvoo nnmh-current-directory nil + "Current news group directory.") + +(defvoo nnmh-status-string "") +(defvoo nnmh-group-alist nil) +(defvoo nnmh-allow-delete-final nil) + + + +;;; Interface functions. + +(nnoo-define-basics nnmh) + +(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let* ((file nil) + (number (length articles)) + (large (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup))) + (count 0) + (pathname-coding-system 'binary) + beg article) + (nnmh-possibly-change-directory newsgroup server) + ;; We don't support fetching by Message-ID. + (if (stringp (car articles)) + 'headers + (while articles + (when (and (file-exists-p + (setq file (concat (file-name-as-directory + nnmh-current-directory) + (int-to-string + (setq article (pop articles)))))) + (not (file-directory-p file))) + (insert (format "221 %d Article retrieved.\n" article)) + (setq beg (point)) + (nnheader-insert-head file) + (goto-char beg) + (if (search-forward "\n\n" nil t) + (forward-char -1) + (goto-char (point-max)) + (insert "\n\n")) + (insert ".\n") + (delete-region (point) (point-max))) + (setq count (1+ count)) + + (and large + (zerop (% count 20)) + (message "nnmh: Receiving headers... %d%%" + (/ (* count 100) number)))) + + (when large + (message "nnmh: Receiving headers...done")) + + (nnheader-fold-continuation-lines) + 'headers)))) + +(deffoo nnmh-open-server (server &optional defs) + (nnoo-change-server 'nnmh server defs) + (when (not (file-exists-p nnmh-directory)) + (condition-case () + (make-directory nnmh-directory t) + (error t))) + (cond + ((not (file-exists-p nnmh-directory)) + (nnmh-close-server) + (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) + ((not (file-directory-p (file-truename nnmh-directory))) + (nnmh-close-server) + (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory)) + (t + (nnheader-report 'nnmh "Opened server %s using directory %s" + server nnmh-directory) + t))) + +(deffoo nnmh-request-article (id &optional newsgroup server buffer) + (nnmh-possibly-change-directory newsgroup server) + (let ((file (if (stringp id) + nil + (concat nnmh-current-directory (int-to-string id)))) + (pathname-coding-system 'binary) + (nntp-server-buffer (or buffer nntp-server-buffer))) + (and (stringp file) + (file-exists-p file) + (not (file-directory-p file)) + (save-excursion (nnmail-find-file file)) + (string-to-int (file-name-nondirectory file))))) + +(deffoo nnmh-request-group (group &optional server dont-check) + (let ((pathname (nnmail-group-pathname group nnmh-directory)) + (pathname-coding-system 'binary) + dir) + (cond + ((not (file-directory-p pathname)) + (nnheader-report + 'nnmh "Can't select group (no such directory): %s" group)) + (t + (setq nnmh-current-directory pathname) + (and nnmh-get-new-mail + nnmh-be-safe + (nnmh-update-gnus-unreads group)) + (cond + (dont-check + (nnheader-report 'nnmh "Selected group %s" group) + t) + (t + ;; Re-scan the directory if it's on a foreign system. + (nnheader-re-read-dir pathname) + (setq dir + (sort + (mapcar (lambda (name) (string-to-int name)) + (directory-files pathname nil "^[0-9]+$" t)) + '<)) + (cond + (dir + (nnheader-report 'nnmh "Selected group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (length dir) (car dir) + (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) + group)) + (t + (nnheader-report 'nnmh "Empty group %s" group) + (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) + +(deffoo nnmh-request-scan (&optional group server) + (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) + +(deffoo nnmh-request-list (&optional server dir) + (nnheader-insert "") + (let ((pathname-coding-system 'binary) + (nnmh-toplev + (file-truename (or dir (file-name-as-directory nnmh-directory))))) + (nnmh-request-list-1 nnmh-toplev)) + (setq nnmh-group-alist (nnmail-get-active)) + t) + +(defvar nnmh-toplev) +(defun nnmh-request-list-1 (dir) + (setq dir (expand-file-name dir)) + ;; Recurse down all directories. + (let ((dirs (and (file-readable-p dir) + (> (nth 1 (file-attributes (file-chase-links dir))) 2) + (directory-files dir t nil t))) + rdir) + ;; Recurse down directories. + (while (setq rdir (pop dirs)) + (when (and (not (member (file-name-nondirectory rdir) '("." ".."))) + (file-directory-p rdir) + (file-readable-p rdir) + (equal (file-truename rdir) + (file-truename dir))) + (nnmh-request-list-1 rdir)))) + ;; For each directory, generate an active file line. + (unless (string= (expand-file-name nnmh-toplev) dir) + (let ((files (mapcar + (lambda (name) (string-to-int name)) + (directory-files dir nil "^[0-9]+$" t)))) + (when files + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-max)) + (insert + (format + "%s %d %d y\n" + (progn + (string-match + (regexp-quote + (file-truename (file-name-as-directory + (expand-file-name nnmh-toplev)))) + dir) + (nnheader-replace-chars-in-string + (gnus-decode-coding-string (substring dir (match-end 0)) + nnmail-pathname-coding-system) + ?/ ?.)) + (apply 'max files) + (apply 'min files))))))) + t) + +(deffoo nnmh-request-newgroups (date &optional server) + (nnmh-request-list server)) + +(deffoo nnmh-request-expire-articles (articles newsgroup + &optional server force) + (nnmh-possibly-change-directory newsgroup server) + (let* ((active-articles + (mapcar + (function + (lambda (name) + (string-to-int name))) + (directory-files nnmh-current-directory nil "^[0-9]+$" t))) + (is-old t) + article rest mod-time) + (nnmail-activate 'nnmh) + + (while (and articles is-old) + (setq article (concat nnmh-current-directory + (int-to-string (car articles)))) + (when (setq mod-time (nth 5 (file-attributes article))) + (if (and (nnmh-deletable-article-p newsgroup (car articles)) + (setq is-old + (nnmail-expired-article-p newsgroup mod-time force))) + (progn + (nnheader-message 5 "Deleting article %s in %s..." + article newsgroup) + (condition-case () + (funcall nnmail-delete-file-function article) + (file-error + (nnheader-message 1 "Couldn't delete article %s in %s" + article newsgroup) + (push (car articles) rest)))) + (push (car articles) rest))) + (setq articles (cdr articles))) + (message "") + (nconc rest articles))) + +(deffoo nnmh-close-group (group &optional server) + t) + +(deffoo nnmh-request-move-article + (article group server accept-form &optional last) + (let ((buf (get-buffer-create " *nnmh move*")) + result) + (and + (nnmh-deletable-article-p group article) + (nnmh-request-article article group server) + (save-excursion + (set-buffer buf) + (erase-buffer) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (progn + (nnmh-possibly-change-directory group server) + (condition-case () + (funcall nnmail-delete-file-function + (concat nnmh-current-directory (int-to-string article))) + (file-error nil)))) + result)) + +(deffoo nnmh-request-accept-article (group &optional server last noinsert) + (nnmh-possibly-change-directory group server) + (nnmail-check-syntax) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (prog1 + (if (stringp group) + (and + (nnmail-activate 'nnmh) + (if noinsert + (nnmh-active-number group) + (car (nnmh-save-mail + (list (cons group (nnmh-active-number group))) + noinsert)))) + (and + (nnmail-activate 'nnmh) + (let ((res (nnmail-article-group 'nnmh-active-number))) + (if (and (null res) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + 'junk + (car (nnmh-save-mail res noinsert)))))) + (when (and last nnmail-cache-accepted-message-ids) + (nnmail-cache-close)))) + +(deffoo nnmh-request-replace-article (article group buffer) + (nnmh-possibly-change-directory group) + (save-excursion + (set-buffer buffer) + (nnmh-possibly-create-directory group) + (ignore-errors + (nnmail-write-region + (point-min) (point-max) + (concat nnmh-current-directory (int-to-string article)) + nil (if (nnheader-be-verbose 5) nil 'nomesg)) + t))) + +(deffoo nnmh-request-create-group (group &optional server args) + (nnmail-activate 'nnmh) + (unless (assoc group nnmh-group-alist) + (let (active) + (push (list group (setq active (cons 1 0))) + nnmh-group-alist) + (nnmh-possibly-create-directory group) + (nnmh-possibly-change-directory group server) + (let ((articles (mapcar + (lambda (file) + (string-to-int file)) + (directory-files + nnmh-current-directory nil "^[0-9]+$")))) + (when articles + (setcar active (apply 'min articles)) + (setcdr active (apply 'max articles)))))) + t) + +(deffoo nnmh-request-delete-group (group &optional force server) + (nnmh-possibly-change-directory group server) + ;; Delete all articles in GROUP. + (if (not force) + () ; Don't delete the articles. + (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) + (while articles + (when (file-writable-p (car articles)) + (nnheader-message 5 "Deleting article %s in %s..." + (car articles) group) + (funcall nnmail-delete-file-function (car articles))) + (setq articles (cdr articles)))) + ;; Try to delete the directory itself. + (ignore-errors + (delete-directory nnmh-current-directory))) + ;; Remove the group from all structures. + (setq nnmh-group-alist + (delq (assoc group nnmh-group-alist) nnmh-group-alist) + nnmh-current-directory nil) + t) + +(deffoo nnmh-request-rename-group (group new-name &optional server) + (nnmh-possibly-change-directory group server) + (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) + (old-dir (nnmail-group-pathname group nnmh-directory))) + (when (ignore-errors + (make-directory new-dir t) + t) + ;; We move the articles file by file instead of renaming + ;; the directory -- there may be subgroups in this group. + ;; One might be more clever, I guess. + (let ((files (nnheader-article-to-file-alist old-dir))) + (while files + (rename-file + (concat old-dir (cdar files)) + (concat new-dir (cdar files))) + (pop files))) + (when (<= (length (directory-files old-dir)) 2) + (ignore-errors + (delete-directory old-dir))) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnmh-group-alist))) + (when entry + (setcar entry new-name)) + (setq nnmh-current-directory nil) + t)))) + +(nnoo-define-skeleton nnmh) + + +;;; Internal functions. + +(defun nnmh-possibly-change-directory (newsgroup &optional server) + (when (and server + (not (nnmh-server-opened server))) + (nnmh-open-server server)) + (when newsgroup + (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) + (pathname-coding-system 'binary)) + (if (file-directory-p pathname) + (setq nnmh-current-directory pathname) + (error "No such newsgroup: %s" newsgroup))))) + +(defun nnmh-possibly-create-directory (group) + (let (dir dirs) + (setq dir (nnmail-group-pathname group nnmh-directory)) + (while (not (file-directory-p dir)) + (push dir dirs) + (setq dir (file-name-directory (directory-file-name dir)))) + (while dirs + (when (make-directory (directory-file-name (car dirs))) + (error "Could not create directory %s" (car dirs))) + (nnheader-message 5 "Creating mail directory %s" (car dirs)) + (setq dirs (cdr dirs))))) + +(defun nnmh-save-mail (group-art &optional noinsert) + "Called narrowed to an article." + (unless noinsert + (nnmail-insert-lines) + (nnmail-insert-xref group-art)) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnmh-prepare-save-mail-hook) + (goto-char (point-min)) + (while (looking-at "From ") + (replace-match "X-From-Line: ") + (forward-line 1)) + ;; We save the article in all the newsgroups it belongs in. + (let ((ga group-art) + first) + (while ga + (nnmh-possibly-create-directory (caar ga)) + (let ((file (concat (nnmail-group-pathname + (caar ga) nnmh-directory) + (int-to-string (cdar ga))))) + (if first + ;; It was already saved, so we just make a hard link. + (funcall nnmail-crosspost-link-function first file t) + ;; Save the article. + (nnmail-write-region (point-min) (point-max) file nil nil) + (setq first file))) + (setq ga (cdr ga)))) + group-art) + +(defun nnmh-active-number (group) + "Compute the next article number in GROUP." + (let ((active (cadr (assoc group nnmh-group-alist))) + (dir (nnmail-group-pathname group nnmh-directory)) + (pathname-coding-system 'binary)) + (unless active + ;; The group wasn't known to nnmh, so we just create an active + ;; entry for it. + (setq active (cons 1 0)) + (push (list group active) nnmh-group-alist) + (unless (file-exists-p dir) + (make-directory dir)) + ;; Find the highest number in the group. + (let ((files (sort + (mapcar + (lambda (f) + (string-to-int f)) + (directory-files dir nil "^[0-9]+$")) + '>))) + (when files + (setcdr active (car files))))) + (setcdr active (1+ (cdr active))) + (while (file-exists-p + (concat (nnmail-group-pathname group nnmh-directory) + (int-to-string (cdr active)))) + (setcdr active (1+ (cdr active)))) + (cdr active))) + +(defun nnmh-update-gnus-unreads (group) + ;; Go through the .nnmh-articles file and compare with the actual + ;; articles in this folder. The articles that are "new" will be + ;; marked as unread by Gnus. + (let* ((dir nnmh-current-directory) + (files (sort (mapcar (function (lambda (name) (string-to-int name))) + (directory-files nnmh-current-directory + nil "^[0-9]+$" t)) + '<)) + (nnmh-file (concat dir ".nnmh-articles")) + new articles) + ;; Load the .nnmh-articles file. + (when (file-exists-p nnmh-file) + (setq articles + (let (nnmh-newsgroup-articles) + (ignore-errors (load nnmh-file nil t t)) + nnmh-newsgroup-articles))) + ;; Add all new articles to the `new' list. + (let ((art files)) + (while art + (unless (assq (car art) articles) + (push (car art) new)) + (setq art (cdr art)))) + ;; Remove all deleted articles. + (let ((art articles)) + (while art + (unless (memq (caar art) files) + (setq articles (delq (car art) articles))) + (setq art (cdr art)))) + ;; Check whether the articles really are the ones that Gnus thinks + ;; they are by looking at the time-stamps. + (let ((arts articles) + art) + (while (setq art (pop arts)) + (when (not (equal + (nth 5 (file-attributes + (concat dir (int-to-string (car art))))) + (cdr art))) + (setq articles (delq art articles)) + (push (car art) new)))) + ;; Go through all the new articles and add them, and their + ;; time-stamps, to the list. + (setq articles + (nconc articles + (mapcar + (lambda (art) + (cons art + (nth 5 (file-attributes + (concat dir (int-to-string art)))))) + new))) + ;; Make Gnus mark all new articles as unread. + (when new + (gnus-make-articles-unread + (gnus-group-prefixed-name group (list 'nnmh "")) + (setq new (sort new '<)))) + ;; Sort the article list with highest numbers first. + (setq articles (sort articles (lambda (art1 art2) + (> (car art1) (car art2))))) + ;; Finally write this list back to the .nnmh-articles file. + (nnheader-temp-write nnmh-file + (insert ";; Gnus article active file for " group "\n\n") + (insert "(setq nnmh-newsgroup-articles '") + (gnus-prin1 articles) + (insert ")\n")))) + +(defun nnmh-deletable-article-p (group article) + "Say whether ARTICLE in GROUP can be deleted." + (let ((path (concat nnmh-current-directory (int-to-string article)))) + ;; Writable. + (and (file-writable-p path) + (or + ;; We can never delete the last article in the group. + (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) + article)) + ;; Well, we can. + nnmh-allow-delete-final)))) + +(provide 'nnmh) + +;;; nnmh.el ends here diff --git a/lisp/nnml.el b/lisp/nnml.el new file mode 100644 index 0000000..cee1e1f --- /dev/null +++ b/lisp/nnml.el @@ -0,0 +1,815 @@ +;;; nnml.el --- mail spool access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Based on nnspool.el by Masanobu UMEDA . +;; For an overview of what the interface functions do, please see the +;; Gnus sources. + +;;; Code: + +(require 'nnheader) +(require 'nnmail) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnml) + +(defvoo nnml-directory message-directory + "Spool directory for the nnml mail backend.") + +(defvoo nnml-active-file + (concat (file-name-as-directory nnml-directory) "active") + "Mail active file.") + +(defvoo nnml-newsgroups-file + (concat (file-name-as-directory nnml-directory) "newsgroups") + "Mail newsgroups description file.") + +(defvoo nnml-get-new-mail t + "If non-nil, nnml will check the incoming mail file and split the mail.") + +(defvoo nnml-nov-is-evil nil + "If non-nil, Gnus will never generate and use nov databases for mail groups. +Using nov databases will speed up header fetching considerably. +This variable shouldn't be flipped much. If you have, for some reason, +set this to t, and want to set it to nil again, you should always run +the `nnml-generate-nov-databases' command. The function will go +through all nnml directories and generate nov databases for them +all. This may very well take some time.") + +(defvoo nnml-prepare-save-mail-hook nil + "Hook run narrowed to an article before saving.") + +(defvoo nnml-inhibit-expiry nil + "If non-nil, inhibit expiry.") + + + + +(defconst nnml-version "nnml 1.0" + "nnml version.") + +(defvoo nnml-nov-file-name ".overview") + +(defvoo nnml-current-directory nil) +(defvoo nnml-current-group nil) +(defvoo nnml-status-string "") +(defvoo nnml-nov-buffer-alist nil) +(defvoo nnml-group-alist nil) +(defvoo nnml-active-timestamp nil) +(defvoo nnml-article-file-alist nil) + +(defvoo nnml-generate-active-function 'nnml-generate-active-info) + + + +;;; Interface functions. + +(nnoo-define-basics nnml) + +(deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) + (when (nnml-possibly-change-directory group server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((file nil) + (number (length sequence)) + (count 0) + ;; 1997/8/12 by MORIOKA Tomohiko + ;; for XEmacs/mule. + (pathname-coding-system 'binary) + beg article) + (if (stringp (car sequence)) + 'headers + (if (nnml-retrieve-headers-with-nov sequence fetch-old) + 'nov + (while sequence + (setq article (car sequence)) + (setq file (nnml-article-to-file article)) + (when (and file + (file-exists-p file) + (not (file-directory-p file))) + (insert (format "221 %d Article retrieved.\n" article)) + (setq beg (point)) + (nnheader-insert-head file) + (goto-char beg) + (if (search-forward "\n\n" nil t) + (forward-char -1) + (goto-char (point-max)) + (insert "\n\n")) + (insert ".\n") + (delete-region (point) (point-max))) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (zerop (% count 20)) + (nnheader-message 6 "nnml: Receiving headers... %d%%" + (/ (* count 100) number)))) + + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (nnheader-message 6 "nnml: Receiving headers...done")) + + (nnheader-fold-continuation-lines) + 'headers)))))) + +(deffoo nnml-open-server (server &optional defs) + (nnoo-change-server 'nnml server defs) + (when (not (file-exists-p nnml-directory)) + (condition-case () + (make-directory nnml-directory t) + (error))) + (cond + ((not (file-exists-p nnml-directory)) + (nnml-close-server) + (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory)) + ((not (file-directory-p (file-truename nnml-directory))) + (nnml-close-server) + (nnheader-report 'nnml "Not a directory: %s" nnml-directory)) + (t + (nnheader-report 'nnml "Opened server %s using directory %s" + server nnml-directory) + t))) + +(defun nnml-request-regenerate (server) + (nnml-possibly-change-directory nil server) + (nnml-generate-nov-databases) + t) + +(deffoo nnml-request-article (id &optional group server buffer) + (nnml-possibly-change-directory group server) + (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) + ;; 1997/8/12 by MORIOKA Tomohiko + ;; for XEmacs/mule. + (pathname-coding-system 'binary) + path gpath group-num) + (if (stringp id) + (when (and (setq group-num (nnml-find-group-number id)) + (cdr + (assq (cdr group-num) + (nnheader-article-to-file-alist + (setq gpath + (nnmail-group-pathname + (car group-num) + nnml-directory)))))) + (setq path (concat gpath (int-to-string (cdr group-num))))) + (setq path (nnml-article-to-file id))) + (cond + ((not path) + (nnheader-report 'nnml "No such article: %s" id)) + ((not (file-exists-p path)) + (nnheader-report 'nnml "No such file: %s" path)) + ((file-directory-p path) + (nnheader-report 'nnml "File is a directory: %s" path)) + ((not (save-excursion (nnmail-find-file path))) + (nnheader-report 'nnml "Couldn't read file: %s" path)) + (t + (nnheader-report 'nnml "Article %s retrieved" id) + ;; We return the article number. + (cons (if group-num (car group-num) group) + (string-to-int (file-name-nondirectory path))))))) + +(deffoo nnml-request-group (group &optional server dont-check) + (let ((pathname-coding-system 'binary)) + (cond + ((not (nnml-possibly-change-directory group server)) + (nnheader-report 'nnml "Invalid group (no such directory)")) + ((not (file-exists-p nnml-current-directory)) + (nnheader-report 'nnml "Directory %s does not exist" + nnml-current-directory)) + ((not (file-directory-p nnml-current-directory)) + (nnheader-report 'nnml "%s is not a directory" nnml-current-directory)) + (dont-check + (nnheader-report 'nnml "Group %s selected" group) + t) + (t + (nnheader-re-read-dir nnml-current-directory) + (nnmail-activate 'nnml) + (let ((active (nth 1 (assoc group nnml-group-alist)))) + (if (not active) + (nnheader-report 'nnml "No such group: %s" group) + (nnheader-report 'nnml "Selected group %s" group) + (nnheader-insert "211 %d %d %d %s\n" + (max (1+ (- (cdr active) (car active))) 0) + (car active) (cdr active) group))))))) + +(deffoo nnml-request-scan (&optional group server) + (setq nnml-article-file-alist nil) + (nnml-possibly-change-directory group server) + (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) + +(deffoo nnml-close-group (group &optional server) + (setq nnml-article-file-alist nil) + t) + +(deffoo nnml-request-create-group (group &optional server args) + (nnmail-activate 'nnml) + (unless (assoc group nnml-group-alist) + (let (active) + (push (list group (setq active (cons 1 0))) + nnml-group-alist) + (nnml-possibly-create-directory group) + (nnml-possibly-change-directory group server) + (let ((articles (nnheader-directory-articles nnml-current-directory))) + (when articles + (setcar active (apply 'min articles)) + (setcdr active (apply 'max articles)))) + (nnmail-save-active nnml-group-alist nnml-active-file))) + t) + +(deffoo nnml-request-list (&optional server) + (save-excursion + ;; 1997/8/12 by MORIOKA Tomohiko + ;; for XEmacs/mule. + (let ((nnmail-file-coding-system nnmail-active-file-coding-system) + (pathname-coding-system 'binary)) ; for XEmacs/mule + (nnmail-find-file nnml-active-file) + ) + (setq nnml-group-alist (nnmail-get-active)) + t)) + +(deffoo nnml-request-newgroups (date &optional server) + (nnml-request-list server)) + +(deffoo nnml-request-list-newsgroups (&optional server) + (save-excursion + (nnmail-find-file nnml-newsgroups-file))) + +(deffoo nnml-request-expire-articles (articles group + &optional server force) + (nnml-possibly-change-directory group server) + (let ((active-articles + (nnheader-directory-articles nnml-current-directory)) + (is-old t) + article rest mod-time number) + (nnmail-activate 'nnml) + + (while (and articles is-old) + (when (setq article (nnml-article-to-file (setq number (pop articles)))) + (when (setq mod-time (nth 5 (file-attributes article))) + (if (and (nnml-deletable-article-p group number) + (setq is-old + (nnmail-expired-article-p group mod-time force + nnml-inhibit-expiry))) + (progn + (nnheader-message 5 "Deleting article %s in %s" + article group) + (condition-case () + (funcall nnmail-delete-file-function article) + (file-error + (push number rest))) + (setq active-articles (delq number active-articles)) + (nnml-nov-delete-article group number)) + (push number rest))))) + (let ((active (nth 1 (assoc group nnml-group-alist)))) + (when active + (setcar active (or (and active-articles + (apply 'min active-articles)) + (1+ (cdr active))))) + (nnmail-save-active nnml-group-alist nnml-active-file)) + (nnml-save-nov) + (nconc rest articles))) + +(deffoo nnml-request-move-article + (article group server accept-form &optional last) + (let ((buf (get-buffer-create " *nnml move*")) + result) + (nnml-possibly-change-directory group server) + (nnml-update-file-alist) + (and + (nnml-deletable-article-p group article) + (nnml-request-article article group server) + (save-excursion + (set-buffer buf) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (progn + (nnml-possibly-change-directory group server) + (condition-case () + (funcall nnmail-delete-file-function + (nnml-article-to-file article)) + (file-error nil)) + (nnml-nov-delete-article group article) + (when last + (nnml-save-nov) + (nnmail-save-active nnml-group-alist nnml-active-file)))) + result)) + +(deffoo nnml-request-accept-article (group &optional server last) + (nnml-possibly-change-directory group server) + (nnmail-check-syntax) + (let (result) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (if (stringp group) + (and + (nnmail-activate 'nnml) + (setq result (car (nnml-save-mail + (list (cons group (nnml-active-number group)))))) + (progn + (nnmail-save-active nnml-group-alist nnml-active-file) + (and last (nnml-save-nov)))) + (and + (nnmail-activate 'nnml) + (if (and (not (setq result (nnmail-article-group 'nnml-active-number))) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result (car (nnml-save-mail result)))) + (when last + (nnmail-save-active nnml-group-alist nnml-active-file) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-close)) + (nnml-save-nov)))) + result)) + +(deffoo nnml-request-replace-article (article group buffer) + (nnml-possibly-change-directory group) + (save-excursion + (set-buffer buffer) + (nnml-possibly-create-directory group) + (let ((chars (nnmail-insert-lines)) + (art (concat (int-to-string article) "\t")) + headers) + (when (condition-case () + (progn + (nnmail-write-region + (point-min) (point-max) + (or (nnml-article-to-file article) + (concat nnml-current-directory + (int-to-string article))) + nil (if (nnheader-be-verbose 5) nil 'nomesg)) + t) + (error nil)) + (setq headers (nnml-parse-head chars article)) + ;; Replace the NOV line in the NOV file. + (save-excursion + (set-buffer (nnml-open-nov group)) + (goto-char (point-min)) + (if (or (looking-at art) + (search-forward (concat "\n" art) nil t)) + ;; Delete the old NOV line. + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))) + ;; The line isn't here, so we have to find out where + ;; we should insert it. (This situation should never + ;; occur, but one likes to make sure...) + (while (and (looking-at "[0-9]+\t") + (< (string-to-int + (buffer-substring + (match-beginning 0) (match-end 0))) + article) + (zerop (forward-line 1))))) + (beginning-of-line) + (nnheader-insert-nov headers) + (nnml-save-nov) + t))))) + +(deffoo nnml-request-delete-group (group &optional force server) + (nnml-possibly-change-directory group server) + (when force + ;; Delete all articles in GROUP. + (let ((articles + (directory-files + nnml-current-directory t + (concat nnheader-numerical-short-files + "\\|" (regexp-quote nnml-nov-file-name) "$"))) + article) + (while articles + (setq article (pop articles)) + (when (file-writable-p article) + (nnheader-message 5 "Deleting article %s in %s..." article group) + (funcall nnmail-delete-file-function article)))) + ;; Try to delete the directory itself. + (condition-case () + (delete-directory nnml-current-directory) + (error nil))) + ;; Remove the group from all structures. + (setq nnml-group-alist + (delq (assoc group nnml-group-alist) nnml-group-alist) + nnml-current-group nil + nnml-current-directory nil) + ;; Save the active file. + (nnmail-save-active nnml-group-alist nnml-active-file) + t) + +(deffoo nnml-request-rename-group (group new-name &optional server) + (nnml-possibly-change-directory group server) + (let ((new-dir (nnmail-group-pathname new-name nnml-directory)) + (old-dir (nnmail-group-pathname group nnml-directory))) + (when (condition-case () + (progn + (make-directory new-dir t) + t) + (error nil)) + ;; We move the articles file by file instead of renaming + ;; the directory -- there may be subgroups in this group. + ;; One might be more clever, I guess. + (let ((files (nnheader-article-to-file-alist old-dir))) + (while files + (rename-file + (concat old-dir (cdar files)) + (concat new-dir (cdar files))) + (pop files))) + ;; Move .overview file. + (let ((overview (concat old-dir nnml-nov-file-name))) + (when (file-exists-p overview) + (rename-file overview (concat new-dir nnml-nov-file-name)))) + (when (<= (length (directory-files old-dir)) 2) + (condition-case () + (delete-directory old-dir) + (error nil))) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnml-group-alist))) + (when entry + (setcar entry new-name)) + (setq nnml-current-directory nil + nnml-current-group nil) + ;; Save the new group alist. + (nnmail-save-active nnml-group-alist nnml-active-file) + t)))) + +(deffoo nnml-set-status (article name value &optional group server) + (nnml-possibly-change-directory group server) + (let ((file (nnml-article-to-file article))) + (cond + ((not (file-exists-p file)) + (nnheader-report 'nnml "File %s does not exist" file)) + (t + (nnheader-temp-write file + (nnheader-insert-file-contents file) + (nnmail-replace-status name value)) + t)))) + + +;;; Internal functions. + +(defun nnml-article-to-file (article) + (nnml-update-file-alist) + (let (file) + (if (setq file (cdr (assq article nnml-article-file-alist))) + (concat nnml-current-directory file) + ;; Just to make sure nothing went wrong when reading over NFS -- + ;; check once more. + (when (file-exists-p + (setq file (concat nnml-current-directory "/" + (number-to-string article)))) + (nnml-update-file-alist t) + file)))) + +(defun nnml-deletable-article-p (group article) + "Say whether ARTICLE in GROUP can be deleted." + (let (path) + (when (setq path (nnml-article-to-file article)) + (when (file-writable-p path) + (or (not nnmail-keep-last-article) + (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) + article))))))) + +;; Find an article number in the current group given the Message-ID. +(defun nnml-find-group-number (id) + (save-excursion + (set-buffer (get-buffer-create " *nnml id*")) + (buffer-disable-undo (current-buffer)) + (let ((alist nnml-group-alist) + number) + ;; We want to look through all .overview files, but we want to + ;; start with the one in the current directory. It seems most + ;; likely that the article we are looking for is in that group. + (if (setq number (nnml-find-id nnml-current-group id)) + (cons nnml-current-group number) + ;; It wasn't there, so we look through the other groups as well. + (while (and (not number) + alist) + (or (string= (caar alist) nnml-current-group) + (setq number (nnml-find-id (caar alist) id))) + (or number + (setq alist (cdr alist)))) + (and number + (cons (caar alist) number)))))) + +(defun nnml-find-id (group id) + (erase-buffer) + (let ((nov (concat (nnmail-group-pathname group nnml-directory) + nnml-nov-file-name)) + number found) + (when (file-exists-p nov) + (nnheader-insert-file-contents nov) + (while (and (not found) + (search-forward id nil t)) ; We find the ID. + ;; And the id is in the fourth field. + (if (not (and (search-backward "\t" nil t 4) + (not (search-backward"\t" (gnus-point-at-bol) t)))) + (forward-line 1) + (beginning-of-line) + (setq found t) + ;; We return the article number. + (setq number + (condition-case () + (read (current-buffer)) + (error nil))))) + number))) + +(defun nnml-retrieve-headers-with-nov (articles &optional fetch-old) + (if (or gnus-nov-is-evil nnml-nov-is-evil) + nil + (let ((nov (concat nnml-current-directory nnml-nov-file-name))) + (when (file-exists-p nov) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (nnheader-insert-file-contents nov) + (if (and fetch-old + (not (numberp fetch-old))) + t ; Don't remove anything. + (nnheader-nov-delete-outside-range + (if fetch-old (max 1 (- (car articles) fetch-old)) + (car articles)) + (car (last articles))) + t)))))) + +(defun nnml-possibly-change-directory (group &optional server) + (when (and server + (not (nnml-server-opened server))) + (nnml-open-server server)) + (if (not group) + t + (let ((pathname (nnmail-group-pathname group nnml-directory)) + ;; 1997/8/14 by MORIOKA Tomohiko + ;; for XEmacs/mule. + (pathname-coding-system 'binary)) + (when (not (equal pathname nnml-current-directory)) + (setq nnml-current-directory pathname + nnml-current-group group + nnml-article-file-alist nil)) + (file-exists-p nnml-current-directory)))) + +(defun nnml-possibly-create-directory (group) + (let (dir dirs) + (setq dir (nnmail-group-pathname group nnml-directory)) + (while (not (file-directory-p dir)) + (push dir dirs) + (setq dir (file-name-directory (directory-file-name dir)))) + (while dirs + (make-directory (directory-file-name (car dirs))) + (nnheader-message 5 "Creating mail directory %s" (car dirs)) + (setq dirs (cdr dirs))))) + +(defun nnml-save-mail (group-art) + "Called narrowed to an article." + (let (chars headers) + (setq chars (nnmail-insert-lines)) + (nnmail-insert-xref group-art) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnml-prepare-save-mail-hook) + (goto-char (point-min)) + (while (looking-at "From ") + (replace-match "X-From-Line: ") + (forward-line 1)) + ;; We save the article in all the groups it belongs in. + (let ((ga group-art) + first) + (while ga + (nnml-possibly-create-directory (caar ga)) + (let ((file (concat (nnmail-group-pathname + (caar ga) nnml-directory) + (int-to-string (cdar ga))))) + (if first + ;; It was already saved, so we just make a hard link. + (funcall nnmail-crosspost-link-function first file t) + ;; Save the article. + (nnmail-write-region (point-min) (point-max) file nil + (if (nnheader-be-verbose 5) nil 'nomesg)) + (setq first file))) + (setq ga (cdr ga)))) + ;; Generate a nov line for this article. We generate the nov + ;; line after saving, because nov generation destroys the + ;; header. + (setq headers (nnml-parse-head chars)) + ;; Output the nov line to all nov databases that should have it. + (let ((ga group-art)) + (while ga + (nnml-add-nov (caar ga) (cdar ga) headers) + (setq ga (cdr ga)))) + group-art)) + +(defun nnml-active-number (group) + "Compute the next article number in GROUP." + (let ((active (cadr (assoc group nnml-group-alist)))) + ;; The group wasn't known to nnml, so we just create an active + ;; entry for it. + (unless active + ;; Perhaps the active file was corrupt? See whether + ;; there are any articles in this group. + (nnml-possibly-create-directory group) + (nnml-possibly-change-directory group) + (unless nnml-article-file-alist + (setq nnml-article-file-alist + (sort + (nnheader-article-to-file-alist nnml-current-directory) + 'car-less-than-car))) + (setq active + (if nnml-article-file-alist + (cons (caar nnml-article-file-alist) + (caar (last nnml-article-file-alist))) + (cons 1 0))) + (push (list group active) nnml-group-alist)) + (setcdr active (1+ (cdr active))) + (while (file-exists-p + (concat (nnmail-group-pathname group nnml-directory) + (int-to-string (cdr active)))) + (setcdr active (1+ (cdr active)))) + (cdr active))) + +(defun nnml-add-nov (group article headers) + "Add a nov line for the GROUP base." + (save-excursion + (set-buffer (nnml-open-nov group)) + (goto-char (point-max)) + (mail-header-set-number headers article) + (nnheader-insert-nov headers))) + +(defsubst nnml-header-value () + (buffer-substring (match-end 0) (progn (end-of-line) (point)))) + +(defun nnml-parse-head (chars &optional number) + "Parse the head of the current buffer." + (save-excursion + (save-restriction + (goto-char (point-min)) + (narrow-to-region + (point) + (1- (or (search-forward "\n\n" nil t) (point-max)))) + ;; Fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + ;; Remove any tabs; they are too confusing. + (subst-char-in-region (point-min) (point-max) ?\t ? ) + (let ((headers (nnheader-parse-head t))) + (mail-header-set-chars headers chars) + (mail-header-set-number headers number) + headers)))) + +(defun nnml-open-nov (group) + (or (cdr (assoc group nnml-nov-buffer-alist)) + (let ((buffer (nnheader-find-file-noselect + (concat (nnmail-group-pathname group nnml-directory) + nnml-nov-file-name)))) + (save-excursion + (set-buffer buffer) + (buffer-disable-undo (current-buffer))) + (push (cons group buffer) nnml-nov-buffer-alist) + buffer))) + +(defun nnml-save-nov () + (save-excursion + (while nnml-nov-buffer-alist + (when (buffer-name (cdar nnml-nov-buffer-alist)) + (set-buffer (cdar nnml-nov-buffer-alist)) + (when (buffer-modified-p) + (nnmail-write-region 1 (point-max) (buffer-file-name) nil 'nomesg)) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist))))) + +;;;###autoload +(defun nnml-generate-nov-databases () + "Generate NOV databases in all nnml directories." + (interactive) + ;; Read the active file to make sure we don't re-use articles + ;; numbers in empty groups. + (nnmail-activate 'nnml) + (nnml-open-server (or (nnoo-current-server 'nnml) "")) + (setq nnml-directory (expand-file-name nnml-directory)) + ;; Recurse down the directories. + (nnml-generate-nov-databases-1 nnml-directory nil t) + ;; Save the active file. + (nnmail-save-active nnml-group-alist nnml-active-file)) + +(defun nnml-generate-nov-databases-1 (dir &optional seen no-active) + "Regenerate the NOV database in DIR." + (interactive "DRegenerate NOV in: ") + (setq dir (file-name-as-directory dir)) + ;; Only scan this sub-tree if we haven't been here yet. + (unless (member (file-truename dir) seen) + (push (file-truename dir) seen) + ;; We descend recursively + (let ((dirs (directory-files dir t nil t)) + dir) + (while (setq dir (pop dirs)) + (when (and (not (member (file-name-nondirectory dir) '("." ".."))) + (file-directory-p dir)) + (nnml-generate-nov-databases-1 dir seen)))) + ;; Do this directory. + (let ((files (sort (nnheader-article-to-file-alist dir) + 'car-less-than-car))) + (when files + (funcall nnml-generate-active-function dir) + ;; Generate the nov file. + (nnml-generate-nov-file dir files) + (unless no-active + (nnmail-save-active nnml-group-alist nnml-active-file)))))) + +(defvar files) +(defun nnml-generate-active-info (dir) + ;; Update the active info for this group. + (let ((group (nnheader-file-to-group + (directory-file-name dir) nnml-directory))) + (setq nnml-group-alist + (delq (assoc group nnml-group-alist) nnml-group-alist)) + (push (list group + (cons (caar files) + (let ((f files)) + (while (cdr f) (setq f (cdr f))) + (caar f)))) + nnml-group-alist))) + +(defun nnml-generate-nov-file (dir files) + (let* ((dir (file-name-as-directory dir)) + (nov (concat dir nnml-nov-file-name)) + (nov-buffer (get-buffer-create " *nov*")) + chars file headers) + (save-excursion + ;; Init the nov buffer. + (set-buffer nov-buffer) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (set-buffer nntp-server-buffer) + ;; Delete the old NOV file. + (when (file-exists-p nov) + (funcall nnmail-delete-file-function nov)) + (while files + (unless (file-directory-p (setq file (concat dir (cdar files)))) + (erase-buffer) + (nnheader-insert-file-contents file) + (narrow-to-region + (goto-char (point-min)) + (progn + (search-forward "\n\n" nil t) + (setq chars (- (point-max) (point))) + (max 1 (1- (point))))) + (unless (zerop (buffer-size)) + (goto-char (point-min)) + (setq headers (nnml-parse-head chars (caar files))) + (save-excursion + (set-buffer nov-buffer) + (goto-char (point-max)) + (nnheader-insert-nov headers))) + (widen)) + (setq files (cdr files))) + (save-excursion + (set-buffer nov-buffer) + (nnmail-write-region 1 (point-max) nov nil 'nomesg) + (kill-buffer (current-buffer)))))) + +(defun nnml-nov-delete-article (group article) + (save-excursion + (set-buffer (nnml-open-nov group)) + (when (nnheader-find-nov-line article) + (delete-region (point) (progn (forward-line 1) (point))) + (when (bobp) + (let ((active (cadr (assoc group nnml-group-alist))) + num) + (when active + (if (eobp) + (setf (car active) (1+ (cdr active))) + (when (and (setq num (ignore-errors (read (current-buffer)))) + (numberp num)) + (setf (car active) num))))))) + t)) + +(defun nnml-update-file-alist (&optional force) + (when (or (not nnml-article-file-alist) + force) + (setq nnml-article-file-alist + (nnheader-article-to-file-alist nnml-current-directory)))) + +(provide 'nnml) + +;;; nnml.el ends here diff --git a/lisp/nnoo.el b/lisp/nnoo.el new file mode 100644 index 0000000..251fdc9 --- /dev/null +++ b/lisp/nnoo.el @@ -0,0 +1,279 @@ +;;; nnoo.el --- OO Gnus Backends +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(eval-when-compile (require 'cl)) + +(defvar nnoo-definition-alist nil) +(defvar nnoo-state-alist nil) + +(defmacro defvoo (var init &optional doc &rest map) + "The same as `defvar', only takes list of variables to MAP to." + `(prog1 + ,(if doc + `(defvar ,var ,init ,doc) + `(defvar ,var ,init)) + (nnoo-define ',var ',map))) +(put 'defvoo 'lisp-indent-function 2) +(put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map)) + +(defmacro deffoo (func args &rest forms) + "The same as `defun', only register FUNC." + `(prog1 + (defun ,func ,args ,@forms) + (nnoo-register-function ',func))) +(put 'deffoo 'lisp-indent-function 2) +(put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body)) + +(defun nnoo-register-function (func) + (let ((funcs (nthcdr 3 (assoc (nnoo-backend func) + nnoo-definition-alist)))) + (unless funcs + (error "%s belongs to a backend that hasn't been declared" func)) + (setcar funcs (cons func (car funcs))))) + +(defmacro nnoo-declare (backend &rest parents) + `(eval-and-compile + (push (list ',backend + (mapcar (lambda (p) (list p)) ',parents) + nil nil) + nnoo-definition-alist) + (push (list ',backend "*internal-non-initialized-backend*") + nnoo-state-alist))) +(put 'nnoo-declare 'lisp-indent-function 1) + +(defun nnoo-parents (backend) + (nth 1 (assoc backend nnoo-definition-alist))) + +(defun nnoo-variables (backend) + (nth 2 (assoc backend nnoo-definition-alist))) + +(defun nnoo-functions (backend) + (nth 3 (assoc backend nnoo-definition-alist))) + +(defmacro nnoo-import (backend &rest imports) + `(nnoo-import-1 ',backend ',imports)) +(put 'nnoo-import 'lisp-indent-function 1) + +(defun nnoo-import-1 (backend imports) + (let ((call-function + (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function)) + imp functions function) + (while (setq imp (pop imports)) + (setq functions + (or (cdr imp) + (nnoo-functions (car imp)))) + (while functions + (unless (fboundp (setq function + (nnoo-symbol backend (nnoo-rest-symbol + (car functions))))) + (eval `(deffoo ,function (&rest args) + (,call-function ',backend ',(car functions) args)))) + (pop functions))))) + +(defun nnoo-parent-function (backend function args) + (let ((pbackend (nnoo-backend function))) + (nnoo-change-server pbackend (nnoo-current-server backend) + (cdr (assq pbackend (nnoo-parents backend)))) + (apply function args))) + +(defun nnoo-execute (backend function &rest args) + "Execute FUNCTION on behalf of BACKEND." + (let ((pbackend (nnoo-backend function))) + (nnoo-change-server pbackend (nnoo-current-server backend) + (cdr (assq pbackend (nnoo-parents backend)))) + (apply function args))) + +(defmacro nnoo-map-functions (backend &rest maps) + `(nnoo-map-functions-1 ',backend ',maps)) +(put 'nnoo-map-functions 'lisp-indent-function 1) + +(defun nnoo-map-functions-1 (backend maps) + (let (m margs i) + (while (setq m (pop maps)) + (setq i 0 + margs nil) + (while (< i (length (cdr m))) + (if (numberp (nth i (cdr m))) + (push `(nth ,i args) margs) + (push (nth i (cdr m)) margs)) + (incf i)) + (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) + (&rest args) + (nnoo-parent-function ',backend ',(car m) + ,(cons 'list (nreverse margs)))))))) + +(defun nnoo-backend (symbol) + (string-match "^[^-]+-" (symbol-name symbol)) + (intern (substring (symbol-name symbol) 0 (1- (match-end 0))))) + +(defun nnoo-rest-symbol (symbol) + (string-match "^[^-]+-" (symbol-name symbol)) + (intern (substring (symbol-name symbol) (match-end 0)))) + +(defun nnoo-symbol (backend symbol) + (intern (format "%s-%s" backend symbol))) + +(defun nnoo-define (var map) + (let* ((backend (nnoo-backend var)) + (def (assq backend nnoo-definition-alist)) + (parents (nth 1 def))) + (unless def + (error "%s belongs to a backend that hasn't been declared" var)) + (setcar (nthcdr 2 def) + (delq (assq var (nth 2 def)) (nth 2 def))) + (setcar (nthcdr 2 def) + (cons (cons var (symbol-value var)) + (nth 2 def))) + (while map + (nconc (assq (nnoo-backend (car map)) parents) + (list (list (pop map) var)))))) + +(defun nnoo-change-server (backend server defs) + (let* ((bstate (cdr (assq backend nnoo-state-alist))) + (current (car bstate)) + (parents (nnoo-parents backend)) + (bvariables (nnoo-variables backend)) + state def) + (unless bstate + (push (setq bstate (list backend nil)) + nnoo-state-alist) + (pop bstate)) + (if (equal server current) + t + (nnoo-push-server backend current) + (setq state (or (cdr (assoc server (cddr bstate))) + (nnoo-variables backend))) + (while state + (set (caar state) (cdar state)) + (pop state)) + (setcar bstate server) + (unless (cdr (assoc server (cddr bstate))) + (while (setq def (pop defs)) + (unless (assq (car def) bvariables) + (nconc bvariables + (list (cons (car def) (and (boundp (car def)) + (symbol-value (car def))))))) + (set (car def) (cadr def)))) + (while parents + (nnoo-change-server + (caar parents) server + (mapcar (lambda (def) (list (car def) (symbol-value (cadr def)))) + (cdar parents))) + (pop parents)))) + t) + +(defun nnoo-push-server (backend current) + (let ((bstate (assq backend nnoo-state-alist)) + (defs (nnoo-variables backend))) + ;; Remove the old definition. + (setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate))) + ;; If this is the first time we push the server (i. e., this is + ;; the nil server), then we update the default values of + ;; all the variables to reflect the current values. + (when (equal current "*internal-non-initialized-backend*") + (let ((defaults (nnoo-variables backend)) + def) + (while (setq def (pop defaults)) + (setcdr def (symbol-value (car def)))))) + (let (state) + (while defs + (push (cons (caar defs) (symbol-value (caar defs))) + state) + (pop defs)) + (nconc bstate (list (cons current state)))))) + +(defsubst nnoo-current-server-p (backend server) + (equal (nnoo-current-server backend) server)) + +(defun nnoo-current-server (backend) + (nth 1 (assq backend nnoo-state-alist))) + +(defun nnoo-close-server (backend &optional server) + (unless server + (setq server (nnoo-current-server backend))) + (when server + (let* ((bstate (cdr (assq backend nnoo-state-alist))) + (defs (assoc server (cdr bstate)))) + (when bstate + (setcar bstate nil) + (setcdr bstate (delq defs (cdr bstate))) + (pop defs) + (while defs + (set (car (pop defs)) nil))))) + t) + +(defun nnoo-close (backend) + (setq nnoo-state-alist + (delq (assq backend nnoo-state-alist) + nnoo-state-alist)) + t) + +(defun nnoo-status-message (backend server) + (nnheader-get-report backend)) + +(defun nnoo-server-opened (backend server) + (and (nnoo-current-server-p backend server) + nntp-server-buffer + (buffer-name nntp-server-buffer))) + +(defmacro nnoo-define-basics (backend) + "Define `close-server', `server-opened' and `status-message'." + `(eval-and-compile + (nnoo-define-basics-1 ',backend))) + +(defun nnoo-define-basics-1 (backend) + (let ((functions '(close-server server-opened status-message))) + (while functions + (eval `(deffoo ,(nnoo-symbol backend (car functions)) + (&optional server) + (,(nnoo-symbol 'nnoo (pop functions)) ',backend server))))) + (eval `(deffoo ,(nnoo-symbol backend 'open-server) + (server &optional defs) + (nnoo-change-server ',backend server defs)))) + +(defmacro nnoo-define-skeleton (backend) + "Define all required backend functions for BACKEND. +All functions will return nil and report an error." + `(eval-and-compile + (nnoo-define-skeleton-1 ',backend))) + +(defun nnoo-define-skeleton-1 (backend) + (let ((functions '(retrieve-headers + request-close request-article + request-group close-group + request-list request-post request-list-newsgroups)) + function fun) + (while (setq function (pop functions)) + (when (not (fboundp (setq fun (nnoo-symbol backend function)))) + (eval `(deffoo ,fun + (&rest args) + (nnheader-report ',backend ,(format "%s-%s not implemented" + backend function)))))))) +(provide 'nnoo) + +;;; nnoo.el ends here. diff --git a/lisp/nnsoup.el b/lisp/nnsoup.el new file mode 100644 index 0000000..76023da --- /dev/null +++ b/lisp/nnsoup.el @@ -0,0 +1,810 @@ +;;; nnsoup.el --- SOUP access for Gnus +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nnmail) +(require 'gnus-soup) +(require 'gnus-msg) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnsoup) + +(defvoo nnsoup-directory "~/SOUP/" + "*SOUP packet directory.") + +(defvoo nnsoup-tmp-directory "/tmp/" + "*Where nnsoup will store temporary files.") + +(defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/") + "*Directory where outgoing packets will be composed.") + +(defvoo nnsoup-replies-format-type ?n + "*Format of the replies packages.") + +(defvoo nnsoup-replies-index-type ?n + "*Index type of the replies packages.") + +(defvoo nnsoup-active-file (concat nnsoup-directory "active") + "Active file.") + +(defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz" + "Format string command for packing a SOUP packet. +The SOUP files will be inserted where the %s is in the string. +This string MUST contain both %s and %d. The file number will be +inserted where %d appears.") + +(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -" + "*Format string command for unpacking a SOUP packet. +The SOUP packet file name will be inserted at the %s.") + +(defvoo nnsoup-packet-directory "~/" + "*Where nnsoup will look for incoming packets.") + +(defvoo nnsoup-packet-regexp "Soupout" + "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") + +(defvoo nnsoup-always-save t + "If non nil commit the reply buffer on each message send. +This is necessary if using message mode outside Gnus with nnsoup as a +backend for the messages.") + + + +(defconst nnsoup-version "nnsoup 0.0" + "nnsoup version.") + +(defvoo nnsoup-status-string "") +(defvoo nnsoup-group-alist nil) +(defvoo nnsoup-current-prefix 0) +(defvoo nnsoup-replies-list nil) +(defvoo nnsoup-buffers nil) +(defvoo nnsoup-current-group nil) +(defvoo nnsoup-group-alist-touched nil) +(defvoo nnsoup-article-alist nil) + + +;;; Interface functions. + +(nnoo-define-basics nnsoup) + +(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old) + (nnsoup-possibly-change-group group) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist))) + (articles sequence) + (use-nov t) + useful-areas this-area-seq msg-buf) + (if (stringp (car sequence)) + ;; We don't support fetching by Message-ID. + 'headers + ;; We go through all the areas and find which files the + ;; articles in SEQUENCE come from. + (while (and areas sequence) + ;; Peel off areas that are below sequence. + (while (and areas (< (cdaar areas) (car sequence))) + (setq areas (cdr areas))) + (when areas + ;; This is a useful area. + (push (car areas) useful-areas) + (setq this-area-seq nil) + ;; We take note whether this MSG has a corresponding IDX + ;; for later use. + (when (or (= (gnus-soup-encoding-index + (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) + (not (file-exists-p + (nnsoup-file + (gnus-soup-area-prefix (nth 1 (car areas))))))) + (setq use-nov nil)) + ;; We assign the portion of `sequence' that is relevant to + ;; this MSG packet to this packet. + (while (and sequence (<= (car sequence) (cdaar areas))) + (push (car sequence) this-area-seq) + (setq sequence (cdr sequence))) + (setcar useful-areas (cons (nreverse this-area-seq) + (car useful-areas))))) + + ;; We now have a list of article numbers and corresponding + ;; areas. + (setq useful-areas (nreverse useful-areas)) + + ;; Two different approaches depending on whether all the MSG + ;; files have corresponding IDX files. If they all do, we + ;; simply return the relevant IDX files and let Gnus sort out + ;; what lines are relevant. If some of the IDX files are + ;; missing, we must return HEADs for all the articles. + (if use-nov + ;; We have IDX files for all areas. + (progn + (while useful-areas + (goto-char (point-max)) + (let ((b (point)) + (number (car (nth 1 (car useful-areas)))) + (index-buffer (nnsoup-index-buffer + (gnus-soup-area-prefix + (nth 2 (car useful-areas)))))) + (when index-buffer + (insert-buffer-substring index-buffer) + (goto-char b) + ;; We have to remove the index number entires and + ;; insert article numbers instead. + (while (looking-at "[0-9]+") + (replace-match (int-to-string number) t t) + (incf number) + (forward-line 1)))) + (setq useful-areas (cdr useful-areas))) + 'nov) + ;; We insert HEADs. + (while useful-areas + (setq articles (caar useful-areas) + useful-areas (cdr useful-areas)) + (while articles + (when (setq msg-buf + (nnsoup-narrow-to-article + (car articles) (cdar useful-areas) 'head)) + (goto-char (point-max)) + (insert (format "221 %d Article retrieved.\n" (car articles))) + (insert-buffer-substring msg-buf) + (goto-char (point-max)) + (insert ".\n")) + (setq articles (cdr articles)))) + + (nnheader-fold-continuation-lines) + 'headers))))) + +(deffoo nnsoup-open-server (server &optional defs) + (nnoo-change-server 'nnsoup server defs) + (when (not (file-exists-p nnsoup-directory)) + (condition-case () + (make-directory nnsoup-directory t) + (error t))) + (cond + ((not (file-exists-p nnsoup-directory)) + (nnsoup-close-server) + (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) + ((not (file-directory-p (file-truename nnsoup-directory))) + (nnsoup-close-server) + (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory)) + (t + (nnsoup-read-active-file) + (nnheader-report 'nnsoup "Opened server %s using directory %s" + server nnsoup-directory) + t))) + +(deffoo nnsoup-request-close () + (nnsoup-write-active-file) + (nnsoup-write-replies) + (gnus-soup-save-areas) + ;; Kill all nnsoup buffers. + (let (buffer) + (while nnsoup-buffers + (setq buffer (cdr (pop nnsoup-buffers))) + (and buffer + (buffer-name buffer) + (kill-buffer buffer)))) + (setq nnsoup-group-alist nil + nnsoup-group-alist-touched nil + nnsoup-current-group nil + nnsoup-replies-list nil) + (nnoo-close-server 'nnoo) + t) + +(deffoo nnsoup-request-article (id &optional newsgroup server buffer) + (nnsoup-possibly-change-group newsgroup) + (let (buf) + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (erase-buffer) + (when (and (not (stringp id)) + (setq buf (nnsoup-narrow-to-article id))) + (insert-buffer-substring buf) + t)))) + +(deffoo nnsoup-request-group (group &optional server dont-check) + (nnsoup-possibly-change-group group) + (if dont-check + t + (let ((active (cadr (assoc group nnsoup-group-alist)))) + (if (not active) + (nnheader-report 'nnsoup "No such group: %s" group) + (nnheader-insert + "211 %d %d %d %s\n" + (max (1+ (- (cdr active) (car active))) 0) + (car active) (cdr active) group))))) + +(deffoo nnsoup-request-type (group &optional article) + (nnsoup-possibly-change-group group) + ;; Try to guess the type based on the first article in the group. + (when (not article) + (setq article + (cdaar (cddr (assoc group nnsoup-group-alist))))) + (if (not article) + 'unknown + (let ((kind (gnus-soup-encoding-kind + (gnus-soup-area-encoding + (nth 1 (nnsoup-article-to-area + article nnsoup-current-group)))))) + (cond ((= kind ?m) 'mail) + ((= kind ?n) 'news) + (t 'unknown))))) + +(deffoo nnsoup-close-group (group &optional server) + ;; Kill all nnsoup buffers. + (let ((buffers nnsoup-buffers) + elem) + (while buffers + (when (equal (car (setq elem (pop buffers))) group) + (setq nnsoup-buffers (delq elem nnsoup-buffers)) + (and (cdr elem) (buffer-name (cdr elem)) + (kill-buffer (cdr elem)))))) + t) + +(deffoo nnsoup-request-list (&optional server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (unless nnsoup-group-alist + (nnsoup-read-active-file)) + (let ((alist nnsoup-group-alist) + (standard-output (current-buffer)) + entry) + (while (setq entry (pop alist)) + (insert (car entry) " ") + (princ (cdadr entry)) + (insert " ") + (princ (caadr entry)) + (insert " y\n")) + t))) + +(deffoo nnsoup-request-scan (group &optional server) + (nnsoup-unpack-packets)) + +(deffoo nnsoup-request-newgroups (date &optional server) + (nnsoup-request-list)) + +(deffoo nnsoup-request-list-newsgroups (&optional server) + nil) + +(deffoo nnsoup-request-post (&optional server) + (nnsoup-store-reply "news") + t) + +(deffoo nnsoup-request-mail (&optional server) + (nnsoup-store-reply "mail") + t) + +(deffoo nnsoup-request-expire-articles (articles group &optional server force) + (nnsoup-possibly-change-group group) + (let* ((total-infolist (assoc group nnsoup-group-alist)) + (active (cadr total-infolist)) + (infolist (cddr total-infolist)) + info range-list mod-time prefix) + (while infolist + (setq info (pop infolist) + range-list (gnus-uncompress-range (car info)) + prefix (gnus-soup-area-prefix (nth 1 info))) + (when ;; All the articles in this file are marked for expiry. + (and (or (setq mod-time (nth 5 (file-attributes + (nnsoup-file prefix)))) + (setq mod-time (nth 5 (file-attributes + (nnsoup-file prefix t))))) + (gnus-sublist-p articles range-list) + ;; This file is old enough. + (nnmail-expired-article-p group mod-time force)) + ;; Ok, we delete this file. + (when (ignore-errors + (nnheader-message + 5 "Deleting %s in group %s..." (nnsoup-file prefix) + group) + (when (file-exists-p (nnsoup-file prefix)) + (delete-file (nnsoup-file prefix))) + (nnheader-message + 5 "Deleting %s in group %s..." (nnsoup-file prefix t) + group) + (when (file-exists-p (nnsoup-file prefix t)) + (delete-file (nnsoup-file prefix t))) + t) + (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) + (setq articles (gnus-sorted-complement articles range-list)))) + (when (not mod-time) + (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) + (if (cddr total-infolist) + (setcar active (caaadr (cdr total-infolist))) + (setcar active (1+ (cdr active)))) + (nnsoup-write-active-file t) + ;; Return the articles that weren't expired. + articles)) + + +;;; Internal functions + +(defun nnsoup-possibly-change-group (group &optional force) + (when (and group + (not (equal nnsoup-current-group group))) + (setq nnsoup-article-alist nil) + (setq nnsoup-current-group group)) + t) + +(defun nnsoup-read-active-file () + (setq nnsoup-group-alist nil) + (when (file-exists-p nnsoup-active-file) + (ignore-errors + (load nnsoup-active-file t t t)) + ;; Be backwards compatible. + (when (and nnsoup-group-alist + (not (atom (caadar nnsoup-group-alist)))) + (let ((alist nnsoup-group-alist) + entry e min max) + (while (setq e (cdr (setq entry (pop alist)))) + (setq min (caaar e)) + (while (cdr e) + (setq e (cdr e))) + (setq max (cdaar e)) + (setcdr entry (cons (cons min max) (cdr entry))))) + (setq nnsoup-group-alist-touched t)) + nnsoup-group-alist)) + +(defun nnsoup-write-active-file (&optional force) + (when (and nnsoup-group-alist + (or force + nnsoup-group-alist-touched)) + (setq nnsoup-group-alist-touched nil) + (nnheader-temp-write nnsoup-active-file + (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) + (insert "\n") + (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) + (insert "\n")))) + +(defun nnsoup-next-prefix () + "Return the next free prefix." + (let (prefix) + (while (or (file-exists-p + (nnsoup-file (setq prefix (int-to-string + nnsoup-current-prefix)))) + (file-exists-p (nnsoup-file prefix t))) + (incf nnsoup-current-prefix)) + (incf nnsoup-current-prefix) + prefix)) + +(defun nnsoup-file-name (dir file) + "Return the full path of FILE (in any case) in DIR." + (let* ((case-fold-search t) + (files (directory-files dir t)) + (regexp (concat (regexp-quote file) "$"))) + (car (delq nil + (mapcar + (lambda (file) + (if (string-match regexp file) + file + nil)) + files))))) + +(defun nnsoup-read-areas () + (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas"))) + (when areas-file + (save-excursion + (set-buffer nntp-server-buffer) + (let ((areas (gnus-soup-parse-areas areas-file)) + entry number area lnum cur-prefix file) + ;; Go through all areas in the new AREAS file. + (while (setq area (pop areas)) + ;; Change the name to the permanent name and move the files. + (setq cur-prefix (nnsoup-next-prefix)) + (message "Incorporating file %s..." cur-prefix) + (when (file-exists-p + (setq file (concat nnsoup-tmp-directory + (gnus-soup-area-prefix area) ".IDX"))) + (rename-file file (nnsoup-file cur-prefix))) + (when (file-exists-p + (setq file (concat nnsoup-tmp-directory + (gnus-soup-area-prefix area) ".MSG"))) + (rename-file file (nnsoup-file cur-prefix t)) + (gnus-soup-set-area-prefix area cur-prefix) + ;; Find the number of new articles in this area. + (setq number (nnsoup-number-of-articles area)) + (if (not (setq entry (assoc (gnus-soup-area-name area) + nnsoup-group-alist))) + ;; If this is a new area (group), we just add this info to + ;; the group alist. + (push (list (gnus-soup-area-name area) + (cons 1 number) + (list (cons 1 number) area)) + nnsoup-group-alist) + ;; There are already articles in this group, so we add this + ;; info to the end of the entry. + (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry))) + (+ lnum number)) + area))) + (setcdr (cadr entry) (+ lnum number)))))) + (nnsoup-write-active-file t) + (delete-file areas-file))))) + +(defun nnsoup-number-of-articles (area) + (save-excursion + (cond + ;; If the number is in the area info, we just return it. + ((gnus-soup-area-number area) + (gnus-soup-area-number area)) + ;; If there is an index file, we just count the lines. + ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) + (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) + (count-lines (point-min) (point-max))) + ;; We do it the hard way - re-searching through the message + ;; buffer. + (t + (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) + (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist) + (nnsoup-dissect-buffer area)) + (length (cdr (assoc (gnus-soup-area-prefix area) + nnsoup-article-alist))))))) + +(defun nnsoup-dissect-buffer (area) + (let ((mbox-delim (concat "^" message-unix-mail-delimiter)) + (format (gnus-soup-encoding-format (gnus-soup-area-encoding area))) + (i 0) + alist len) + (goto-char (point-min)) + (cond + ;; rnews batch format + ((= format ?n) + (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$") + (forward-line 1) + (push (list + (incf i) (point) + (progn + (forward-char (string-to-number (match-string 1))) + (point))) + alist))) + ;; Unix mbox format + ((= format ?m) + (while (looking-at mbox-delim) + (forward-line 1) + (push (list + (incf i) (point) + (progn + (if (re-search-forward mbox-delim nil t) + (beginning-of-line) + (goto-char (point-max))) + (point))) + alist))) + ;; MMDF format + ((= format ?M) + (while (looking-at "\^A\^A\^A\^A\n") + (forward-line 1) + (push (list + (incf i) (point) + (progn + (if (search-forward "\n\^A\^A\^A\^A\n" nil t) + (beginning-of-line) + (goto-char (point-max))) + (point))) + alist))) + ;; Binary format + ((or (= format ?B) (= format ?b)) + (while (not (eobp)) + (setq len (+ (* (char-after (point)) (expt 2.0 24)) + (* (char-after (+ (point) 1)) (expt 2 16)) + (* (char-after (+ (point) 2)) (expt 2 8)) + (char-after (+ (point) 3)))) + (push (list + (incf i) (+ (point) 4) + (progn + (forward-char (floor (+ len 4))) + (point))) + alist))) + (t + (error "Unknown format: %c" format))) + (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist))) + +(defun nnsoup-index-buffer (prefix &optional message) + (let* ((file (concat prefix (if message ".MSG" ".IDX"))) + (buffer-name (concat " *nnsoup " file "*"))) + (or (get-buffer buffer-name) ; File already loaded. + (when (file-exists-p (concat nnsoup-directory file)) + (save-excursion ; Load the file. + (set-buffer (get-buffer-create buffer-name)) + (buffer-disable-undo (current-buffer)) + (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) + (nnheader-insert-file-contents (concat nnsoup-directory file)) + (current-buffer)))))) + +(defun nnsoup-file (prefix &optional message) + (expand-file-name + (concat nnsoup-directory prefix (if message ".MSG" ".IDX")))) + +(defun nnsoup-message-buffer (prefix) + (nnsoup-index-buffer prefix 'msg)) + +(defun nnsoup-unpack-packets () + "Unpack all packets in `nnsoup-packet-directory'." + (let ((packets (directory-files + nnsoup-packet-directory t nnsoup-packet-regexp)) + packet) + (while (setq packet (pop packets)) + (message "nnsoup: unpacking %s..." packet) + (if (not (gnus-soup-unpack-packet + nnsoup-tmp-directory nnsoup-unpacker packet)) + (message "Couldn't unpack %s" packet) + (delete-file packet) + (nnsoup-read-areas) + (message "Unpacking...done"))))) + +(defun nnsoup-narrow-to-article (article &optional area head) + (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) + (prefix (and area (gnus-soup-area-prefix (nth 1 area)))) + (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg))) + beg end) + (when area + (save-excursion + (cond + ;; There is no MSG file. + ((null msg-buf) + nil) + ;; We use the index file to find out where the article + ;; begins and ends. + ((and (= (gnus-soup-encoding-index + (gnus-soup-area-encoding (nth 1 area))) + ?c) + (file-exists-p (nnsoup-file prefix))) + (set-buffer (nnsoup-index-buffer prefix)) + (widen) + (goto-char (point-min)) + (forward-line (- article (caar area))) + (setq beg (read (current-buffer))) + (forward-line 1) + (if (looking-at "[0-9]+") + (progn + (setq end (read (current-buffer))) + (set-buffer msg-buf) + (widen) + (let ((format (gnus-soup-encoding-format + (gnus-soup-area-encoding (nth 1 area))))) + (goto-char end) + (when (or (= format ?n) (= format ?m)) + (setq end (progn (forward-line -1) (point)))))) + (set-buffer msg-buf)) + (widen) + (narrow-to-region beg (or end (point-max)))) + (t + (set-buffer msg-buf) + (widen) + (unless (assoc (gnus-soup-area-prefix (nth 1 area)) + nnsoup-article-alist) + (nnsoup-dissect-buffer (nth 1 area))) + (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix + (nth 1 area)) + nnsoup-article-alist))))) + (when entry + (narrow-to-region (cadr entry) (caddr entry)))))) + (goto-char (point-min)) + (if (not head) + () + (narrow-to-region + (point-min) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max)))) + msg-buf)))) + +;;;###autoload +(defun nnsoup-pack-replies () + "Make an outbound package of SOUP replies." + (interactive) + (unless (file-exists-p nnsoup-replies-directory) + (message "No such directory: %s" nnsoup-replies-directory)) + ;; Write all data buffers. + (gnus-soup-save-areas) + ;; Write the active file. + (nnsoup-write-active-file) + ;; Write the REPLIES file. + (nnsoup-write-replies) + ;; Check whether there is anything here. + (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$")) + (error "No files to pack")) + ;; Pack all these files into a SOUP packet. + (gnus-soup-pack nnsoup-replies-directory nnsoup-packer)) + +(defun nnsoup-write-replies () + "Write the REPLIES file." + (when nnsoup-replies-list + (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list) + (setq nnsoup-replies-list nil))) + +(defun nnsoup-article-to-area (article group) + "Return the area that ARTICLE in GROUP is located in." + (let ((areas (cddr (assoc group nnsoup-group-alist)))) + (while (and areas (< (cdaar areas) article)) + (setq areas (cdr areas))) + (and areas (car areas)))) + +(defvar nnsoup-old-functions + (list message-send-mail-function message-send-news-function)) + +;;;###autoload +(defun nnsoup-set-variables () + "Use the SOUP methods for posting news and mailing mail." + (interactive) + (setq message-send-news-function 'nnsoup-request-post) + (setq message-send-mail-function 'nnsoup-request-mail)) + +;;;###autoload +(defun nnsoup-revert-variables () + "Revert posting and mailing methods to the standard Emacs methods." + (interactive) + (setq message-send-mail-function (car nnsoup-old-functions)) + (setq message-send-news-function (cadr nnsoup-old-functions))) + +(defun nnsoup-store-reply (kind) + ;; Mostly stolen from `message.el'. + (require 'mail-utils) + (let ((tembuf (generate-new-buffer " message temp")) + (case-fold-search nil) + delimline + (mailbuf (current-buffer))) + (unwind-protect + (save-excursion + (save-restriction + (message-narrow-to-headers) + (if (equal kind "mail") + (message-generate-headers message-required-mail-headers) + (message-generate-headers message-required-news-headers))) + (set-buffer tembuf) + (erase-buffer) + (insert-buffer-substring mailbuf) + ;; Remove some headers. + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (let ((case-fold-search t)) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (when (eval message-mailer-swallows-blank-line) + (newline)) + (let ((msg-buf + (gnus-soup-store + nnsoup-replies-directory + (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type + nnsoup-replies-index-type)) + (num 0)) + (when (and msg-buf (bufferp msg-buf)) + (save-excursion + (set-buffer msg-buf) + (goto-char (point-min)) + (while (re-search-forward "^#! *rnews" nil t) + (incf num)) + (when nnsoup-always-save + (save-buffer))) + (message "Stored %d messages" num))) + (nnsoup-write-replies) + (kill-buffer tembuf)))))) + +(defun nnsoup-kind-to-prefix (kind) + (unless nnsoup-replies-list + (setq nnsoup-replies-list + (gnus-soup-parse-replies + (concat nnsoup-replies-directory "REPLIES")))) + (let ((replies nnsoup-replies-list)) + (while (and replies + (not (string= kind (gnus-soup-reply-kind (car replies))))) + (setq replies (cdr replies))) + (if replies + (gnus-soup-reply-prefix (car replies)) + (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory) + kind + (format "%c%c%c" + nnsoup-replies-format-type + nnsoup-replies-index-type + (if (string= kind "news") + ?n ?m))) + nnsoup-replies-list) + (gnus-soup-reply-prefix (car nnsoup-replies-list))))) + +(defun nnsoup-make-active () + "(Re-)create the SOUP active file." + (interactive) + (let ((files (sort (directory-files nnsoup-directory t "IDX$") + (lambda (f1 f2) + (< (progn (string-match "/\\([0-9]+\\)\\." f1) + (string-to-int (match-string 1 f1))) + (progn (string-match "/\\([0-9]+\\)\\." f2) + (string-to-int (match-string 1 f2))))))) + active group lines ident elem min) + (set-buffer (get-buffer-create " *nnsoup work*")) + (buffer-disable-undo (current-buffer)) + (while files + (message "Doing %s..." (car files)) + (erase-buffer) + (nnheader-insert-file-contents (car files)) + (goto-char (point-min)) + (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t)) + (setq group "unknown") + (setq group (match-string 2))) + (setq lines (count-lines (point-min) (point-max))) + (setq ident (progn (string-match + "/\\([0-9]+\\)\\." (car files)) + (substring + (car files) (match-beginning 1) + (match-end 1)))) + (if (not (setq elem (assoc group active))) + (push (list group (cons 1 lines) + (list (cons 1 lines) + (vector ident group "ncm" "" lines))) + active) + (nconc elem + (list + (list (cons (1+ (setq min (cdadr elem))) + (+ min lines)) + (vector ident group "ncm" "" lines)))) + (setcdr (cadr elem) (+ min lines))) + (setq files (cdr files))) + (message "") + (setq nnsoup-group-alist active) + (nnsoup-write-active-file t))) + +(defun nnsoup-delete-unreferenced-message-files () + "Delete any *.MSG and *.IDX files that aren't known by nnsoup." + (interactive) + (let* ((known (apply 'nconc (mapcar + (lambda (ga) + (mapcar + (lambda (area) + (gnus-soup-area-prefix (cadr area))) + (cddr ga))) + nnsoup-group-alist))) + (regexp "\\.MSG$\\|\\.IDX$") + (files (directory-files nnsoup-directory nil regexp)) + non-files file) + ;; Find all files that aren't known by nnsoup. + (while (setq file (pop files)) + (string-match regexp file) + (unless (member (substring file 0 (match-beginning 0)) known) + (push file non-files))) + ;; Sort and delete the files. + (setq non-files (sort non-files 'string<)) + (map-y-or-n-p "Delete file %s? " + (lambda (file) (delete-file (concat nnsoup-directory file))) + non-files))) + +(provide 'nnsoup) + +;;; nnsoup.el ends here diff --git a/lisp/nnspool.el b/lisp/nnspool.el new file mode 100644 index 0000000..967a4c8 --- /dev/null +++ b/lisp/nnspool.el @@ -0,0 +1,471 @@ +;;; nnspool.el --- spool access for GNU Emacs +;; Copyright (C) 1988,89,90,93,94,95,96,97 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA +;; Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nntp) +(require 'timezone) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnspool) + +(defvoo nnspool-inews-program news-inews-program + "Program to post news. +This is most commonly `inews' or `injnews'.") + +(defvoo nnspool-inews-switches '("-h" "-S") + "Switches for nnspool-request-post to pass to `inews' for posting news. +If you are using Cnews, you probably should set this variable to nil.") + +(defvoo nnspool-spool-directory (file-name-as-directory news-path) + "Local news spool directory.") + +(defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/") + "Local news nov directory.") + +(defvoo nnspool-lib-dir "/usr/lib/news/" + "Where the local news library files are stored.") + +(defvoo nnspool-active-file (concat nnspool-lib-dir "active") + "Local news active file.") + +(defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups") + "Local news newsgroups file.") + +(defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat") + "Local news distributions file.") + +(defvoo nnspool-history-file (concat nnspool-lib-dir "history") + "Local news history file.") + +(defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times") + "Local news active date file.") + +(defvoo nnspool-large-newsgroup 50 + "The number of the articles which indicates a large newsgroup. +If the number of the articles is greater than the value, verbose +messages will be shown to indicate the current status.") + +(defvoo nnspool-nov-is-evil nil + "Non-nil means that nnspool will never return NOV lines instead of headers.") + +(defconst nnspool-sift-nov-with-sed nil + "If non-nil, use sed to get the relevant portion from the overview file. +If nil, nnspool will load the entire file into a buffer and process it +there.") + +(defvoo nnspool-rejected-article-hook nil + "*A hook that will be run when an article has been rejected by the server.") + +;; 1997/8/14 by MORIOKA Tomohiko +(defvoo nnspool-file-coding-system nnheader-file-coding-system + "Coding system for nnspool.") + + + +(defconst nnspool-version "nnspool 2.0" + "Version numbers of this version of NNSPOOL.") + +(defvoo nnspool-current-directory nil + "Current news group directory.") + +(defvoo nnspool-current-group nil) +(defvoo nnspool-status-string "") + + +;;; Interface functions. + +(nnoo-define-basics nnspool) + +(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old) + "Retrieve the headers of ARTICLES." + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (when (nnspool-possibly-change-directory group) + (let* ((number (length articles)) + (count 0) + (default-directory nnspool-current-directory) + (do-message (and (numberp nnspool-large-newsgroup) + (> number nnspool-large-newsgroup))) + (nnheader-file-coding-system nnspool-file-coding-system) + file beg article ag) + (if (and (numberp (car articles)) + (nnspool-retrieve-headers-with-nov articles fetch-old)) + ;; We successfully retrieved the NOV headers. + 'nov + ;; No NOV headers here, so we do it the hard way. + (while (setq article (pop articles)) + (if (stringp article) + ;; This is a Message-ID. + (setq ag (nnspool-find-id article) + file (and ag (nnspool-article-pathname + (car ag) (cdr ag))) + article (cdr ag)) + ;; This is an article in the current group. + (setq file (int-to-string article))) + ;; Insert the head of the article. + (when (and file + (file-exists-p file)) + (insert "221 ") + (princ article (current-buffer)) + (insert " Article retrieved.\n") + (setq beg (point)) + (inline (nnheader-insert-head file)) + (goto-char beg) + (search-forward "\n\n" nil t) + (forward-char -1) + (insert ".\n") + (delete-region (point) (point-max))) + + (and do-message + (zerop (% (incf count) 20)) + (message "nnspool: Receiving headers... %d%%" + (/ (* count 100) number)))) + + (when do-message + (message "nnspool: Receiving headers...done")) + + ;; Fold continuation lines. + (nnheader-fold-continuation-lines) + 'headers))))) + +(deffoo nnspool-open-server (server &optional defs) + (nnoo-change-server 'nnspool server defs) + (cond + ((not (file-exists-p nnspool-spool-directory)) + (nnspool-close-server) + (nnheader-report 'nnspool "Spool directory doesn't exist: %s" + nnspool-spool-directory)) + ((not (file-directory-p + (directory-file-name + (file-truename nnspool-spool-directory)))) + (nnspool-close-server) + (nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory)) + ((not (file-exists-p nnspool-active-file)) + (nnheader-report 'nnspool "The active file doesn't exist: %s" + nnspool-active-file)) + (t + (nnheader-report 'nnspool "Opened server %s using directory %s" + server nnspool-spool-directory) + t))) + +(deffoo nnspool-request-article (id &optional group server buffer) + "Select article by message ID (or number)." + (nnspool-possibly-change-directory group) + (let ((nntp-server-buffer (or buffer nntp-server-buffer)) + file ag) + (if (stringp id) + ;; This is a Message-ID. + (when (setq ag (nnspool-find-id id)) + (setq file (nnspool-article-pathname (car ag) (cdr ag)))) + (setq file (nnspool-article-pathname nnspool-current-group id))) + (and file + (file-exists-p file) + (not (file-directory-p file)) + (save-excursion (nnspool-find-file file)) + ;; We return the article number and group name. + (if (numberp id) + (cons nnspool-current-group id) + ag)))) + +(deffoo nnspool-request-body (id &optional group server) + "Select article body by message ID (or number)." + (nnspool-possibly-change-directory group) + (let ((res (nnspool-request-article id))) + (when res + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (point-min) (point))) + res)))) + +(deffoo nnspool-request-head (id &optional group server) + "Select article head by message ID (or number)." + (nnspool-possibly-change-directory group) + (let ((res (nnspool-request-article id))) + (when res + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (1- (point)) (point-max))) + (nnheader-fold-continuation-lines))) + res)) + +(deffoo nnspool-request-group (group &optional server dont-check) + "Select news GROUP." + (let ((pathname (nnspool-article-pathname group)) + dir) + (if (not (file-directory-p pathname)) + (nnheader-report + 'nnspool "Invalid group name (no such directory): %s" group) + (setq nnspool-current-directory pathname) + (nnheader-report 'nnspool "Selected group %s" group) + (if dont-check + (progn + (nnheader-report 'nnspool "Selected group %s" group) + t) + ;; Yes, completely empty spool directories *are* possible. + ;; Fix by Sudish Joseph + (when (setq dir (directory-files pathname nil "^[0-9]+$" t)) + (setq dir + (sort (mapcar (lambda (name) (string-to-int name)) dir) '<))) + (if dir + (nnheader-insert + "211 %d %d %d %s\n" (length dir) (car dir) + (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) + group) + (nnheader-report 'nnspool "Empty group %s" group) + (nnheader-insert "211 0 0 0 %s\n" group)))))) + +(deffoo nnspool-request-type (group &optional article) + 'news) + +(deffoo nnspool-close-group (group &optional server) + t) + +(deffoo nnspool-request-list (&optional server) + "List active newsgroups." + (save-excursion + (or (nnspool-find-file nnspool-active-file) + (nnheader-report 'nnspool (nnheader-file-error nnspool-active-file))))) + +(deffoo nnspool-request-list-newsgroups (&optional server) + "List newsgroups (defined in NNTP2)." + (save-excursion + (or (nnspool-find-file nnspool-newsgroups-file) + (nnheader-report 'nnspool (nnheader-file-error + nnspool-newsgroups-file))))) + +(deffoo nnspool-request-list-distributions (&optional server) + "List distributions (defined in NNTP2)." + (save-excursion + (or (nnspool-find-file nnspool-distributions-file) + (nnheader-report 'nnspool (nnheader-file-error + nnspool-distributions-file))))) + +;; Suggested by Hallvard B Furuseth . +(deffoo nnspool-request-newgroups (date &optional server) + "List groups created after DATE." + (if (nnspool-find-file nnspool-active-times-file) + (save-excursion + ;; Find the last valid line. + (goto-char (point-max)) + (while (and (not (looking-at + "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] ")) + (zerop (forward-line -1)))) + (let ((seconds (nnspool-seconds-since-epoch date)) + groups) + ;; Go through lines and add the latest groups to a list. + (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ") + (progn + ;; We insert a .0 to make the list reader + ;; interpret the number as a float. It is far + ;; too big to be stored in a lisp integer. + (goto-char (1- (match-end 0))) + (insert ".0") + (> (progn + (goto-char (match-end 1)) + (read (current-buffer))) + seconds)) + (push (buffer-substring + (match-beginning 1) (match-end 1)) + groups) + (zerop (forward-line -1)))) + (erase-buffer) + (while groups + (insert (car groups) " 0 0 y\n") + (setq groups (cdr groups)))) + t) + nil)) + +(deffoo nnspool-request-post (&optional server) + "Post a new news in current buffer." + (save-excursion + (let* ((process-connection-type nil) ; t bugs out on Solaris + (inews-buffer (generate-new-buffer " *nnspool post*")) + (proc + (condition-case err + (apply 'start-process "*nnspool inews*" inews-buffer + nnspool-inews-program nnspool-inews-switches) + (error + (nnheader-report 'nnspool "inews error: %S" err))))) + (if (not proc) + ;; The inews program failed. + () + (nnheader-report 'nnspool "") + (set-process-sentinel proc 'nnspool-inews-sentinel) + (process-send-region proc (point-min) (point-max)) + ;; We slap a condition-case around this, because the process may + ;; have exited already... + (ignore-errors + (process-send-eof proc)) + t)))) + + + +;;; Internal functions. + +(defun nnspool-inews-sentinel (proc status) + (save-excursion + (set-buffer (process-buffer proc)) + (goto-char (point-min)) + (if (or (zerop (buffer-size)) + (search-forward "spooled" nil t)) + (kill-buffer (current-buffer)) + ;; Make status message by folding lines. + (while (re-search-forward "[ \t\n]+" nil t) + (replace-match " " t t)) + (nnheader-report 'nnspool "%s" (buffer-string)) + (message "nnspool: %s" nnspool-status-string) + (ding) + (run-hooks 'nnspool-rejected-article-hook)))) + +(defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old) + (if (or gnus-nov-is-evil nnspool-nov-is-evil) + nil + (let ((nov (nnheader-group-pathname + nnspool-current-group nnspool-nov-directory ".overview")) + (arts articles) + (nnheader-file-coding-system nnspool-file-coding-system) + last) + (if (not (file-exists-p nov)) + () + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (if nnspool-sift-nov-with-sed + (nnspool-sift-nov-with-sed articles nov) + (nnheader-insert-file-contents nov) + (if (and fetch-old + (not (numberp fetch-old))) + t ; We want all the headers. + (ignore-errors + ;; Delete unwanted NOV lines. + (nnheader-nov-delete-outside-range + (if fetch-old (max 1 (- (car articles) fetch-old)) + (car articles)) + (car (last articles))) + ;; If the buffer is empty, this wasn't very successful. + (unless (zerop (buffer-size)) + ;; We check what the last article number was. + ;; The NOV file may be out of sync with the articles + ;; in the group. + (forward-line -1) + (setq last (read (current-buffer))) + (if (= last (car articles)) + ;; Yup, it's all there. + t + ;; Perhaps not. We try to find the missing articles. + (while (and arts + (<= last (car arts))) + (pop arts)) + ;; The articles in `arts' are missing from the buffer. + (while arts + (nnspool-insert-nov-head (pop arts))) + t)))))))))) + +(defun nnspool-insert-nov-head (article) + "Read the head of ARTICLE, convert to NOV headers, and insert." + (save-excursion + (let ((cur (current-buffer)) + buf) + (setq buf (nnheader-set-temp-buffer " *nnspool head*")) + (when (nnheader-insert-head + (nnspool-article-pathname nnspool-current-group article)) + (nnheader-insert-article-line article) + (let ((headers (nnheader-parse-head))) + (set-buffer cur) + (goto-char (point-max)) + (nnheader-insert-nov headers))) + (kill-buffer buf)))) + +(defun nnspool-sift-nov-with-sed (articles file) + (let ((first (car articles)) + (last (progn (while (cdr articles) (setq articles (cdr articles))) + (car articles)))) + (call-process "awk" nil t nil + (format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}" + (1- first) (1+ last)) + file))) + +;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle). +;; Find out what group an article identified by a Message-ID is in. +(defun nnspool-find-id (id) + (save-excursion + (set-buffer (get-buffer-create " *nnspool work*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (ignore-errors + (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file)) + (goto-char (point-min)) + (prog1 + (when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]") + (cons (match-string 1) (string-to-int (match-string 2)))) + (kill-buffer (current-buffer))))) + +(defun nnspool-find-file (file) + "Insert FILE in server buffer safely." + (set-buffer nntp-server-buffer) + (erase-buffer) + (condition-case () + (let ((nnheader-file-coding-system nnspool-file-coding-system)) + (nnheader-insert-file-contents file) + t) + (file-error nil))) + +(defun nnspool-possibly-change-directory (group) + (if (not group) + t + (let ((pathname (nnspool-article-pathname group))) + (if (file-directory-p pathname) + (setq nnspool-current-directory pathname + nnspool-current-group group) + (nnheader-report 'nnspool "No such newsgroup: %s" group))))) + +(defun nnspool-article-pathname (group &optional article) + "Find the path for GROUP." + (nnheader-group-pathname group nnspool-spool-directory article)) + +(defun nnspool-seconds-since-epoch (date) + (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti))) + (timezone-parse-date date))) + (ttime (mapcar (lambda (ti) (and ti (string-to-int ti))) + (timezone-parse-time + (aref (timezone-parse-date date) 3)))) + (unix (encode-time (nth 2 ttime) (nth 1 ttime) (nth 0 ttime) + (nth 2 tdate) (nth 1 tdate) (nth 0 tdate) + (nth 4 tdate)))) + (+ (* (car unix) 65536.0) + (cadr unix)))) + +(provide 'nnspool) + +;;; nnspool.el ends here diff --git a/lisp/nntp.el b/lisp/nntp.el new file mode 100644 index 0000000..d1470f6 --- /dev/null +++ b/lisp/nntp.el @@ -0,0 +1,1148 @@ +;;; nntp.el --- nntp access for Gnus +;;; Copyright (C) 1987-90,92-97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nnoo) +(require 'gnus-util) + +(nnoo-declare nntp) + +(eval-and-compile + (unless (fboundp 'open-network-stream) + (require 'tcp))) + +(eval-when-compile (require 'cl)) + +(defvoo nntp-address nil + "Address of the physical nntp server.") + +(defvoo nntp-port-number "nntp" + "Port number on the physical nntp server.") + +(defvoo nntp-server-opened-hook '(nntp-send-mode-reader) + "*Hook used for sending commands to the server at startup. +The default value is `nntp-send-mode-reader', which makes an innd +server spawn an nnrpd server. Another useful function to put in this +hook might be `nntp-send-authinfo', which will prompt for a password +to allow posting from the server. Note that this is only necessary to +do on servers that use strict access control.") + +(defvoo nntp-authinfo-function 'nntp-send-authinfo + "Function used to send AUTHINFO to the server.") + +(defvoo nntp-server-action-alist + '(("nntpd 1\\.5\\.11t" + (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) + ("NNRP server Netscape" + (setq nntp-server-list-active-group nil))) + "Alist of regexps to match on server types and actions to be taken. +For instance, if you want Gnus to beep every time you connect +to innd, you could say something like: + +\(setq nntp-server-action-alist + '((\"innd\" (ding)))) + +You probably don't want to do that, though.") + +(defvoo nntp-open-connection-function 'nntp-open-network-stream + "*Function used for connecting to a remote system. +It will be called with the buffer to output in. + +Two pre-made functions are `nntp-open-network-stream', which is the +default, and simply connects to some port or other on the remote +system (see nntp-port-number). The other are `nntp-open-rlogin', +which does an rlogin on the remote system, and then does a telnet to +the NNTP server available there (see nntp-rlogin-parameters) and +`nntp-open-telnet' which telnets to a remote system, logs in and does +the same.") + +(defvoo nntp-rlogin-program "rsh" + "*Program used to log in on remote machines. +The default is \"rsh\", but \"ssh\" is a popular alternative.") + +(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") + "*Parameters to `nntp-open-login'. +That function may be used as `nntp-open-connection-function'. In that +case, this list will be used as the parameter list given to rsh.") + +(defvoo nntp-rlogin-user-name nil + "*User name on remote system when using the rlogin connect method.") + +(defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") + "*Parameters to `nntp-open-telnet'. +That function may be used as `nntp-open-connection-function'. In that +case, this list will be executed as a command after logging in +via telnet.") + +(defvoo nntp-telnet-user-name nil + "User name to log in via telnet with.") + +(defvoo nntp-telnet-passwd nil + "Password to use to log in via telnet with.") + +(defvoo nntp-telnet-command "telnet" + "Command used to start telnet.") + +(defvoo nntp-telnet-switches '("-8") + "Switches given to the telnet command.") + +(defvoo nntp-end-of-line "\r\n" + "String to use on the end of lines when talking to the NNTP server. +This is \"\\r\\n\" by default, but should be \"\\n\" when +using rlogin or telnet to communicate with the server.") + +(defvoo nntp-large-newsgroup 50 + "*The number of the articles which indicates a large newsgroup. +If the number of the articles is greater than the value, verbose +messages will be shown to indicate the current status.") + +(defvoo nntp-maximum-request 400 + "*The maximum number of the requests sent to the NNTP server at one time. +If Emacs hangs up while retrieving headers, set the variable to a +lower value.") + +(defvoo nntp-nov-is-evil nil + "*If non-nil, nntp will never attempt to use XOVER when talking to the server.") + +(defvoo nntp-xover-commands '("XOVER" "XOVERVIEW") + "*List of strings that are used as commands to fetch NOV lines from a server. +The strings are tried in turn until a positive response is gotten. If +none of the commands are successful, nntp will just grab headers one +by one.") + +(defvoo nntp-nov-gap 5 + "*Maximum allowed gap between two articles. +If the gap between two consecutive articles is bigger than this +variable, split the XOVER request into two requests.") + +(defvoo nntp-connection-timeout nil + "*Number of seconds to wait before an nntp connection times out. +If this variable is nil, which is the default, no timers are set.") + +(defvoo nntp-prepare-server-hook nil + "*Hook run before a server is opened. +If can be used to set up a server remotely, for instance. Say you +have an account at the machine \"other.machine\". This machine has +access to an NNTP server that you can't access locally. You could +then use this hook to rsh to the remote machine and start a proxy NNTP +server there that you can connect to. See also `nntp-open-connection-function'") + +(defvoo nntp-warn-about-losing-connection t + "*If non-nil, beep when a server closes connection.") + +(defvoo nntp-coding-system-for-read nil + "*coding-system for read from NNTP.") + + + +;;; Internal variables. + +(defvar nntp-have-messaged nil) + +(defvar nntp-process-wait-for nil) +(defvar nntp-process-to-buffer nil) +(defvar nntp-process-callback nil) +(defvar nntp-process-decode nil) +(defvar nntp-process-start-point nil) +(defvar nntp-inside-change-function nil) + +(defvar nntp-connection-list nil) + +(defvoo nntp-server-type nil) +(defvoo nntp-connection-alist nil) +(defvoo nntp-status-string "") +(defconst nntp-version "nntp 5.0") +(defvoo nntp-inhibit-erase nil) +(defvoo nntp-inhibit-output nil) + +(defvoo nntp-server-xover 'try) +(defvoo nntp-server-list-active-group 'try) + +(eval-and-compile + (autoload 'nnmail-read-passwd "nnmail")) + + + +;;; Internal functions. + +(defsubst nntp-send-string (process string) + "Send STRING to PROCESS." + (process-send-string process (concat string nntp-end-of-line))) + +(defsubst nntp-wait-for (process wait-for buffer &optional decode discard) + "Wait for WAIT-FOR to arrive from PROCESS." + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-min)) + (while (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) + (looking-at "480")) + (when (looking-at "480") + (erase-buffer) + (funcall nntp-authinfo-function)) + (nntp-accept-process-output process) + (goto-char (point-min))) + (prog1 + (if (looking-at "[45]") + (progn + (nntp-snarf-error-message) + nil) + (goto-char (point-max)) + (let ((limit (point-min))) + (while (not (re-search-backward wait-for limit t)) + ;; We assume that whatever we wait for is less than 1000 + ;; characters long. + (setq limit (max (- (point-max) 1000) (point-min))) + (nntp-accept-process-output process) + (goto-char (point-max)))) + (nntp-decode-text (not decode)) + (unless discard + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (insert-buffer-substring (process-buffer process)) + ;; Nix out "nntp reading...." message. + (when nntp-have-messaged + (setq nntp-have-messaged nil) + (message "")) + t))) + (unless discard + (erase-buffer))))) + +(defsubst nntp-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((alist nntp-connection-alist) + (buffer (if (stringp buffer) (get-buffer buffer) buffer)) + process entry) + (while (setq entry (pop alist)) + (when (eq buffer (cadr entry)) + (setq process (car entry) + alist nil))) + (when process + (if (memq (process-status process) '(open run)) + process + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process))) + (setq nntp-connection-alist (delq entry nntp-connection-alist)) + nil)))) + +(defsubst nntp-find-connection-entry (buffer) + "Return the entry for the connection to BUFFER." + (assq (nntp-find-connection buffer) nntp-connection-alist)) + +(defun nntp-find-connection-buffer (buffer) + "Return the process connection buffer tied to BUFFER." + (let ((process (nntp-find-connection buffer))) + (when process + (process-buffer process)))) + +(defsubst nntp-retrieve-data (command address port buffer + &optional wait-for callback decode) + "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." + (let ((process (or (nntp-find-connection buffer) + (nntp-open-connection buffer)))) + (if (not process) + (nnheader-report 'nntp "Couldn't open connection to %s" address) + (unless (or nntp-inhibit-erase nnheader-callback-function) + (save-excursion + (set-buffer (process-buffer process)) + (erase-buffer))) + (when command + (nntp-send-string process command)) + (cond + ((eq callback 'ignore) + t) + ((and callback wait-for) + (save-excursion + (set-buffer (process-buffer process)) + (unless nntp-inside-change-function + (erase-buffer)) + (setq nntp-process-decode decode + nntp-process-to-buffer buffer + nntp-process-wait-for wait-for + nntp-process-callback callback + nntp-process-start-point (point-max) + after-change-functions + (list 'nntp-after-change-function-callback))) + t) + (wait-for + (nntp-wait-for process wait-for buffer decode)) + (t t))))) + +(defsubst nntp-send-command (wait-for &rest strings) + "Send STRINGS to server and wait until WAIT-FOR returns." + (when (and (not nnheader-callback-function) + (not nntp-inhibit-output)) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer))) + (nntp-retrieve-data + (mapconcat 'identity strings " ") + nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function)) + +(defun nntp-send-command-nodelete (wait-for &rest strings) + "Send STRINGS to server and wait until WAIT-FOR returns." + (nntp-retrieve-data + (mapconcat 'identity strings " ") + nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function)) + +(defun nntp-send-command-and-decode (wait-for &rest strings) + "Send STRINGS to server and wait until WAIT-FOR returns." + (when (and (not nnheader-callback-function) + (not nntp-inhibit-output)) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer))) + (nntp-retrieve-data + (mapconcat 'identity strings " ") + nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function t)) + +(defun nntp-send-buffer (wait-for) + "Send the current buffer to server and wait until WAIT-FOR returns." + (when (and (not nnheader-callback-function) + (not nntp-inhibit-output)) + (save-excursion + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + (erase-buffer))) + (nntp-encode-text) + (process-send-region (nntp-find-connection nntp-server-buffer) + (point-min) (point-max)) + (nntp-retrieve-data + nil nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function)) + + + +;;; Interface functions. + +(nnoo-define-basics nntp) + +(defsubst nntp-next-result-arrived-p () + (let ((point (point))) + (cond + ((eq (following-char) ?2) + (if (re-search-forward "\n\\.\r?\n" nil t) + t + (goto-char point) + nil)) + ((looking-at "[34]") + (forward-line 1) + t) + (t + nil)))) + +(deffoo nntp-retrieve-headers (articles &optional group server fetch-old) + "Retrieve the headers of ARTICLES." + (nntp-possibly-change-group group server) + (save-excursion + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + (erase-buffer) + (if (and (not gnus-nov-is-evil) + (not nntp-nov-is-evil) + (nntp-retrieve-headers-with-xover articles fetch-old)) + ;; We successfully retrieved the headers via XOVER. + 'nov + ;; XOVER didn't work, so we do it the hard, slow and inefficient + ;; way. + (let ((number (length articles)) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + article) + ;; Send HEAD commands. + (while (setq article (pop articles)) + (nntp-send-command + nil + "HEAD" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving headers... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving headers...done")) + + ;; Now all of replies are received. Fold continuation lines. + (nnheader-fold-continuation-lines) + ;; Remove all "\r"'s. + (nnheader-strip-cr) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'headers)))) + +(deffoo nntp-retrieve-groups (groups &optional server) + "Retrieve group info on GROUPS." + (nntp-possibly-change-group nil server) + (save-excursion + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + ;; The first time this is run, this variable is `try'. So we + ;; try. + (when (eq nntp-server-list-active-group 'try) + (nntp-try-list-active (car groups))) + (erase-buffer) + (let ((count 0) + (received 0) + (last-point (point-min)) + (nntp-inhibit-erase t) + (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) + (while groups + ;; Send the command to the server. + (nntp-send-command nil command (pop groups)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null groups) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9]" nil t) + (incf received)) + (setq last-point (point)) + (< received count)) + (nntp-accept-response)))) + + ;; Wait for the reply from the final command. + (goto-char (point-max)) + (re-search-backward "^[0-9]" nil t) + (when (looking-at "^[23]") + (while (progn + (goto-char (point-max)) + (if (not nntp-server-list-active-group) + (not (re-search-backward "\r?\n" (- (point) 3) t)) + (not (re-search-backward "^\\.\r?\n" (- (point) 4) t)))) + (nntp-accept-response))) + + ;; Now all replies are received. We remove CRs. + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (replace-match "" t t)) + + (if (not nntp-server-list-active-group) + (progn + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'group) + ;; We have read active entries, so we just delete the + ;; superfluous gunk. + (goto-char (point-min)) + (while (re-search-forward "^[.2-5]" nil t) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'active)))) + +(deffoo nntp-retrieve-articles (articles &optional group server) + (nntp-possibly-change-group group server) + (save-excursion + (let ((number (length articles)) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + (map (apply 'vector articles)) + (point 1) + article alist) + (set-buffer buf) + (erase-buffer) + ;; Send ARTICLE command. + (while (setq article (pop articles)) + (nntp-send-command + nil + "ARTICLE" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (aset map received (cons (aref map received) (point))) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving articles... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving articles...done")) + + ;; Now we have all the responses. We go through the results, + ;; washes it and copies it over to the server buffer. + (set-buffer nntp-server-buffer) + (erase-buffer) + (setq last-point (point-min)) + (mapcar + (lambda (entry) + (narrow-to-region + (setq point (goto-char (point-max))) + (progn + (insert-buffer-substring buf last-point (cdr entry)) + (point-max))) + (setq last-point (cdr entry)) + (nntp-decode-text) + (widen) + (cons (car entry) point)) + map)))) + +(defun nntp-try-list-active (group) + (nntp-list-active-group group) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (cond ((or (eobp) + (looking-at "5[0-9]+")) + (setq nntp-server-list-active-group nil)) + (t + (setq nntp-server-list-active-group t))))) + +(deffoo nntp-list-active-group (group &optional server) + "Return the active info on GROUP (which can be a regexp." + (nntp-possibly-change-group nil server) + (nntp-send-command "^.*\r?\n" "LIST ACTIVE" group)) + +(deffoo nntp-request-article (article &optional group server buffer command) + (nntp-possibly-change-group group server) + (when (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "ARTICLE" + (if (numberp article) (int-to-string article) article)) + (if (and buffer + (not (equal buffer nntp-server-buffer))) + (save-excursion + (set-buffer nntp-server-buffer) + (copy-to-buffer buffer (point-min) (point-max)) + (nntp-find-group-and-number)) + (nntp-find-group-and-number)))) + +(deffoo nntp-request-head (article &optional group server) + (nntp-possibly-change-group group server) + (when (nntp-send-command + "\r?\n\\.\r?\n" "HEAD" + (if (numberp article) (int-to-string article) article)) + (prog1 + (nntp-find-group-and-number) + (nntp-decode-text)))) + +(deffoo nntp-request-body (article &optional group server) + (nntp-possibly-change-group group server) + (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "BODY" + (if (numberp article) (int-to-string article) article))) + +(deffoo nntp-request-group (group &optional server dont-check) + (nntp-possibly-change-group nil server) + (when (nntp-send-command "^2.*\n" "GROUP" group) + (let ((entry (nntp-find-connection-entry nntp-server-buffer))) + (setcar (cddr entry) group)))) + +(deffoo nntp-close-group (group &optional server) + t) + +(deffoo nntp-server-opened (&optional server) + "Say whether a connection to SERVER has been opened." + (and (nnoo-current-server-p 'nntp server) + nntp-server-buffer + (gnus-buffer-live-p nntp-server-buffer) + (nntp-find-connection nntp-server-buffer))) + +(deffoo nntp-open-server (server &optional defs connectionless) + (nnheader-init-server-buffer) + (if (nntp-server-opened server) + t + (when (or (stringp (car defs)) + (numberp (car defs))) + (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs)))) + (unless (assq 'nntp-address defs) + (setq defs (append defs (list (list 'nntp-address server))))) + (nnoo-change-server 'nntp server defs) + (unless connectionless + (or (nntp-find-connection nntp-server-buffer) + (nntp-open-connection nntp-server-buffer))))) + +(deffoo nntp-close-server (&optional server) + (nntp-possibly-change-group nil server t) + (let (process) + (while (setq process (car (pop nntp-connection-alist))) + (when (memq (process-status process) '(open run)) + (set-process-sentinel process nil) + (ignore-errors + (nntp-send-string process "QUIT"))) + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process)))) + (nnoo-close-server 'nntp))) + +(deffoo nntp-request-close () + (let (process) + (while (setq process (pop nntp-connection-list)) + (when (memq (process-status process) '(open run)) + (set-process-sentinel process nil) + (ignore-errors + (nntp-send-string process "QUIT"))) + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process)))))) + +(deffoo nntp-request-list (&optional server) + (nntp-possibly-change-group nil server) + (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST")) + +(deffoo nntp-request-list-newsgroups (&optional server) + (nntp-possibly-change-group nil server) + (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")) + +(deffoo nntp-request-newgroups (date &optional server) + (nntp-possibly-change-group nil server) + (save-excursion + (set-buffer nntp-server-buffer) + (let* ((date (timezone-parse-date date)) + (time-string + (format "%s%02d%02d %s%s%s" + (substring (aref date 0) 2) (string-to-int (aref date 1)) + (string-to-int (aref date 2)) (substring (aref date 3) 0 2) + (substring + (aref date 3) 3 5) (substring (aref date 3) 6 8)))) + (prog1 + (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string) + (nntp-decode-text))))) + +(deffoo nntp-request-post (&optional server) + (nntp-possibly-change-group nil server) + (when (nntp-send-command "^[23].*\r?\n" "POST") + (nntp-send-buffer "^[23].*\n"))) + +(deffoo nntp-request-type (group article) + 'news) + +(deffoo nntp-asynchronous-p () + t) + +;;; Hooky functions. + +(defun nntp-send-mode-reader () + "Send the MODE READER command to the nntp server. +This function is supposed to be called from `nntp-server-opened-hook'. +It will make innd servers spawn an nnrpd process to allow actual article +reading." + (nntp-send-command "^.*\r?\n" "MODE READER")) + +(defun nntp-send-nosy-authinfo () + "Send the AUTHINFO to the nntp server. +This function is supposed to be called from `nntp-server-opened-hook'. +It will prompt for a password." + (nntp-send-command + "^.*\r?\n" "AUTHINFO USER" + (read-string (format "NNTP (%s) user name: " nntp-address))) + (nntp-send-command + "^.*\r?\n" "AUTHINFO PASS" + (nnmail-read-passwd "NNTP (%s) password: " nntp-address))) + +(defun nntp-send-authinfo () + "Send the AUTHINFO to the nntp server. +This function is supposed to be called from `nntp-server-opened-hook'. +It will prompt for a password." + (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) + (nntp-send-command + "^.*\r?\n" "AUTHINFO PASS" + (nnmail-read-passwd (format "NNTP (%s) password: " nntp-address)))) + +(defun nntp-send-authinfo-from-file () + "Send the AUTHINFO to the nntp server. +This function is supposed to be called from `nntp-server-opened-hook'." + (when (file-exists-p "~/.nntp-authinfo") + (nnheader-temp-write nil + (insert-file-contents "~/.nntp-authinfo") + (goto-char (point-min)) + (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) + (nntp-send-command + "^.*\r?\n" "AUTHINFO PASS" + (buffer-substring (point) (progn (end-of-line) (point))))))) + +;;; Internal functions. + +(defun nntp-make-process-buffer (buffer) + "Create a new, fresh buffer usable for nntp process connections." + (save-excursion + (set-buffer + (generate-new-buffer + (format " *server %s %s %s*" + nntp-address nntp-port-number + (buffer-name (get-buffer buffer))))) + (buffer-disable-undo (current-buffer)) + (set (make-local-variable 'after-change-functions) nil) + (set (make-local-variable 'nntp-process-wait-for) nil) + (set (make-local-variable 'nntp-process-callback) nil) + (set (make-local-variable 'nntp-process-to-buffer) nil) + (set (make-local-variable 'nntp-process-start-point) nil) + (set (make-local-variable 'nntp-process-decode) nil) + (current-buffer))) + +(defun nntp-open-connection (buffer) + "Open a connection to PORT on ADDRESS delivering output to BUFFER." + (run-hooks 'nntp-prepare-server-hook) + (let* ((pbuffer (nntp-make-process-buffer buffer)) + (process + (condition-case () + (let ((coding-system-for-read nntp-coding-system-for-read)) + (funcall nntp-open-connection-function pbuffer)) + (error nil) + (quit nil)))) + (when process + (process-kill-without-query process) + (nntp-wait-for process "^.*\n" buffer nil t) + (if (memq (process-status process) '(open run)) + (prog1 + (caar (push (list process buffer nil) nntp-connection-alist)) + (push process nntp-connection-list) + (save-excursion + (set-buffer pbuffer) + (nntp-read-server-type) + (erase-buffer) + (set-buffer nntp-server-buffer) + (let ((nnheader-callback-function nil)) + (run-hooks 'nntp-server-opened-hook)))) + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process))) + nil)))) + +(defun nntp-open-network-stream (buffer) + (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) + +(defun nntp-read-server-type () + "Find out what the name of the server we have connected to is." + ;; Wait for the status string to arrive. + (setq nntp-server-type (buffer-string)) + (let ((alist nntp-server-action-alist) + (case-fold-search t) + entry) + ;; Run server-specific commands. + (while alist + (setq entry (pop alist)) + (when (string-match (car entry) nntp-server-type) + (if (and (listp (cadr entry)) + (not (eq 'lambda (caadr entry)))) + (eval (cadr entry)) + (funcall (cadr entry))))))) + +(defun nntp-after-change-function-callback (beg end len) + (when nntp-process-callback + (save-match-data + (if (and (= beg (point-min)) + (memq (char-after beg) '(?4 ?5))) + ;; Report back error messages. + (save-excursion + (goto-char beg) + (if (looking-at "480") + (funcall nntp-authinfo-function) + (nntp-snarf-error-message) + (funcall nntp-process-callback nil))) + (goto-char end) + (when (and (> (point) nntp-process-start-point) + (re-search-backward nntp-process-wait-for + nntp-process-start-point t)) + (when (buffer-name (get-buffer nntp-process-to-buffer)) + (let ((cur (current-buffer)) + (start nntp-process-start-point)) + (save-excursion + (set-buffer (get-buffer nntp-process-to-buffer)) + (goto-char (point-max)) + (let ((b (point))) + (insert-buffer-substring cur start) + (narrow-to-region b (point-max)) + (nntp-decode-text) + (widen))))) + (goto-char end) + (let ((callback nntp-process-callback) + (nntp-inside-change-function t)) + (setq nntp-process-callback nil) + (save-excursion + (funcall callback (buffer-name + (get-buffer nntp-process-to-buffer)))))))))) + +(defun nntp-snarf-error-message () + "Save the error message in the current buffer." + (let ((message (buffer-string))) + (while (string-match "[\r\n]+" message) + (setq message (replace-match " " t t message))) + (nnheader-report 'nntp message) + message)) + +(defun nntp-accept-process-output (process) + "Wait for output from PROCESS and message some dots." + (save-excursion + (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer) + nntp-server-buffer)) + (let ((len (/ (point-max) 1024)) + message-log-max) + (unless (< len 10) + (setq nntp-have-messaged t) + (nnheader-message 7 "nntp read: %dk" len))) + (accept-process-output process 1))) + +(defun nntp-accept-response () + "Wait for output from the process that outputs to BUFFER." + (nntp-accept-process-output (nntp-find-connection nntp-server-buffer))) + +(defun nntp-possibly-change-group (group server &optional connectionless) + (let ((nnheader-callback-function nil)) + (when server + (or (nntp-server-opened server) + (nntp-open-server server nil connectionless))) + + (unless connectionless + (or (nntp-find-connection nntp-server-buffer) + (nntp-open-connection nntp-server-buffer)))) + + (when group + (let ((entry (nntp-find-connection-entry nntp-server-buffer))) + (when (not (equal group (caddr entry))) + (save-excursion + (set-buffer (process-buffer (car entry))) + (erase-buffer) + (nntp-send-string (car entry) (concat "GROUP " group)) + (nntp-wait-for-string "^2.*\n") + (setcar (cddr entry) group) + (erase-buffer)))))) + +(defun nntp-decode-text (&optional cr-only) + "Decode the text in the current buffer." + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (delete-char -1)) + (unless cr-only + ;; Remove trailing ".\n" end-of-transfer marker. + (goto-char (point-max)) + (forward-line -1) + (when (looking-at ".\n") + (delete-char 2)) + ;; Delete status line. + (goto-char (point-min)) + (delete-region (point) (progn (forward-line 1) (point))) + ;; Remove "." -> ".." encoding. + (while (search-forward "\n.." nil t) + (delete-char -1)))) + +(defun nntp-encode-text () + "Encode the text in the current buffer." + (save-excursion + ;; Replace "." at beginning of line with "..". + (goto-char (point-min)) + (while (re-search-forward "^\\." nil t) + (insert ".")) + (goto-char (point-max)) + ;; Insert newline at the end of the buffer. + (unless (bolp) + (insert "\n")) + ;; Insert `.' at end of buffer (end of text mark). + (goto-char (point-max)) + (insert "." nntp-end-of-line))) + +(defun nntp-retrieve-headers-with-xover (articles &optional fetch-old) + (set-buffer nntp-server-buffer) + (erase-buffer) + (cond + + ;; This server does not talk NOV. + ((not nntp-server-xover) + nil) + + ;; We don't care about gaps. + ((or (not nntp-nov-gap) + fetch-old) + (nntp-send-xover-command + (if fetch-old + (if (numberp fetch-old) + (max 1 (- (car articles) fetch-old)) + 1) + (car articles)) + (car (last articles)) 'wait) + + (goto-char (point-min)) + (when (looking-at "[1-5][0-9][0-9] ") + (delete-region (point) (progn (forward-line 1) (point)))) + (while (search-forward "\r" nil t) + (replace-match "" t t)) + (goto-char (point-max)) + (forward-line -1) + (when (looking-at "\\.") + (delete-region (point) (progn (forward-line 1) (point))))) + + ;; We do it the hard way. For each gap, an XOVER command is sent + ;; to the server. We do not wait for a reply from the server, we + ;; just send them off as fast as we can. That means that we have + ;; to count the number of responses we get back to find out when we + ;; have gotten all we asked for. + ((numberp nntp-nov-gap) + (let ((count 0) + (received 0) + (last-point (point-min)) + (buf nntp-server-buffer) + ;;(process-buffer (nntp-find-connection (current-buffer)))) + first) + ;; We have to check `nntp-server-xover'. If it gets set to nil, + ;; that means that the server does not understand XOVER, but we + ;; won't know that until we try. + (while (and nntp-server-xover articles) + (setq first (car articles)) + ;; Search forward until we find a gap, or until we run out of + ;; articles. + (while (and (cdr articles) + (< (- (nth 1 articles) (car articles)) nntp-nov-gap)) + (setq articles (cdr articles))) + + (when (nntp-send-xover-command first (car articles)) + (setq articles (cdr articles) + count (1+ count)) + + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (accept-process-output) + ;; On some Emacs versions the preceding function has + ;; a tendency to change the buffer. Perhaps. It's + ;; quite difficult to reproduce, because it only + ;; seems to happen once in a blue moon. + (set-buffer buf) + (while (progn + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9][0-9][0-9] " nil t) + (setq received (1+ received))) + (setq last-point (point)) + (< received count)) + (accept-process-output) + (set-buffer buf))))) + + (when nntp-server-xover + ;; Wait for the reply from the final command. + (goto-char (point-max)) + (re-search-backward "^[0-9][0-9][0-9] " nil t) + (when (looking-at "^[23]") + (while (progn + (goto-char (point-max)) + (forward-line -1) + (not (looking-at "^\\.\r?\n"))) + (nntp-accept-response))) + + ;; We remove any "." lines and status lines. + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (delete-char -1)) + (goto-char (point-min)) + (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ") + ;;(copy-to-buffer nntp-server-buffer (point-min) (point-max)) + t)))) + + nntp-server-xover) + +(defun nntp-send-xover-command (beg end &optional wait-for-reply) + "Send the XOVER command to the server." + (let ((range (format "%d-%d" beg end)) + (nntp-inhibit-erase t)) + (if (stringp nntp-server-xover) + ;; If `nntp-server-xover' is a string, then we just send this + ;; command. + (if wait-for-reply + (nntp-send-command-nodelete + "\r?\n\\.\r?\n" nntp-server-xover range) + ;; We do not wait for the reply. + (nntp-send-command-nodelete "\r?\n\\.\r?\n" nntp-server-xover range)) + (let ((commands nntp-xover-commands)) + ;; `nntp-xover-commands' is a list of possible XOVER commands. + ;; We try them all until we get at positive response. + (while (and commands (eq nntp-server-xover 'try)) + (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (and (looking-at "[23]") ; No error message. + ;; We also have to look at the lines. Some buggy + ;; servers give back simple lines with just the + ;; article number. How... helpful. + (progn + (forward-line 1) + (looking-at "[0-9]+\t...")) ; More text after number. + (setq nntp-server-xover (car commands)))) + (setq commands (cdr commands))) + ;; If none of the commands worked, we disable XOVER. + (when (eq nntp-server-xover 'try) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (setq nntp-server-xover nil))) + nntp-server-xover)))) + +;;; Alternative connection methods. + +(defun nntp-wait-for-string (regexp) + "Wait until string arrives in the buffer." + (let ((buf (current-buffer))) + (goto-char (point-min)) + (while (not (re-search-forward regexp nil t)) + (accept-process-output (nntp-find-connection nntp-server-buffer)) + (set-buffer buf) + (goto-char (point-min))))) + +(defun nntp-open-telnet (buffer) + (save-excursion + (set-buffer buffer) + (erase-buffer) + (let ((proc (apply + 'start-process + "nntpd" buffer nntp-telnet-command nntp-telnet-switches)) + (case-fold-search t)) + (when (memq (process-status proc) '(open run)) + (process-send-string proc "set escape \^X\n") + (process-send-string proc (concat "open " nntp-address "\n")) + (nntp-wait-for-string "^\r*.?login:") + (process-send-string + proc (concat + (or nntp-telnet-user-name + (setq nntp-telnet-user-name (read-string "login: "))) + "\n")) + (nntp-wait-for-string "^\r*.?password:") + (process-send-string + proc (concat + (or nntp-telnet-passwd + (setq nntp-telnet-passwd + (nnmail-read-passwd "Password: "))) + "\n")) + (erase-buffer) + (nntp-wait-for-string "bash\\|\$ *\r?$\\|> *\r?") + (process-send-string + proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) + (nntp-wait-for-string "^\r*200") + (beginning-of-line) + (delete-region (point-min) (point)) + (process-send-string proc "\^]") + (nntp-wait-for-string "^telnet") + (process-send-string proc "mode character\n") + (accept-process-output proc 1) + (sit-for 1) + (goto-char (point-min)) + (forward-line 1) + (delete-region (point) (point-max))) + proc))) + +(defun nntp-open-rlogin (buffer) + "Open a connection to SERVER using rsh." + (let ((proc (if nntp-rlogin-user-name + (start-process + "nntpd" buffer nntp-rlogin-program + nntp-address "-l" nntp-rlogin-user-name + (mapconcat 'identity + nntp-rlogin-parameters " ")) + (start-process + "nntpd" buffer nntp-rlogin-program nntp-address + (mapconcat 'identity + nntp-rlogin-parameters " "))))) + (set-buffer buffer) + (nntp-wait-for-string "^\r*200") + (beginning-of-line) + (delete-region (point-min) (point)) + proc)) + +(defun nntp-find-group-and-number () + (save-excursion + (save-restriction + (set-buffer nntp-server-buffer) + (narrow-to-region (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point-max))) + (goto-char (point-min)) + ;; We first find the number by looking at the status line. + (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ") + (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))))) + group newsgroups xref) + (and number (zerop number) (setq number nil)) + ;; Then we find the group name. + (setq group + (cond + ;; If there is only one group in the Newsgroups header, + ;; then it seems quite likely that this article comes + ;; from that group, I'd say. + ((and (setq newsgroups (mail-fetch-field "newsgroups")) + (not (string-match "," newsgroups))) + newsgroups) + ;; If there is more than one group in the Newsgroups + ;; header, then the Xref header should be filled out. + ;; We hazard a guess that the group that has this + ;; article number in the Xref header is the one we are + ;; looking for. This might very well be wrong if this + ;; article happens to have the same number in several + ;; groups, but that's life. + ((and (setq xref (mail-fetch-field "xref")) + number + (string-match (format "\\([^ :]+\\):%d" number) xref)) + (substring xref (match-beginning 1) (match-end 1))) + (t ""))) + (when (string-match "\r" group) + (setq group (substring group 0 (match-beginning 0)))) + (cons group number))))) + +(provide 'nntp) + +;;; nntp.el ends here diff --git a/lisp/nnvirtual.el b/lisp/nnvirtual.el new file mode 100644 index 0000000..c814b27 --- /dev/null +++ b/lisp/nnvirtual.el @@ -0,0 +1,784 @@ +;;; nnvirtual.el --- virtual newsgroups access for Gnus +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. + +;; Author: David Moore +;; Lars Magne Ingebrigtsen +;; Masanobu UMEDA +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The other access methods (nntp, nnspool, etc) are general news +;; access methods. This module relies on Gnus and can not be used +;; separately. + +;;; Code: + +(require 'nntp) +(require 'nnheader) +(require 'gnus) +(require 'nnoo) +(require 'gnus-util) +(require 'gnus-start) +(require 'gnus-sum) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnvirtual) + +(defvoo nnvirtual-always-rescan nil + "*If non-nil, always scan groups for unread articles when entering a group. +If this variable is nil (which is the default) and you read articles +in a component group after the virtual group has been activated, the +read articles from the component group will show up when you enter the +virtual group.") + +(defvoo nnvirtual-component-regexp nil + "*Regexp to match component groups.") + +(defvoo nnvirtual-component-groups nil + "Component group in this nnvirtual group.") + + + +(defconst nnvirtual-version "nnvirtual 1.1") + +(defvoo nnvirtual-current-group nil) + +(defvoo nnvirtual-mapping-table nil + "Table of rules on how to map between component group and article number +to virtual article number.") + +(defvoo nnvirtual-mapping-offsets nil + "Table indexed by component group to an offset to be applied to article numbers in that group.") + +(defvoo nnvirtual-mapping-len 0 + "Number of articles in this virtual group.") + +(defvoo nnvirtual-mapping-reads nil + "Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.") + +(defvoo nnvirtual-mapping-marks nil + "Compressed marks alist for the virtual group as computed from the marks of individual component groups.") + +(defvoo nnvirtual-info-installed nil + "T if we have already installed the group info for this group, and shouldn't blast over it again.") + +(defvoo nnvirtual-status-string "") + +(eval-and-compile + (autoload 'gnus-cache-articles-in-group "gnus-cache")) + + + +;;; Interface functions. + +(nnoo-define-basics nnvirtual) + + +(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup + server fetch-old) + (when (nnvirtual-possibly-change-server server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (if (stringp (car articles)) + 'headers + (let ((vbuf (nnheader-set-temp-buffer + (get-buffer-create " *virtual headers*"))) + (carticles (nnvirtual-partition-sequence articles)) + (system-name (system-name)) + cgroup carticle article result prefix) + (while carticles + (setq cgroup (caar carticles)) + (setq articles (cdar carticles)) + (pop carticles) + (when (and articles + (gnus-check-server + (gnus-find-method-for-group cgroup) t) + (gnus-request-group cgroup t) + (setq prefix (gnus-group-real-prefix cgroup)) + ;; FIX FIX FIX we want to check the cache! + ;; This is probably evil if people have set + ;; gnus-use-cache to nil themselves, but I + ;; have no way of finding the true value of it. + (let ((gnus-use-cache t)) + (setq result (gnus-retrieve-headers + articles cgroup nil)))) + (set-buffer nntp-server-buffer) + ;; If we got HEAD headers, we convert them into NOV + ;; headers. This is slow, inefficient and, come to think + ;; of it, downright evil. So sue me. I couldn't be + ;; bothered to write a header parse routine that could + ;; parse a mixed HEAD/NOV buffer. + (when (eq result 'headers) + (nnvirtual-convert-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (delete-region (point) + (progn + (setq carticle (read nntp-server-buffer)) + (point))) + + ;; We remove this article from the articles list, if + ;; anything is left in the articles list after going through + ;; the entire buffer, then those articles have been + ;; expired or canceled, so we appropriately update the + ;; component group below. They should be coming up + ;; generally in order, so this shouldn't be slow. + (setq articles (delq carticle articles)) + + (setq article (nnvirtual-reverse-map-article cgroup carticle)) + (if (null article) + ;; This line has no reverse mapping, that means it + ;; was an extra article reference returned by nntp. + (progn + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Otherwise insert the virtual article number, + ;; and clean up the xrefs. + (princ article nntp-server-buffer) + (nnvirtual-update-xref-header cgroup carticle + prefix system-name) + (forward-line 1)) + ) + + (set-buffer vbuf) + (goto-char (point-max)) + (insert-buffer-substring nntp-server-buffer)) + ;; Anything left in articles is expired or canceled. + ;; Could be smart and not tell it about articles already known? + (when articles + (gnus-group-make-articles-read cgroup articles)) + ) + + ;; The headers are ready for reading, so they are inserted into + ;; the nntp-server-buffer, which is where Gnus expects to find + ;; them. + (prog1 + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring vbuf) + ;; FIX FIX FIX, we should be able to sort faster than + ;; this if needed, since each cgroup is sorted, we just + ;; need to merge + (sort-numeric-fields 1 (point-min) (point-max)) + 'nov) + (kill-buffer vbuf))))))) + + +(defvoo nnvirtual-last-accessed-component-group nil) + +(deffoo nnvirtual-request-article (article &optional group server buffer) + (when (nnvirtual-possibly-change-server server) + (if (stringp article) + ;; This is a fetch by Message-ID. + (cond + ((not nnvirtual-last-accessed-component-group) + (nnheader-report + 'nnvirtual "Don't know what server to request from")) + (t + (save-excursion + (when buffer + (set-buffer buffer)) + (let ((method (gnus-find-method-for-group + nnvirtual-last-accessed-component-group))) + (funcall (gnus-get-function method 'request-article) + article nil (nth 1 method) buffer))))) + ;; This is a fetch by number. + (let* ((amap (nnvirtual-map-article article)) + (cgroup (car amap))) + (cond + ((not amap) + (nnheader-report 'nnvirtual "No such article: %s" article)) + ((not (gnus-check-group cgroup)) + (nnheader-report + 'nnvirtual "Can't open server where %s exists" cgroup)) + ((not (gnus-request-group cgroup t)) + (nnheader-report 'nnvirtual "Can't open component group %s" cgroup)) + (t + (setq nnvirtual-last-accessed-component-group cgroup) + (if buffer + (save-excursion + (set-buffer buffer) + (gnus-request-article-this-buffer (cdr amap) cgroup)) + (gnus-request-article (cdr amap) cgroup)))))))) + + +(deffoo nnvirtual-open-server (server &optional defs) + (unless (assq 'nnvirtual-component-regexp defs) + (push `(nnvirtual-component-regexp ,server) + defs)) + (nnoo-change-server 'nnvirtual server defs) + (if nnvirtual-component-groups + t + (setq nnvirtual-mapping-table nil + nnvirtual-mapping-offsets nil + nnvirtual-mapping-len 0 + nnvirtual-mapping-reads nil + nnvirtual-mapping-marks nil + nnvirtual-info-installed nil) + (when nnvirtual-component-regexp + ;; Go through the newsrc alist and find all component groups. + (let ((newsrc (cdr gnus-newsrc-alist)) + group) + (while (setq group (car (pop newsrc))) + (when (string-match nnvirtual-component-regexp group) ; Match + ;; Add this group to the list of component groups. + (setq nnvirtual-component-groups + (cons group (delete group nnvirtual-component-groups))))))) + (if (not nnvirtual-component-groups) + (nnheader-report 'nnvirtual "No component groups: %s" server) + t))) + + +(deffoo nnvirtual-request-group (group &optional server dont-check) + (nnvirtual-possibly-change-server server) + (setq nnvirtual-component-groups + (delete (nnvirtual-current-group) nnvirtual-component-groups)) + (cond + ((null nnvirtual-component-groups) + (setq nnvirtual-current-group nil) + (nnheader-report 'nnvirtual "No component groups in %s" group)) + (t + (when (or (not dont-check) + nnvirtual-always-rescan) + (nnvirtual-create-mapping)) + (setq nnvirtual-current-group group) + (nnheader-insert "211 %d 1 %d %s\n" + nnvirtual-mapping-len nnvirtual-mapping-len group)))) + + +(deffoo nnvirtual-request-type (group &optional article) + (if (not article) + 'unknown + (let ((mart (nnvirtual-map-article article))) + (when mart + (gnus-request-type (car mart) (cdr mart)))))) + +(deffoo nnvirtual-request-update-mark (group article mark) + (let* ((nart (nnvirtual-map-article article)) + (cgroup (car nart)) + ;; The component group might be a virtual group. + (nmark (gnus-request-update-mark cgroup (cdr nart) mark))) + (when (and nart + (= mark nmark) + (gnus-group-auto-expirable-p cgroup)) + (setq mark gnus-expirable-mark))) + mark) + + +(deffoo nnvirtual-close-group (group &optional server) + (when (and (nnvirtual-possibly-change-server server) + (not (gnus-ephemeral-group-p (nnvirtual-current-group)))) + (nnvirtual-update-read-and-marked t t)) + t) + + +(deffoo nnvirtual-request-list (&optional server) + (nnheader-report 'nnvirtual "LIST is not implemented.")) + + +(deffoo nnvirtual-request-newgroups (date &optional server) + (nnheader-report 'nnvirtual "NEWGROUPS is not supported.")) + + +(deffoo nnvirtual-request-list-newsgroups (&optional server) + (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented.")) + + +(deffoo nnvirtual-request-update-info (group info &optional server) + (when (and (nnvirtual-possibly-change-server server) + (not nnvirtual-info-installed)) + ;; Install the precomputed lists atomically, so the virtual group + ;; is not left in a half-way state in case of C-g. + (gnus-atomic-progn + (setcar (cddr info) nnvirtual-mapping-reads) + (if (nthcdr 3 info) + (setcar (nthcdr 3 info) nnvirtual-mapping-marks) + (when nnvirtual-mapping-marks + (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks)))) + (setq nnvirtual-info-installed t)) + t)) + + +(deffoo nnvirtual-catchup-group (group &optional server all) + (when (and (nnvirtual-possibly-change-server server) + (not (gnus-ephemeral-group-p (nnvirtual-current-group)))) + ;; copy over existing marks first, in case they set anything + (nnvirtual-update-read-and-marked nil nil) + ;; do a catchup on all component groups + (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups)) + (gnus-expert-user t)) + ;; Make sure all groups are activated. + (mapcar + (lambda (g) + (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb)))) + (gnus-activate-group g))) + nnvirtual-component-groups) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-catchup-current nil all))))) + + +(deffoo nnvirtual-find-group-art (group article) + "Return the real group and article for virtual GROUP and ARTICLE." + (nnvirtual-map-article article)) + + +(deffoo nnvirtual-request-post (&optional server) + (if (not gnus-message-group-art) + (nnheader-report 'nnvirtual "Can't post to an nnvirtual group") + (let ((group (car (nnvirtual-find-group-art + (car gnus-message-group-art) + (cdr gnus-message-group-art))))) + (gnus-request-post (gnus-find-method-for-group group))))) + + +;;; Internal functions. + +(defun nnvirtual-convert-headers () + "Convert HEAD headers into NOV headers." + (save-excursion + (set-buffer nntp-server-buffer) + (let* ((dependencies (make-vector 100 0)) + (headers (gnus-get-newsgroup-headers dependencies)) + header) + (erase-buffer) + (while (setq header (pop headers)) + (nnheader-insert-nov header))))) + + +(defun nnvirtual-update-xref-header (group article prefix system-name) + "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." + ;; Move to beginning of Xref field, creating a slot if needed. + (beginning-of-line) + (looking-at + "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") + (goto-char (match-end 0)) + (unless (search-forward "\t" (gnus-point-at-eol) 'move) + (insert "\t")) + + ;; Remove any spaces at the beginning of the Xref field. + (while (= (char-after (1- (point))) ? ) + (forward-char -1) + (delete-char 1)) + + (insert "Xref: " system-name " " group ":") + (princ article (current-buffer)) + (insert " ") + + ;; If there were existing xref lines, clean them up to have the correct + ;; component server prefix. + (save-restriction + (narrow-to-region (point) + (or (search-forward "\t" (gnus-point-at-eol) t) + (gnus-point-at-eol))) + (goto-char (point-min)) + (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (when (re-search-forward + (concat (gnus-group-real-name group) ":[0-9]+") + nil t) + (replace-match "" t t)) + (unless (= (point) (point-max)) + (insert " ") + (when (not (string= "" prefix)) + (while (re-search-forward "[^ ]+:[0-9]+" nil t) + (save-excursion + (goto-char (match-beginning 0)) + (insert prefix)))))) + + ;; Ensure a trailing \t. + (end-of-line) + (or (= (char-after (1- (point))) ?\t) + (insert ?\t))) + + +(defun nnvirtual-possibly-change-server (server) + (or (not server) + (nnoo-current-server-p 'nnvirtual server) + (nnvirtual-open-server server))) + + +(defun nnvirtual-update-read-and-marked (read-p update-p) + "Copy marks from the virtual group to the component groups. +If READ-P is not nil, update the (un)read status of the components. +If UPDATE-P is not nil, call gnus-group-update-group on the components." + (when nnvirtual-current-group + (let ((unreads (and read-p + (nnvirtual-partition-sequence + (gnus-list-of-unread-articles + (nnvirtual-current-group))))) + (type-marks (mapcar (lambda (ml) + (cons (car ml) + (nnvirtual-partition-sequence (cdr ml)))) + (gnus-info-marks (gnus-get-info + (nnvirtual-current-group))))) + mark type groups carticles info entry) + + ;; Ok, atomically move all of the (un)read info, clear any old + ;; marks, and move all of the current marks. This way if someone + ;; hits C-g, you won't leave the component groups in a half-way state. + (gnus-atomic-progn + ;; move (un)read + (let ((gnus-newsgroup-active nil)) ;workaround guns-update-read-articles + (while (setq entry (pop unreads)) + (gnus-update-read-articles (car entry) (cdr entry)))) + + ;; clear all existing marks on the component groups + (setq groups nnvirtual-component-groups) + (while groups + (when (and (setq info (gnus-get-info (pop groups))) + (gnus-info-marks info)) + (gnus-info-set-marks info nil))) + + ;; Ok, currently type-marks is an assq list with keys of a mark type, + ;; with data of an assq list with keys of component group names + ;; and the articles which correspond to that key/group pair. + (while (setq mark (pop type-marks)) + (setq type (car mark)) + (setq groups (cdr mark)) + (while (setq carticles (pop groups)) + (gnus-add-marked-articles (car carticles) type (cdr carticles) + nil t)))) + + ;; possibly update the display, it is really slow + (when update-p + (setq groups nnvirtual-component-groups) + (while groups + (gnus-group-update-group (pop groups) t)))))) + + +(defun nnvirtual-current-group () + "Return the prefixed name of the current nnvirtual group." + (concat "nnvirtual:" nnvirtual-current-group)) + + + +;;; This is currently O(kn^2) to merge n lists of length k. +;;; You could do it in O(knlogn), but we have a small n, and the +;;; overhead of the other approach is probably greater. +(defun nnvirtual-merge-sorted-lists (&rest lists) + "Merge many sorted lists of numbers." + (if (null (cdr lists)) + (car lists) + (sort (apply 'nconc lists) '<))) + + +;;; We map between virtual articles and real articles in a manner +;;; which keeps the size of the virtual active list the same as +;;; the sum of the component active lists. +;;; To achieve fair mixing of the groups, the last article in +;;; each of N component groups will be in the the last N articles +;;; in the virtual group. + +;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and 6-7 +;;; resprectively, then the virtual article numbers look like: +;;; +;;; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 +;;; A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7 + +;;; To compute these mappings we generate a couple tables and then +;;; do some fast operations on them. Tables for the example above: +;;; +;;; Offsets - [(A 0) (B -3) (C -1)] +;;; +;;; a b c d e +;;; Mapping - ([ 3 0 1 3 0 ] +;;; [ 6 3 2 9 3 ] +;;; [ 8 6 3 15 9 ]) +;;; +;;; (note column 'e' is different in real algorithm, which is slightly +;;; different than described here, but this gives you the methodology.) +;;; +;;; The basic idea is this, when going from component->virtual, apply +;;; the appropriate offset to the article number. Then search the first +;;; column of the table for a row where 'a' is less than or equal to the +;;; modified number. You can see that only group A can therefore go to +;;; the first row, groups A and B to the second, and all to the last. +;;; The third column of the table is telling us the number of groups +;;; which might be able to reach that row (it might increase by more than +;;; 1 if several groups have the same size). +;;; Then column 'b' provides an additional offset you apply when you have +;;; found the correct row. You then multiply by 'c' and add on the groups +;;; _position_ in the offset table. The basic idea here is that on +;;; any given row we are going to map back and forth using X'=X*c+Y and +;;; X=(X'/c), Y=(X' mod c). Then once you've done this transformation, +;;; you apply a final offset from column 'e' to give the virtual article. +;;; +;;; Going the other direction, you instead search on column 'd' instead +;;; of 'a', and apply everything in reverse order. + +;;; Convert component -> virtual: +;;; set num = num - Offset(group) +;;; find first row in Mapping where num <= 'a' +;;; num = (num-'b')*c + Position(group) + 'e' + +;;; Convert virtual -> component: +;;; find first row in Mapping where num <= 'd' +;;; num = num - 'e' +;;; group_pos = num mod 'c' +;;; num = (num / 'c') + 'b' + Offset(group_pos) + +;;; Easy no? :) +;;; +;;; Well actually, you need to keep column e offset smaller by the 'c' +;;; column for that line, and always add 1 more when going from +;;; component -> virtual. Otherwise you run into a problem with +;;; unique reverse mapping. + +(defun nnvirtual-map-article (article) + "Return a cons of the component group and article corresponding to the given virtual ARTICLE." + (let ((table nnvirtual-mapping-table) + entry group-pos) + (while (and table + (> article (aref (car table) 3))) + (setq table (cdr table))) + (when (and table + (> article 0)) + (setq entry (car table)) + (setq article (- article (aref entry 4) 1)) + (setq group-pos (mod article (aref entry 2))) + (cons (car (aref nnvirtual-mapping-offsets group-pos)) + (+ (/ article (aref entry 2)) + (aref entry 1) + (cdr (aref nnvirtual-mapping-offsets group-pos))) + )) + )) + + + +(defun nnvirtual-reverse-map-article (group article) + "Return the virtual article number corresponding to the given component GROUP and ARTICLE." + (when (numberp article) + (let ((table nnvirtual-mapping-table) + (group-pos 0) + entry) + (while (not (string= group (car (aref nnvirtual-mapping-offsets + group-pos)))) + (setq group-pos (1+ group-pos))) + (setq article (- article (cdr (aref nnvirtual-mapping-offsets + group-pos)))) + (while (and table + (> article (aref (car table) 0))) + (setq table (cdr table))) + (setq entry (car table)) + (when (and entry + (> article 0) + (< group-pos (aref entry 2))) ; article not out of range below + (+ (aref entry 4) + group-pos + (* (- article (aref entry 1)) + (aref entry 2)) + 1)) + ))) + + +(defsubst nnvirtual-reverse-map-sequence (group articles) + "Return list of virtual article numbers for all ARTICLES in GROUP. +The ARTICLES should be sorted, and can be a compressed sequence. +If any of the article numbers has no corresponding virtual article, +then it is left out of the result." + (when (numberp (cdr-safe articles)) + (setq articles (list articles))) + (let (result a i j new-a) + (while (setq a (pop articles)) + (if (atom a) + (setq i a + j a) + (setq i (car a) + j (cdr a))) + (while (<= i j) + ;; If this is slow, you can optimize by moving article checking + ;; into here. You don't have to recompute the group-pos, + ;; nor scan the table every time. + (when (setq new-a (nnvirtual-reverse-map-article group i)) + (push new-a result)) + (setq i (1+ i)))) + (nreverse result))) + + +(defun nnvirtual-partition-sequence (articles) + "Return an association list of component article numbers. +These are indexed by elements of nnvirtual-component-groups, based on +the sequence ARTICLES of virtual article numbers. ARTICLES should be +sorted, and can be a compressed sequence. If any of the article +numbers has no corresponding component article, then it is left out of +the result." + (when (numberp (cdr-safe articles)) + (setq articles (list articles))) + (let ((carticles (mapcar (lambda (g) (list g)) + nnvirtual-component-groups)) + a i j article entry) + (while (setq a (pop articles)) + (if (atom a) + (setq i a + j a) + (setq i (car a) + j (cdr a))) + (while (<= i j) + (when (setq article (nnvirtual-map-article i)) + (setq entry (assoc (car article) carticles)) + (setcdr entry (cons (cdr article) (cdr entry)))) + (setq i (1+ i)))) + (mapcar (lambda (x) (setcdr x (nreverse (cdr x)))) + carticles) + carticles)) + + +(defun nnvirtual-create-mapping () + "Build the tables necessary to map between component (group, article) to virtual article. +Generate the set of read messages and marks for the virtual group +based on the marks on the component groups." + (let ((cnt 0) + (tot 0) + (M 0) + (i 0) + actives all-unreads all-marks + active min max size unreads marks + next-M next-tot + reads beg) + ;; Ok, we loop over all component groups and collect a lot of + ;; information: + ;; Into actives we place (g size max), where size is max-min+1. + ;; Into all-unreads we put (g unreads). + ;; Into all-marks we put (g marks). + ;; We also increment cnt and tot here, and compute M (max of sizes). + (mapc (lambda (g) + (setq active (gnus-activate-group g) + min (car active) + max (cdr active)) + (when (and active (>= max min) (not (zerop max))) + ;; store active information + (push (list g (- max min -1) max) actives) + ;; collect unread/mark info for later + (setq unreads (gnus-list-of-unread-articles g)) + (setq marks (gnus-info-marks (gnus-get-info g))) + (when gnus-use-cache + (push (cons 'cache + (gnus-cache-articles-in-group g)) + marks)) + (push (cons g unreads) all-unreads) + (push (cons g marks) all-marks) + ;; count groups, total #articles, and max size + (setq size (- max min -1)) + (setq cnt (1+ cnt) + tot (+ tot size) + M (max M size)))) + nnvirtual-component-groups) + + ;; Number of articles in the virtual group. + (setq nnvirtual-mapping-len tot) + + + ;; We want the actives list sorted by size, to build the tables. + (setq actives (sort actives (lambda (g1 g2) (< (nth 1 g1) (nth 1 g2))))) + + ;; Build the offset table. Largest sized groups are at the front. + (setq nnvirtual-mapping-offsets + (vconcat + (nreverse + (mapcar (lambda (entry) + (cons (nth 0 entry) + (- (nth 2 entry) M))) + actives)))) + + ;; Build the mapping table. + (setq nnvirtual-mapping-table nil) + (setq actives (mapcar (lambda (entry) (nth 1 entry)) actives)) + (while actives + (setq size (car actives)) + (setq next-M (- M size)) + (setq next-tot (- tot (* cnt size))) + ;; make current row in table + (push (vector M next-M cnt tot (- next-tot cnt)) + nnvirtual-mapping-table) + ;; update M and tot + (setq M next-M) + (setq tot next-tot) + ;; subtract the current size from all entries. + (setq actives (mapcar (lambda (x) (- x size)) actives)) + ;; remove anything that went to 0. + (while (and actives + (= (car actives) 0)) + (pop actives) + (setq cnt (- cnt 1)))) + + + ;; Now that the mapping tables are generated, we can convert + ;; and combine the separate component unreads and marks lists + ;; into single lists of virtual article numbers. + (setq unreads (apply 'nnvirtual-merge-sorted-lists + (mapcar (lambda (x) + (nnvirtual-reverse-map-sequence + (car x) (cdr x))) + all-unreads))) + (setq marks (mapcar + (lambda (type) + (cons (cdr type) + (gnus-compress-sequence + (apply + 'nnvirtual-merge-sorted-lists + (mapcar (lambda (x) + (nnvirtual-reverse-map-sequence + (car x) + (cdr (assq (cdr type) (cdr x))))) + all-marks))))) + gnus-article-mark-lists)) + + ;; Remove any empty marks lists, and store. + (setq nnvirtual-mapping-marks nil) + (while marks + (if (cdr (car marks)) + (push (car marks) nnvirtual-mapping-marks)) + (setq marks (cdr marks))) + + ;; We need to convert the unreads to reads. We compress the + ;; sequence as we go, otherwise it could be huge. + (while (and (<= (incf i) nnvirtual-mapping-len) + unreads) + (if (= i (car unreads)) + (setq unreads (cdr unreads)) + ;; try to get a range. + (setq beg i) + (while (and (<= (incf i) nnvirtual-mapping-len) + (not (= i (car unreads))))) + (setq i (- i 1)) + (if (= i beg) + (push i reads) + (push (cons beg i) reads)) + )) + (when (<= i nnvirtual-mapping-len) + (if (= i nnvirtual-mapping-len) + (push i reads) + (push (cons i nnvirtual-mapping-len) reads))) + + ;; Store the reads list for later use. + (setq nnvirtual-mapping-reads (nreverse reads)) + + ;; Throw flag to show we changed the info. + (setq nnvirtual-info-installed nil) + )) + +(provide 'nnvirtual) + +;;; nnvirtual.el ends here diff --git a/lisp/nnweb.el b/lisp/nnweb.el new file mode 100644 index 0000000..4cc1fc9 --- /dev/null +++ b/lisp/nnweb.el @@ -0,0 +1,690 @@ +;;; nnweb.el --- retrieving articles via web search engines +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Note: You need to have `url' and `w3' installed for this +;; backend to work. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'nnoo) +(require 'message) +(require 'gnus-util) +(require 'gnus) +(require 'w3) +(require 'url) +(require 'nnmail) +(ignore-errors + (require 'w3-forms)) + +(nnoo-declare nnweb) + +(defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/") + "Where nnweb will save its files.") + +(defvoo nnweb-type 'dejanews + "What search engine type is being used.") + +(defvar nnweb-type-definition + '((dejanews + (article . nnweb-dejanews-wash-article) + (map . nnweb-dejanews-create-mapping) + (search . nnweb-dejanews-search) + (address . "http://xp9.dejanews.com/dnquery.xp") + (identifier . nnweb-dejanews-identity)) + (reference + (article . nnweb-reference-wash-article) + (map . nnweb-reference-create-mapping) + (search . nnweb-reference-search) + (address . "http://www.reference.com/cgi-bin/pn/go") + (identifier . identity)) + (altavista + (article . nnweb-altavista-wash-article) + (map . nnweb-altavista-create-mapping) + (search . nnweb-altavista-search) + (address . "http://www.altavista.digital.com/cgi-bin/query") + (id . "/cgi-bin/news?id@%s") + (identifier . identity))) + "Type-definition alist.") + +(defvoo nnweb-search nil + "Search string to feed to DejaNews.") + +(defvoo nnweb-max-hits 100 + "Maximum number of hits to display.") + +(defvoo nnweb-ephemeral-p nil + "Whether this nnweb server is ephemeral.") + +;;; Internal variables + +(defvoo nnweb-articles nil) +(defvoo nnweb-buffer nil) +(defvoo nnweb-group-alist nil) +(defvoo nnweb-group nil) +(defvoo nnweb-hashtb nil) + +;;; Interface functions + +(nnoo-define-basics nnweb) + +(deffoo nnweb-retrieve-headers (articles &optional group server fetch-old) + (nnweb-possibly-change-server group server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (article header) + (while (setq article (pop articles)) + (when (setq header (cadr (assq article nnweb-articles))) + (nnheader-insert-nov header))) + 'nov))) + +(deffoo nnweb-request-scan (&optional group server) + (nnweb-possibly-change-server group server) + (setq nnweb-hashtb (gnus-make-hashtable 4095)) + (funcall (nnweb-definition 'map)) + (unless nnweb-ephemeral-p + (nnweb-write-active) + (nnweb-write-overview group))) + +(deffoo nnweb-request-group (group &optional server dont-check) + (nnweb-possibly-change-server nil server) + (when (and group + (not (equal group nnweb-group)) + (not nnweb-ephemeral-p)) + (let ((info (assoc group nnweb-group-alist))) + (setq nnweb-group group) + (setq nnweb-type (nth 2 info)) + (setq nnweb-search (nth 3 info)) + (unless dont-check + (nnweb-read-overview group)))) + (cond + ((not nnweb-articles) + (nnheader-report 'nnweb "No matching articles")) + (t + (let ((active (if nnweb-ephemeral-p + (cons (caar nnweb-articles) + (caar (last nnweb-articles))) + (cadr (assoc group nnweb-group-alist))))) + (nnheader-report 'nnweb "Opened group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (length nnweb-articles) + (car active) (cdr active) group))))) + +(deffoo nnweb-close-group (group &optional server) + (nnweb-possibly-change-server group server) + (when (gnus-buffer-live-p nnweb-buffer) + (save-excursion + (set-buffer nnweb-buffer) + (set-buffer-modified-p nil) + (kill-buffer nnweb-buffer))) + t) + +(deffoo nnweb-request-article (article &optional group server buffer) + (nnweb-possibly-change-server group server) + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (let* ((header (cadr (assq article nnweb-articles))) + (url (and header (mail-header-xref header)))) + (when (or (and url + (nnweb-fetch-url url)) + (and (stringp article) + (nnweb-definition 'id t) + (let ((fetch (nnweb-definition 'id)) + art) + (when (string-match "^<\\(.*\\)>$" article) + (setq art (match-string 1 article))) + (and fetch + art + (nnweb-fetch-url + (format fetch article)))))) + (unless nnheader-callback-function + (funcall (nnweb-definition 'article)) + (nnweb-decode-entities)) + (nnheader-report 'nnweb "Fetched article %s" article) + t)))) + +(deffoo nnweb-close-server (&optional server) + (when (and (nnweb-server-opened server) + (gnus-buffer-live-p nnweb-buffer)) + (save-excursion + (set-buffer nnweb-buffer) + (set-buffer-modified-p nil) + (kill-buffer nnweb-buffer))) + (nnoo-close-server 'nnweb server)) + +(deffoo nnweb-request-list (&optional server) + (nnweb-possibly-change-server nil server) + (save-excursion + (set-buffer nntp-server-buffer) + (nnmail-generate-active nnweb-group-alist) + t)) + +(deffoo nnweb-request-update-info (group info &optional server) + (nnweb-possibly-change-server group server) + ;;(setcar (cddr info) nil) + ) + +(deffoo nnweb-asynchronous-p () + t) + +(deffoo nnweb-request-create-group (group &optional server args) + (nnweb-possibly-change-server nil server) + (nnweb-request-delete-group group) + (push `(,group ,(cons 1 0) ,@args) nnweb-group-alist) + (nnweb-write-active) + t) + +(deffoo nnweb-request-delete-group (group &optional force server) + (nnweb-possibly-change-server group server) + (gnus-delete-assoc group nnweb-group-alist) + (gnus-delete-file (nnweb-overview-file group)) + t) + +(nnoo-define-skeleton nnweb) + +;;; Internal functions + +(defun nnweb-read-overview (group) + "Read the overview of GROUP and build the map." + (when (file-exists-p (nnweb-overview-file group)) + (nnheader-temp-write nil + (nnheader-insert-file-contents (nnweb-overview-file group)) + (goto-char (point-min)) + (let (header) + (while (not (eobp)) + (setq header (nnheader-parse-nov)) + (forward-line 1) + (push (list (mail-header-number header) + header (mail-header-xref header)) + nnweb-articles) + (nnweb-set-hashtb header (car nnweb-articles))))))) + +(defun nnweb-write-overview (group) + "Write the overview file for GROUP." + (nnheader-temp-write (nnweb-overview-file group) + (let ((articles nnweb-articles)) + (while articles + (nnheader-insert-nov (cadr (pop articles))))))) + +(defun nnweb-set-hashtb (header data) + (gnus-sethash (nnweb-identifier (mail-header-xref header)) + data nnweb-hashtb)) + +(defun nnweb-get-hashtb (url) + (gnus-gethash (nnweb-identifier url) nnweb-hashtb)) + +(defun nnweb-identifier (ident) + (funcall (nnweb-definition 'identifier) ident)) + +(defun nnweb-overview-file (group) + "Return the name of the overview file of GROUP." + (nnheader-concat nnweb-directory group ".overview")) + +(defun nnweb-write-active () + "Save the active file." + (nnheader-temp-write (nnheader-concat nnweb-directory "active") + (prin1 `(setq nnweb-group-alist ',nnweb-group-alist) (current-buffer)))) + +(defun nnweb-read-active () + "Read the active file." + (load (nnheader-concat nnweb-directory "active") t t t)) + +(defun nnweb-definition (type &optional noerror) + "Return the definition of TYPE." + (let ((def (cdr (assq type (assq nnweb-type nnweb-type-definition))))) + (when (and (not def) + (not noerror)) + (error "Undefined definition %s" type)) + def)) + +(defun nnweb-possibly-change-server (&optional group server) + (nnweb-init server) + (when server + (unless (nnweb-server-opened server) + (nnweb-open-server server))) + (unless nnweb-group-alist + (nnweb-read-active)) + (when group + (when (and (not nnweb-ephemeral-p) + (not (equal group nnweb-group))) + (nnweb-request-group group nil t)))) + +(defun nnweb-init (server) + "Initialize buffers and such." + (unless (gnus-buffer-live-p nnweb-buffer) + (setq nnweb-buffer + (save-excursion + (nnheader-set-temp-buffer + (format " *nnweb %s %s %s*" nnweb-type nnweb-search server)))))) + +(defun nnweb-fetch-url (url) + (save-excursion + (if (not nnheader-callback-function) + (let ((buf (current-buffer))) + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (url-insert-file-contents url) + (copy-to-buffer buf (point-min) (point-max)) + t)) + (nnweb-url-retrieve-asynch + url 'nnweb-callback (current-buffer) nnheader-callback-function) + t))) + +(defun nnweb-callback (buffer callback) + (when (gnus-buffer-live-p url-working-buffer) + (save-excursion + (set-buffer url-working-buffer) + (funcall (nnweb-definition 'article)) + (nnweb-decode-entities) + (set-buffer buffer) + (goto-char (point-max)) + (insert-buffer-substring url-working-buffer)) + (funcall callback t) + (gnus-kill-buffer url-working-buffer))) + +(defun nnweb-url-retrieve-asynch (url callback &rest data) + (let ((url-request-method "GET") + (old-asynch url-be-asynchronous) + (url-request-data nil) + (url-request-extra-headers nil) + (url-working-buffer (generate-new-buffer-name " *nnweb*"))) + (setq-default url-be-asynchronous t) + (save-excursion + (set-buffer (get-buffer-create url-working-buffer)) + (setq url-current-callback-data data + url-be-asynchronous t + url-current-callback-func callback) + (url-retrieve url)) + (setq-default url-be-asynchronous old-asynch))) + +(defun nnweb-encode-www-form-urlencoded (pairs) + "Return PAIRS encoded for forms." + (mapconcat + (function + (lambda (data) + (concat (w3-form-encode-xwfu (car data)) "=" + (w3-form-encode-xwfu (cdr data))))) + pairs "&")) + +(defun nnweb-fetch-form (url pairs) + (let ((url-request-data (nnweb-encode-www-form-urlencoded pairs)) + (url-request-method "POST") + (url-request-extra-headers + '(("Content-type" . "application/x-www-form-urlencoded")))) + (url-insert-file-contents url) + (setq buffer-file-name nil)) + t) + +(defun nnweb-decode-entities () + (goto-char (point-min)) + (while (re-search-forward "&\\([a-z]+\\);" nil t) + (replace-match (char-to-string (or (cdr (assq (intern (match-string 1)) + w3-html-entities)) + ?#)) + t t))) + +(defun nnweb-remove-markup () + (goto-char (point-min)) + (while (search-forward "" nil t) + (point-max)))) + (goto-char (point-min)) + (while (re-search-forward "<[^>]+>" nil t) + (replace-match "" t t))) + +;;; +;;; DejaNews functions. +;;; + +(defun nnweb-dejanews-create-mapping () + "Perform the search and create an number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (when (funcall (nnweb-definition 'search) nnweb-search) + (let ((i 0) + (more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + Subject Score Date Newsgroup Author + map url) + (while more + ;; Go through all the article hits on this page. + (goto-char (point-min)) + (nnweb-decode-entities) + (goto-char (point-min)) + (while (re-search-forward "^ +[0-9]+\\." nil t) + (narrow-to-region + (point) + (cond ((re-search-forward "^ +[0-9]+\\." nil t) + (match-beginning 0)) + ((search-forward "\n\n" nil t) + (point)) + (t + (point-max)))) + (goto-char (point-min)) + (when (looking-at ".*HREF=\"\\([^\"]+\\)\"") + (setq url (match-string 1))) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (replace-match " ")) + (goto-char (point-min)) + (while (re-search-forward "^ +\\([^:]+\\): +\\(.*\\)$" nil t) + (set (intern (match-string 1)) (match-string 2))) + (widen) + (when (string-match "#[0-9]+/[0-9]+ *$" Subject) + (setq Subject (substring Subject 0 (match-beginning 0)))) + (incf i) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" Newsgroup ") " Subject) Author Date + (concat "<" (nnweb-identifier url) "@dejanews>") + nil 0 (string-to-int Score) url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + ;; See whether there is a "Get next 20 hits" button here. + (if (or (not (re-search-forward + "HREF=\"\\([^\"]+\\)\">Get next" nil t)) + (>= i nnweb-max-hits)) + (setq more nil) + ;; Yup -- fetch it. + (setq more (match-string 1)) + (erase-buffer) + (url-insert-file-contents more))) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) 'car-less-than-car)))))) + +(defun nnweb-dejanews-wash-article () + (let ((case-fold-search t)) + (goto-char (point-min)) + (re-search-forward "
" nil t)
+    (delete-region (point-min) (point))
+    (re-search-forward "
" nil t) + (delete-region (point) (point-max)) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (and (looking-at " *$") + (not (eobp))) + (gnus-delete-line)) + (while (looking-at "\\(^[^ ]+:\\) *") + (replace-match "\\1 " t) + (forward-line 1)) + (when (re-search-forward "\n\n+" nil t) + (replace-match "\n" t t)) + (goto-char (point-min)) + (when (search-forward "[More Headers]" nil t) + (replace-match "" t t)))) + +(defun nnweb-dejanews-search (search) + (nnweb-fetch-form + (nnweb-definition 'address) + `(("query" . ,search) + ("defaultOp" . "AND") + ("svcclass" . "dncurrent") + ("maxhits" . "100") + ("format" . "verbose") + ("threaded" . "0") + ("showsort" . "score") + ("agesign" . "1") + ("ageweight" . "1"))) + t) + +(defun nnweb-dejanews-identity (url) + "Return an unique identifier based on URL." + (if (string-match "recnum=\\([0-9]+\\)" url) + (match-string 1 url) + url)) + +;;; +;;; InReference +;;; + +(defun nnweb-reference-create-mapping () + "Perform the search and create an number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (when (funcall (nnweb-definition 'search) nnweb-search) + (let ((i 0) + (more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + Subject Score Date Newsgroups From Message-ID + map url) + (while more + ;; Go through all the article hits on this page. + (goto-char (point-min)) + (search-forward "
" nil t) + (delete-region (point-min) (point)) + ;(nnweb-decode-entities) + (goto-char (point-min)) + (while (re-search-forward "^ +[0-9]+\\." nil t) + (narrow-to-region + (point) + (if (re-search-forward "^$" nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min)) + (when (looking-at ".*href=\"\\([^\"]+\\)\"") + (setq url (match-string 1))) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (replace-match " ")) + (goto-char (point-min)) + (while (re-search-forward "^\\([^:]+\\): \\(.*\\)$" nil t) + (set (intern (match-string 1)) (match-string 2))) + (widen) + (search-forward "" nil t) + (incf i) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" Newsgroups ") " Subject) From Date + Message-ID + nil 0 (string-to-int Score) url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + (setq more nil)) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) 'car-less-than-car)))))) + +(defun nnweb-reference-wash-article () + (let ((case-fold-search t)) + (goto-char (point-min)) + (re-search-forward "^
" nil t) + (delete-region (point-min) (point)) + (search-forward "
" nil t)
+    (forward-line -1)
+    (let ((body (point-marker)))
+      (search-forward "
" nil t) + (delete-region (point) (point-max)) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (looking-at " *$") + (gnus-delete-line)) + (narrow-to-region (point-min) body) + (while (and (re-search-forward "^$" nil t) + (not (eobp))) + (gnus-delete-line)) + (goto-char (point-min)) + (while (looking-at "\\(^[^ ]+:\\) *") + (replace-match "\\1 " t) + (forward-line 1)) + (goto-char (point-min)) + (when (re-search-forward "^References:" nil t) + (narrow-to-region + (point) (if (re-search-forward "^$\\|^[^:]+:" nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min)) + (while (not (eobp)) + (unless (looking-at "References") + (insert "\t") + (forward-line 1))) + (goto-char (point-min)) + (while (search-forward "," nil t) + (replace-match " " t t))) + (widen) + (set-marker body nil)))) + +(defun nnweb-reference-search (search) + (url-insert-file-contents + (concat + (nnweb-definition 'address) + "?" + (nnweb-encode-www-form-urlencoded + `(("search" . "advanced") + ("querytext" . ,search) + ("subj" . "") + ("name" . "") + ("login" . "") + ("host" . "") + ("organization" . "") + ("groups" . "") + ("keywords" . "") + ("choice" . "Search") + ("startmonth" . "Jul") + ("startday" . "25") + ("startyear" . "1996") + ("endmonth" . "Aug") + ("endday" . "24") + ("endyear" . "1996") + ("mode" . "Quick") + ("verbosity" . "Verbose") + ("ranking" . "Relevance") + ("first" . "1") + ("last" . "25") + ("score" . "50"))))) + (setq buffer-file-name nil) + t) + +;;; +;;; Alta Vista +;;; + +(defun nnweb-altavista-create-mapping () + "Perform the search and create an number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (let ((part 0)) + (when (funcall (nnweb-definition 'search) nnweb-search part) + (let ((i 0) + (more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + subject date from id group + map url) + (while more + ;; Go through all the article hits on this page. + (goto-char (point-min)) + (search-forward "
" nil t) + (delete-region (point-min) (match-beginning 0)) + (goto-char (point-min)) + (while (search-forward "
" nil t) + (replace-match "\n")) + (nnweb-decode-entities) + (goto-char (point-min)) + (while (re-search-forward ".*href=\"\\([^\"]+\\)\">\\([^>]*\\)
\\([^-]+\\)- \\([^<]+\\)<.*href=\"news:\\([^\"]+\\)\">.*\">\\(.+\\)

" + nil t) + (setq url (match-string 1) + subject (match-string 2) + date (match-string 3) + group (match-string 4) + id (concat "<" (match-string 5) ">") + from (match-string 6)) + (incf i) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" group ") " subject) from date + id nil 0 0 url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + ;; See if we want more. + (when (or (not nnweb-articles) + (>= i nnweb-max-hits) + (not (funcall (nnweb-definition 'search) + nnweb-search (incf part)))) + (setq more nil))) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) 'car-less-than-car))))))) + +(defun nnweb-altavista-wash-article () + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (re-search-forward "^" nil t) + (delete-region (point-min) (match-beginning 0))) + (goto-char (point-min)) + (while (looking-at "\\([^ ]+\\) + +\\(.*\\)$") + (replace-match "\\1: \\2" t) + (forward-line 1)) + (when (re-search-backward "^References:" nil t) + (narrow-to-region (point) (progn (forward-line 1) (point))) + (goto-char (point-min)) + (while (re-search-forward "[0-9]+" nil t) + (replace-match "<\\1> " t))) + (widen) + (nnweb-remove-markup))) + +(defun nnweb-altavista-search (search &optional part) + (url-insert-file-contents + (concat + (nnweb-definition 'address) + "?" + (nnweb-encode-www-form-urlencoded + `(("pg" . "aq") + ("what" . "news") + ,@(when part `(("stq" . ,(int-to-string (* part 30))))) + ("fmt" . "d") + ("q" . ,search) + ("r" . "") + ("d0" . "") + ("d1" . ""))))) + (setq buffer-file-name nil) + t) + +(provide 'nnweb) + +;;; nnweb.el ends here diff --git a/lisp/parse-time.el b/lisp/parse-time.el new file mode 100644 index 0000000..e25abbb --- /dev/null +++ b/lisp/parse-time.el @@ -0,0 +1,199 @@ +;;; parse-time.el --- Parsing time strings + +;; Copyright (C) 1996 by Free Software Foundation, Inc. + +;; Author: Erik Naggum +;; Keywords: util + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; With the introduction of the `encode-time', `decode-time', and +;; `format-time-string' functions, dealing with time became simpler in +;; Emacs. However, parsing time strings is still largely a matter of +;; heuristics and no common interface has been designed. + +;; `parse-time-string' parses a time in a string and returns a list of 9 +;; values, just like `decode-time', where unspecified elements in the +;; string are returned as nil. `encode-time' may be applied on these +;; valuse to obtain an internal time value. + +;;; Code: + +(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it + +(put 'parse-time-syntax 'char-table-extra-slots 0) + +(defvar parse-time-syntax (make-char-table 'parse-time-syntax)) +(defvar parse-time-digits (make-char-table 'parse-time-syntax)) + +;; Byte-compiler warnings +(defvar elt) +(defvar val) + +(unless (aref parse-time-digits ?0) + (loop for i from ?0 to ?9 + do (set-char-table-range parse-time-digits i (- i ?0)))) + +(unless (aref parse-time-syntax ?0) + (loop for i from ?0 to ?9 + do (set-char-table-range parse-time-syntax i ?0)) + (loop for i from ?A to ?Z + do (set-char-table-range parse-time-syntax i ?A)) + (loop for i from ?a to ?z + do (set-char-table-range parse-time-syntax i ?a)) + (set-char-table-range parse-time-syntax ?+ 1) + (set-char-table-range parse-time-syntax ?- -1) + (set-char-table-range parse-time-syntax ?: ?d) + ) + +(defsubst digit-char-p (char) + (aref parse-time-digits char)) + +(defsubst parse-time-string-chars (char) + (aref parse-time-syntax char)) + +(put 'parse-error 'error-conditions '(parse-error error)) +(put 'parse-error 'error-message "Parsing error") + +(defsubst parse-integer (string &optional start end) + "[CL] Parse and return the integer in STRING, or nil if none." + (let ((integer 0) + (digit 0) + (index (or start 0)) + (end (or end (length string)))) + (when (< index end) + (let ((sign (aref string index))) + (if (or (eq sign ?+) (eq sign ?-)) + (setq sign (parse-time-string-chars sign) + index (1+ index)) + (setq sign 1)) + (while (and (< index end) + (setq digit (digit-char-p (aref string index)))) + (setq integer (+ (* integer 10) digit) + index (1+ index))) + (if (/= index end) + (signal 'parse-error `("not an integer" ,(substring string (or start 0) end))) + (* sign integer)))))) + +(defun parse-time-tokenize (string) + "Tokenize STRING into substrings." + (let ((start nil) + (end (length string)) + (all-digits nil) + (list ()) + (index 0) + (c nil)) + (while (< index end) + (while (and (< index end) ;skip invalid characters + (not (setq c (parse-time-string-chars (aref string index))))) + (incf index)) + (setq start index all-digits (eq c ?0)) + (while (and (< (incf index) end) ;scan valid characters + (setq c (parse-time-string-chars (aref string index)))) + (setq all-digits (and all-digits (eq c ?0)))) + (if (<= index end) + (push (if all-digits (parse-integer string start index) + (substring string start index)) + list))) + (nreverse list))) + +(defvar parse-time-months '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) + ("Apr" . 4) ("May" . 5) ("Jun" . 6) + ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) + ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))) +(defvar parse-time-weekdays '(("Sun" . 0) ("Mon" . 1) ("Tue" . 2) + ("Wed" . 3) ("Thu" . 4) ("Fri" . 5) ("Sat" . 6))) +(defvar parse-time-zoneinfo `(("Z" 0) ("UT" 0) ("GMT" 0) + ("PST" ,(* -8 3600)) ("PDT" ,(* -7 3600) t) + ("MST" ,(* -7 3600)) ("MDT" ,(* -6 3600) t) + ("CST" ,(* -6 3600)) ("CDT" ,(* -5 3600) t) + ("EST" ,(* -5 3600)) ("EDT" ,(* -4 3600) t)) + "(zoneinfo seconds-off daylight-savings-time-p)") + +(defvar parse-time-rules + `(((6) parse-time-weekdays) + ((3) (1 31)) + ((4) parse-time-months) + ((5) (1970 2038)) + ((2 1 0) + ,#'(lambda () (and (stringp elt) + (= (length elt) 8) + (= (aref elt 2) ?:) + (= (aref elt 5) ?:))) + [0 2] [3 5] [6 8]) + ((8 7) parse-time-zoneinfo + ,#'(lambda () (car val)) + ,#'(lambda () (cadr val))) + ((8) + ,#'(lambda () + (and (stringp elt) + (= 5 (length elt)) + (or (= (aref elt 0) ?+) (= (aref elt 0) ?-)))) + ,#'(lambda () (* 60 (+ (parse-integer elt 3 5) + (* 60 (parse-integer elt 1 3))) + (if (= (aref elt 0) ?-) -1 1)))) + ((5 4 3) + ,#'(lambda () (and (stringp elt) (= (length elt) 10) (= (aref elt 4) ?-) (= (aref elt 7) ?-))) + [0 4] [5 7] [8 10]) + ((2 1) + ,#'(lambda () (and (stringp elt) (= (length elt) 5) (= (aref elt 2) ?:))) + [0 2] [3 5]) + ((5) (70 99) ,#'(lambda () (+ 1900 elt)))) + "(slots predicate extractor...)") + +(defun parse-time-string (string) + "Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). +The values are identical to those of `decode-time', but any values that are +unknown are returned as nil." + (let ((time (list nil nil nil nil nil nil nil nil nil nil)) + (temp (parse-time-tokenize string))) + (while temp + (let ((elt (pop temp)) + (rules parse-time-rules) + (exit nil)) + (while (and (not (null rules)) (not exit)) + (let* ((rule (pop rules)) + (slots (pop rule)) + (predicate (pop rule)) + (val)) + (if (and (not (nth (car slots) time)) ;not already set + (setq val (cond ((and (consp predicate) + (not (eq (car predicate) 'lambda))) + (and (numberp elt) + (<= (car predicate) elt) + (<= elt (cadr predicate)) + elt)) + ((symbolp predicate) + (cdr (assoc elt (symbol-value predicate)))) + ((funcall predicate))))) + (progn + (setq exit t) + (while slots + (let ((new-val (and rule + (let ((this (pop rule))) + (if (vectorp this) + (parse-integer elt (aref this 0) (aref this 1)) + (funcall this)))))) + (rplaca (nthcdr (pop slots) time) (or new-val val)))))))))) + time)) + +(provide 'parse-time) + +;;; parse-time.el ends here diff --git a/lisp/pop3.el b/lisp/pop3.el new file mode 100644 index 0000000..b76e74f --- /dev/null +++ b/lisp/pop3.el @@ -0,0 +1,462 @@ +;;; pop3.el --- Post Office Protocol (RFC 1460) interface + +;; Copyright (C) 1996,1997 Free Software Foundation, Inc. + +;; Author: Richard L. Pieri +;; Keywords: mail, pop3 +;; Version: 1.3g + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands +;; are implemented. The LIST command has not been implemented due to lack +;; of actual usefulness. +;; The optional POP3 command TOP has not been implemented. + +;; This program was inspired by Kyle E. Jones's vm-pop program. + +;;; Code: + +(require 'mail-utils) +(provide 'pop3) + +(defconst pop3-version "1.3g") + +(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil) + "*POP3 maildrop.") +(defvar pop3-mailhost (or (getenv "MAILHOST") nil) + "*POP3 mailhost.") +(defvar pop3-port 110 + "*POP3 port.") + +(defvar pop3-password-required t + "*Non-nil if a password is required when connecting to POP server.") +(defvar pop3-password nil + "*Password to use when connecting to POP server.") + +(defvar pop3-authentication-scheme 'pass + "*POP3 authentication scheme. +Defaults to 'pass, for the standard USER/PASS authentication. Other valid +values are 'apop.") + +(defvar pop3-timestamp nil + "Timestamp returned when initially connected to the POP server. +Used for APOP authentication.") + +(defvar pop3-movemail-file-coding-system nil + "Crashbox made by pop3-movemail with this coding system.") + +(defvar pop3-read-point nil) +(defvar pop3-debug nil) + +(defun pop3-movemail (&optional crashbox) + "Transfer contents of a maildrop to the specified CRASHBOX." + (or crashbox (setq crashbox (expand-file-name "~/.crashbox"))) + (let* ((process (pop3-open-server pop3-mailhost pop3-port)) + (crashbuf (get-buffer-create " *pop3-retr*")) + (n 1) + message-count) + ;; for debugging only + (if pop3-debug (switch-to-buffer (process-buffer process))) + (cond ((equal 'apop pop3-authentication-scheme) + (pop3-apop process pop3-maildrop)) + ((equal 'pass pop3-authentication-scheme) + (pop3-user process pop3-maildrop) + (pop3-pass process)) + (t (error "Invalid POP3 authentication scheme."))) + (setq message-count (car (pop3-stat process))) + (while (<= n message-count) + (message (format "Retrieving message %d of %d from %s..." + n message-count pop3-mailhost)) + (pop3-retr process n crashbuf) + (save-excursion + (set-buffer crashbuf) + (let ((coding-system-for-write pop3-movemail-file-coding-system)) + (append-to-file (point-min) (point-max) crashbox)) + (set-buffer (process-buffer process)) + (while (> (buffer-size) 5000) + (goto-char (point-min)) + (forward-line 50) + (delete-region (point-min) (point)))) + (pop3-dele process n) + (setq n (+ 1 n)) + (if pop3-debug (sit-for 1) (sit-for 0.1)) + ) + (pop3-quit process) + (kill-buffer crashbuf) + ) + ) + +(defun pop3-open-server (mailhost port) + "Open TCP connection to MAILHOST. +Returns the process associated with the connection." + (let ((process-buffer + (get-buffer-create (format "trace of POP session to %s" mailhost))) + (process)) + (save-excursion + (set-buffer process-buffer) + (erase-buffer)) + (setq process + (open-network-stream "POP" process-buffer mailhost port)) + (setq pop3-read-point (point-min)) + (let ((response (pop3-read-response process t))) + (setq pop3-timestamp + (substring response (or (string-match "<" response) 0) + (+ 1 (or (string-match ">" response) -1))))) + process + )) + +;; Support functions + +(defun pop3-process-filter (process output) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert output))) + +(defun pop3-send-command (process command) + (set-buffer (process-buffer process)) + (goto-char (point-max)) +;; (if (= (aref command 0) ?P) +;; (insert "PASS \r\n") +;; (insert command "\r\n")) + (setq pop3-read-point (point)) + (goto-char (point-max)) + (process-send-string process command) + (process-send-string process "\r\n") + ) + +(defun pop3-read-response (process &optional return) + "Read the response from the server. +Return the response string if optional second argument is non-nil." + (let ((case-fold-search nil) + match-end) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char pop3-read-point) + (while (not (search-forward "\r\n" nil t)) + (accept-process-output process 3) + (goto-char pop3-read-point)) + (setq match-end (point)) + (goto-char pop3-read-point) + (if (looking-at "-ERR") + (error (buffer-substring (point) (- match-end 2))) + (if (not (looking-at "+OK")) + (progn (setq pop3-read-point match-end) nil) + (setq pop3-read-point match-end) + (if return + (buffer-substring (point) match-end) + t) + ))))) + +(defun pop3-string-to-list (string &optional regexp) + "Chop up a string into a list." + (let ((list) + (regexp (or regexp " ")) + (string (if (string-match "\r" string) + (substring string 0 (match-beginning 0)) + string))) + (store-match-data nil) + (while string + (if (string-match regexp string) + (setq list (cons (substring string 0 (- (match-end 0) 1)) list) + string (substring string (match-end 0))) + (setq list (cons string list) + string nil))) + (nreverse list))) + +(defvar pop3-read-passwd nil) +(defun pop3-read-passwd (prompt) + (if (not pop3-read-passwd) + (if (load "passwd" t) + (setq pop3-read-passwd 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq pop3-read-passwd 'ange-ftp-read-passwd))) + (funcall pop3-read-passwd prompt)) + +(defun pop3-clean-region (start end) + (setq end (set-marker (make-marker) end)) + (save-excursion + (goto-char start) + (while (and (< (point) end) (search-forward "\r\n" end t)) + (replace-match "\n" t t)) + (goto-char start) + (while (and (< (point) end) (re-search-forward "^\\." end t)) + (replace-match "" t t) + (forward-char))) + (set-marker end nil)) + +(defun pop3-munge-message-separator (start end) + "Check to see if a message separator exists. If not, generate one." + (if (not (fboundp 'message-make-date)) (autoload 'message-make-date "message")) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (if (not (or (looking-at "From .?") ; Unix mail + (looking-at "\001\001\001\001\n") ; MMDF + (looking-at "BABYL OPTIONS:") ; Babyl + )) + (let ((from (mail-strip-quoted-names (mail-fetch-field "From"))) + (date (pop3-string-to-list (or (mail-fetch-field "Date") + (message-make-date)))) + (From_)) + ;; sample date formats I have seen + ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT) + ;; Date: 08 Jul 1996 23:22:24 -0400 + ;; should be + ;; Tue Jul 9 09:04:21 1996 + (setq date + (cond ((string-match "[A-Z]" (nth 0 date)) + (format "%s %s %s %s %s" + (nth 0 date) (nth 2 date) (nth 1 date) + (nth 4 date) (nth 3 date))) + (t + ;; this really needs to be better but I don't feel + ;; like writing a date to day converter. + (format "Sun %s %s %s %s" + (nth 1 date) (nth 0 date) + (nth 3 date) (nth 2 date))) + )) + (setq From_ (format "\nFrom %s %s\n" from date)) + (while (string-match "," From_) + (setq From_ (concat (substring From_ 0 (match-beginning 0)) + (substring From_ (match-end 0))))) + (goto-char (point-min)) + (insert From_)))))) + +;; The Command Set + +;; AUTHORIZATION STATE + +(defun pop3-user (process user) + "Send USER information to POP3 server." + (pop3-send-command process (format "USER %s" user)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (error (format "USER %s not valid." user))))) + +(defun pop3-pass (process) + "Send authentication information to the server." + (let ((pass pop3-password)) + (if (and pop3-password-required (not pass)) + (setq pass + (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (if pass + (progn + (pop3-send-command process (format "PASS %s" pass)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process))))) + )) + +(defvar pop3-md5-program "md5" + "*Program to encode its input in MD5.") + +(defun pop3-md5 (string) + (nnheader-temp-write nil + (insert string) + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t (current-buffer) nil + "-c" pop3-md5-program) + ;; The meaningful output is the first 32 characters. + ;; Don't return the newline that follows them! + (buffer-substring (point-min) (+ (point-min) 32)))) + +(defun pop3-apop (process user) + "Send alternate authentication information to the server." + (let ((pass pop3-password)) + (if (and pop3-password-required (not pass)) + (setq pass + (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (if pass + (let ((hash (pop3-md5 (concat pop3-timestamp pass)))) + (pop3-send-command process (format "APOP %s %s" user hash)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process))))) + )) + +;; TRANSACTION STATE + +(defun pop3-stat (process) + "Return the number of messages in the maildrop and the maildrop's size." + (pop3-send-command process "STAT") + (let ((response (pop3-read-response process t))) + (list (string-to-int (nth 1 (pop3-string-to-list response))) + (string-to-int (nth 2 (pop3-string-to-list response)))) + )) + +(defun pop3-list (process &optional msg) + "Scan listing of available messages. +This function currently does nothing.") + +(defun pop3-retr (process msg crashbuf) + "Retrieve message-id MSG to buffer CRASHBUF." + (pop3-send-command process (format "RETR %s" msg)) + (pop3-read-response process) + (let ((start pop3-read-point) end) + (save-excursion + (set-buffer (process-buffer process)) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (accept-process-output process 3) + ;; bill@att.com ... to save wear and tear on the heap + (if (> (buffer-size) 20000) (sleep-for 1)) + (if (> (buffer-size) 50000) (sleep-for 1)) + (if (> (buffer-size) 100000) (sleep-for 1)) + (if (> (buffer-size) 200000) (sleep-for 1)) + (if (> (buffer-size) 500000) (sleep-for 1)) + ;; bill@att.com + (goto-char start)) + (setq pop3-read-point (point-marker)) +;; this code does not seem to work for some POP servers... +;; and I cannot figure out why not. +; (goto-char (match-beginning 0)) +; (backward-char 2) +; (if (not (looking-at "\r\n")) +; (insert "\r\n")) +; (re-search-forward "\\.\r\n") + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (pop3-clean-region start end) + (pop3-munge-message-separator start end) + (save-excursion + (set-buffer crashbuf) + (erase-buffer)) + (copy-to-buffer crashbuf start end) + (delete-region start end) + ))) + +(defun pop3-dele (process msg) + "Mark message-id MSG as deleted." + (pop3-send-command process (format "DELE %s" msg)) + (pop3-read-response process)) + +(defun pop3-noop (process msg) + "No-operation." + (pop3-send-command process "NOOP") + (pop3-read-response process)) + +(defun pop3-last (process) + "Return highest accessed message-id number for the session." + (pop3-send-command process "LAST") + (let ((response (pop3-read-response process t))) + (string-to-int (nth 1 (pop3-string-to-list response))) + )) + +(defun pop3-rset (process) + "Remove all delete marks from current maildrop." + (pop3-send-command process "RSET") + (pop3-read-response process)) + +;; UPDATE + +(defun pop3-quit (process) + "Close connection to POP3 server. +Tell server to remove all messages marked as deleted, unlock the maildrop, +and close the connection." + (pop3-send-command process "QUIT") + (pop3-read-response process t) + (if process + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (delete-process process)))) + +;; Summary of POP3 (Post Office Protocol version 3) commands and responses + +;;; AUTHORIZATION STATE + +;; Initial TCP connection +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [POP3 server ready] + +;; USER name +;; Arguments: a server specific user-id (required) +;; Restrictions: authorization state [after unsuccessful USER or PASS +;; Possible responses: +;; +OK [valid user-id] +;; -ERR [invalid user-id] + +;; PASS string +;; Arguments: a server/user-id specific password (required) +;; Restrictions: authorization state, after successful USER +;; Possible responses: +;; +OK [maildrop locked and ready] +;; -ERR [invalid password] +;; -ERR [unable to lock maildrop] + +;;; TRANSACTION STATE + +;; STAT +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn mm [# of messages, size of maildrop] + +;; LIST [msg] +;; Arguments: a message-id (optional) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [scan listing follows] +;; -ERR [no such message] + +;; RETR msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message contents follow] +;; -ERR [no such message] + +;; DELE msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message deleted] +;; -ERR [no such message] + +;; NOOP +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK + +;; LAST +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn [highest numbered message accessed] + +;; RSET +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK [all delete marks removed] + +;;; UPDATE STATE + +;; QUIT +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [TCP connection closed] diff --git a/lisp/score-mode.el b/lisp/score-mode.el new file mode 100644 index 0000000..fdb8d71 --- /dev/null +++ b/lisp/score-mode.el @@ -0,0 +1,109 @@ +;;; score-mode.el --- mode for editing Gnus score files +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'easymenu) +(require 'timezone) +(eval-when-compile (require 'cl)) + +(defvar gnus-score-mode-hook nil + "*Hook run in score mode buffers.") + +(defvar gnus-score-menu-hook nil + "*Hook run after creating the score mode menu.") + +(defvar gnus-score-edit-exit-function nil + "Function run on exit from the score buffer.") + +(defvar gnus-score-mode-map nil) +(unless gnus-score-mode-map + (setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map)) + (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-exit) + (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date) + (define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print)) + +;;;###autoload +(defun gnus-score-mode () + "Mode for editing Gnus score files. +This mode is an extended emacs-lisp mode. + +\\{gnus-score-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map gnus-score-mode-map) + (gnus-score-make-menu-bar) + (set-syntax-table emacs-lisp-mode-syntax-table) + (setq major-mode 'gnus-score-mode) + (setq mode-name "Score") + (lisp-mode-variables nil) + (make-local-variable 'gnus-score-edit-exit-function) + (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook)) + +(defun gnus-score-make-menu-bar () + (unless (boundp 'gnus-score-menu) + (easy-menu-define + gnus-score-menu gnus-score-mode-map "" + '("Score" + ["Exit" gnus-score-edit-exit t] + ["Insert date" gnus-score-edit-insert-date t] + ["Format" gnus-score-pretty-print t])) + (run-hooks 'gnus-score-menu-hook))) + +(defun gnus-score-edit-insert-date () + "Insert date in numerical format." + (interactive) + (princ (gnus-score-day-number (current-time)) (current-buffer))) + +(defun gnus-score-pretty-print () + "Format the current score file." + (interactive) + (goto-char (point-min)) + (let ((form (read (current-buffer)))) + (erase-buffer) + (pp form (current-buffer))) + (goto-char (point-min))) + +(defun gnus-score-edit-exit () + "Stop editing the score file." + (interactive) + (unless (file-exists-p (file-name-directory (buffer-file-name))) + (make-directory (file-name-directory (buffer-file-name)) t)) + (save-buffer) + (bury-buffer (current-buffer)) + (let ((buf (current-buffer))) + (when gnus-score-edit-exit-function + (funcall gnus-score-edit-exit-function)) + (when (eq buf (current-buffer)) + (switch-to-buffer (other-buffer (current-buffer)))))) + +(defun gnus-score-day-number (time) + (let ((dat (decode-time time))) + (timezone-absolute-from-gregorian + (nth 4 dat) (nth 3 dat) (nth 5 dat)))) + +(provide 'score-mode) + +;;; score-mode.el ends here diff --git a/lisp/smiley.el b/lisp/smiley.el new file mode 100644 index 0000000..2a66080 --- /dev/null +++ b/lisp/smiley.el @@ -0,0 +1,277 @@ +;;; smiley.el --- displaying smiley faces +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Wes Hardaker +;; Keywords: fun + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; +;; comments go here. +;; + +;;; Test smileys: :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-( + +;; To use: +;; (require 'smiley) +;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t) + +;; The smilies were drawn by Joe Reiss . + +(require 'annotations) +(require 'messagexmas) +(require 'cl) +(require 'custom) + +(defgroup smiley nil + "Turn :-)'s into real images (XEmacs)." + :group 'gnus-visual) + +(defcustom smiley-data-directory (message-xmas-find-glyph-directory "smilies") + "Location of the smiley faces files." + :type 'directory + :group 'smiley) + +;; Notice the subtle differences in the regular expressions in the +;; two alists below. + +(defcustom smiley-deformed-regexp-alist + '(("\\(\\^_?\\^;;;\\)\\W" 1 "WideFaceAse3.xbm") + ("\\(\\^_?\\^;;\\)\\W" 1 "WideFaceAse2.xbm") + ("\\(\\^_?\\^;\\)\\W" 1 "WideFaceAse1.xbm") + ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm") + ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm") + ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm") + ("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm") + ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") + ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm") + ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm") + ("\\(=[)>»]+\\)\\W" 1 "FaceHappy.xpm") + ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm") + ("\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm") + ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm") + ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm") + ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm") + ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm") + ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm") + ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm") + ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm") + ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm") + ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm") + ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm")) + "Normal and deformed faces for smilies." + :type '(repeat (list regexp + (integer :tag "Match") + (string :tag "Image"))) + :group 'smiley) + +(defcustom smiley-nosey-regexp-alist + '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm") + ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") + ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm") + ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm") + ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") + ("\\(=[)>]+\\)\\W" 1 "FaceHappy.xpm") + ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm") + ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm") + ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm") + ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm") + ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm") + ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm") + ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm") + ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm") + ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm") + ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm") + ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm") + ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm") + ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm")) + "Smileys with noses. These get less false matches." + :type '(repeat (list regexp + (integer :tag "Match") + (string :tag "Image"))) + :group 'smiley) + +(defcustom smiley-regexp-alist smiley-deformed-regexp-alist + "A list of regexps to map smilies to real images. +Defaults to the contents of `smiley-deformed-regexp-alist'. +An alternative is `smiley-nosey-regexp-alist' that matches less +aggressively. +If this is a symbol, take its value." + :type '(radio (variable-item smiley-deformed-regexp-alist) + (variable-item smiley-nosey-regexp-alist) + symbol + (repeat (list regexp + (integer :tag "Match") + (string :tag "Image")))) + :group 'smiley) + +(defcustom smiley-flesh-color "yellow" + "Flesh color." + :type 'string + :group 'smiley) + +(defcustom smiley-features-color "black" + "Features color." + :type 'string + :group 'smiley) + +(defcustom smiley-tongue-color "red" + "Tongue color." + :type 'string + :group 'smiley) + +(defcustom smiley-circle-color "black" + "Circle color." + :type 'string + :group 'smiley) + +(defcustom smiley-mouse-face 'highlight + "Face used for mouse highlighting in the smiley buffer. + +Smiley buttons will be displayed in this face when the cursor is +above them." + :type 'face + :group 'smiley) + + +(defvar smiley-glyph-cache nil) +(defvar smiley-running-xemacs (string-match "XEmacs" emacs-version)) + +(defvar smiley-map (make-sparse-keymap "smiley-keys") + "Keymap to toggle smiley states.") + +(define-key smiley-map [(button2)] 'smiley-toggle-extent) + +(defun smiley-create-glyph (smiley pixmap) + (and + smiley-running-xemacs + (or + (cdr-safe (assoc pixmap smiley-glyph-cache)) + (let* ((xpm-color-symbols + (and (featurep 'xpm) + (append `(("flesh" ,smiley-flesh-color) + ("features" ,smiley-features-color) + ("tongue" ,smiley-tongue-color)) + xpm-color-symbols))) + (glyph (make-glyph + (list + (cons 'x (expand-file-name pixmap smiley-data-directory)) + (cons 'tty smiley))))) + (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache)) + (set-glyph-face glyph 'default) + glyph)))) + +;;;###autoload +(defun smiley-region (beg end) + "Smilify the region between point and mark." + (interactive "r") + (smiley-buffer (current-buffer) beg end)) + +(defun smiley-toggle-extent (event) + "Toggle smiley at given point" + (interactive "e") + (let* ((ant (event-glyph-extent event)) + (pt (event-closest-point event)) + ext) + (if (annotationp ant) + (when (extentp (setq ext (extent-property ant 'smiley-extent))) + (set-extent-property ext 'invisible nil) + (hide-annotation ant)) + (when pt + (while (setq ext (extent-at pt (event-buffer event) nil ext 'at)) + (when (annotationp (setq ant + (extent-property ext 'smiley-annotation))) + (reveal-annotation ant) + (set-extent-property ext 'invisible t))))))) + +;;;###autoload +(defun smiley-buffer (&optional buffer st nd) + (interactive) + (when (featurep 'x) + (save-excursion + (when buffer + (set-buffer buffer)) + (let ((buffer-read-only nil) + (alist (if (symbolp smiley-regexp-alist) + (symbol-value smiley-regexp-alist) + smiley-regexp-alist)) + (case-fold-search nil) + entry regexp beg group file) + (goto-char (or st (point-min))) + (setq beg (point)) + ;; loop through alist + (while (setq entry (pop alist)) + (setq regexp (car entry) + group (cadr entry) + file (caddr entry)) + (goto-char beg) + (while (re-search-forward regexp nd t) + (let* ((start (match-beginning group)) + (end (match-end group)) + (glyph (smiley-create-glyph (buffer-substring start end) + file))) + (when glyph + (mapcar 'delete-annotation (annotations-at end)) + (let ((ext (make-extent start end)) + (ant (make-annotation glyph end 'text))) + ;; set text extent params + (set-extent-property ext 'end-open t) + (set-extent-property ext 'start-open t) + (set-extent-property ext 'invisible t) + (set-extent-property ext 'keymap smiley-map) + (set-extent-property ext 'mouse-face smiley-mouse-face) + (set-extent-property ext 'intangible t) + ;; set annotation params + (set-extent-property ant 'mouse-face smiley-mouse-face) + (set-extent-property ant 'keymap smiley-map) + ;; remember each other + (set-extent-property ant 'smiley-extent ext) + (set-extent-property ext 'smiley-annotation ant)) + (when (smiley-end-paren-p start end) + (make-annotation ")" end 'text)) + (goto-char end))))))))) + +(defun smiley-end-paren-p (start end) + "Try to guess whether the current smiley is an end-paren smiley." + (save-excursion + (goto-char start) + (when (and (re-search-backward "[()]" nil t) + (= (following-char) ?\() + (goto-char end) + (or (not (re-search-forward "[()]" nil t)) + (= (char-after (1- (point))) ?\())) + t))) + +(defvar gnus-article-buffer) +;;;###autoload +(defun gnus-smiley-display () + "Display \"smileys\" as small graphical icons." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + ;; We skip the headers. + (unless (search-forward "\n\n" nil t) + (goto-char (point-max))) + (smiley-buffer (current-buffer) (point)))) + +(provide 'smiley) + +;;; smiley.el ends here diff --git a/readme b/readme new file mode 100644 index 0000000..c8249c2 --- /dev/null +++ b/readme @@ -0,0 +1,52 @@ +This package contains a beta version of Gnus. The lisp directory +contains the source lisp files, and the texi directory contains a +draft of the Gnus info pages. + +To use Gnus you first have to unpack the files, which you've obviously +done, because you are reading this. + +You should definitely byte-compile the source files. To do that, you +can simply say "make" in this directory. If you are using XEmacs, you +*must* say "make EMACS=xemacs". In that case you may also want to +pull down the package of nice glyphs from +. It should be installed +into the "gnus-5.4.53/etc" directory. + +Then you have to tell Emacs where Gnus is. You might put something +like + + (setq load-path (cons (expand-file-name "~/gnus-5.4.53/lisp") load-path)) + +in your .emacs file, or wherever you keep such things. + +To enable reading the Gnus manual, you could say something like: + + (setq Info-default-directory-list + (cons "~/gnus-5.4.53/texi" Info-default-directory-list)) + +Note that Gnus and GNUS can't coexist in a single Emacs. They both use +the same function and variable names. If you have been running GNUS +in your Emacs, you should probably exit that Emacs and start a new one +to fire up Gnus. + +Gnus does absolutely not work with anything older than Emacs 19.33 or +XEmacs 19.14. So you definitely need a new Emacs. + +Then you do a `M-x gnus', and everything should... uhm... it should +work, but it might not. Set `debug-on-error' to t, and mail me the +backtraces, or, better yet, find out why Gnus does something wrong, +fix it, and send me the diffs. :-) + +There are four main things I want your help and input on: + +1) Startup. Does everything go smoothly, and why not? + +2) Any errors while you read news normally? + +3) Any errors if you do anything abnormal? + +4) Features you do not like, or do like, but would like to tweak a + bit, and features you would like to see. + +Send any comments and all your bug fixes/complaints to +`bugs@gnus.org'. diff --git a/texi/ChangeLog b/texi/ChangeLog new file mode 100644 index 0000000..f883167 --- /dev/null +++ b/texi/ChangeLog @@ -0,0 +1,654 @@ +Sat Sep 27 04:24:41 1997 Lars Magne Ingebrigtsen + + * message.texi (Various Commands): Addition. + +Wed Sep 24 02:38:21 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Example Setup): Wrong info. + (SOUP Groups): Addition. + (Contributors): Addition. + +1997-09-22 SL Baur + + * gnus.texi (Finding the Parent): Fix typo. + (NoCeM): Fix typos. + +Tue Sep 23 07:05:48 1997 Lars Magne Ingebrigtsen + + * gnus.texi (NoCeM): Addition. + (Finding the Parent): Addition. + +Mon Sep 22 06:13:00 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Filling In Threads): Addition. + (Finding the Parent): Addition. + +Sun Sep 21 04:35:56 1997 Lars Magne Ingebrigtsen + + * gnus.texi (NNTP): Addition. + (Hiding Headers): Addition. + (Symbolic Prefixes): New. + (Extended Interactive): New. + (Summary Score Commands): Addition. + +Sat Sep 20 20:53:43 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Startup Variables): Addition. + +1997-09-16 SL Baur + + * gnus.texi: Correct typo. + +Wed Sep 17 02:32:56 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Customizing Threading): Broken up into five nodes. + (Article Washing): Addition. + + * message.texi (Various Commands): Add. + +Tue Sep 16 04:04:03 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Example Setup): New. + +Mon Sep 15 23:10:05 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Customizing Threading): Addition. + +Sun Sep 14 21:59:07 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Outgoing Messages): New. + (Score File Format): Note. + (Subscription Methods): Fix. + (Starting Up): Fix. + (Threading): Add. + +Sat Jul 19 23:02:03 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Followups To Yourself): \\(_-_\\)? + +Sat Jul 12 16:29:35 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Picon Configuration): Moved Picons to under XEmacs. + (Smileys): New section. + +Fri Jul 11 11:58:20 1997 Lars Magne Ingebrigtsen + + * gnus.texi (NNTP): Addition. + +Tue Jun 17 23:52:17 1997 Justin Sheehy + + * gnus.texi (Group Parameters): Addition. + +Sun May 25 14:40:17 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Expiring Mail): Addition. + +Sat May 24 05:26:17 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Score File Format): Update. + +Tue May 20 21:56:03 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Document Server Internals): Typo. + +Sun May 18 05:59:24 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Topic Commands): Addition. + +Sun May 11 20:09:24 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Article Hiding): Change. + +Thu May 8 23:48:36 1997 James Troup + + * gnus.texi (Saving Articles): Typo. + +Wed May 7 19:00:48 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Saving Articles): Addition. + +Wed May 7 19:00:43 1997 Mark Boyns + + * gnus.texi (Saving Articles): Addition. + +Thu May 1 14:06:57 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Score File Format): Fix. + +Sun Apr 27 11:11:43 1997 Lars Magne Ingebrigtsen + + * gnus.texi (NNTP): Addition. + +Sat Apr 12 16:51:32 1997 Robert Bihlmeyer + + * gnus.texi (Thwarting Email Spam): Addition. + +Tue Apr 15 16:11:38 1997 Lars Magne Ingebrigtsen + + * message.texi (Various Message Variables): Addition. + + * gnus.texi (Thwarting Email Spam): Addition. + +Sat Apr 12 00:26:47 1997 Francois Felix Ingrand + + * gnus.texi (NoCeM): Addition. + +Thu Apr 10 21:25:14 1997 Hrvoje Niksic + + * gnus.texi (Emacs/XEmacs Code): Addition. + +Thu Apr 10 20:45:47 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Group Information): Fix. + +Wed Apr 2 11:48:44 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Sorting): Use total score. + +Tue Apr 1 11:44:57 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Subscription Methods): Addition. + (Group Info): Addition. + (Gnus Utility Functions): New. + (Thwarting Email Spam): Addition. + +Mon Mar 31 16:15:54 1997 Lars Magne Ingebrigtsen + + * message.texi (Various Message Variables): Addition. + +Sun Mar 23 02:16:19 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Thwarting Email Spam): New. + (Unavailable Servers): Fix. + +Wed Mar 19 15:45:17 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Various Summary Stuff): Addition. + (Mail Backend Variables): Addition. + +Tue Mar 18 14:43:32 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Article Washing): Not addition. + +Mon Mar 17 16:15:54 1997 Philippe Schnoebelen + + * Makefile (install): Install properly. + +Fri Mar 14 21:00:33 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Group Parameters): Addition. + (Expiring Mail): Addition. + +Wed Mar 12 06:57:14 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Various Various): Addition. + +Sat Mar 8 03:41:47 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Group Parameters): Added example. + (Duplicates): Fix. + +Fri Mar 7 10:49:43 1997 Lars Magne Ingebrigtsen + + * Makefile: New "install" target. + +Thu Mar 6 08:01:37 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Mail and Procmail): Fix. + +Sun Mar 2 02:08:40 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Startup Files): Addition. + (Score File Format): Fix. + +Fri Feb 28 23:23:31 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Archived Messages): Clarify. + (Fuzzy Matching): New. + +Mon Feb 24 23:41:57 1997 Lars Magne Ingebrigtsen + + * message.texi (Compatibility): New. + +Thu Feb 20 03:29:17 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Foreign Groups): Addition. + +Wed Feb 19 02:57:51 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Server Variables): New. + +Sun Feb 16 15:43:34 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Mail Backend Variables): Fix. + + * message.texi (Various Message Variables): Addition. + +Mon Feb 10 07:18:16 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Article Commands): Addition. + +Mon Feb 3 19:59:10 1997 Paul Franklin + + * gnus-group.el (gnus-group-edit-group): Allow editing of bad + groups. + +Wed Feb 5 02:00:46 1997 Lars Magne Ingebrigtsen + + * message.texi (Mail Variables): Change. + +Tue Feb 4 02:33:31 1997 Lars Magne Ingebrigtsen + + * message.texi (Mail Aliases): New. + + * gnus.texi (Splitting Mail): Addition. + +Mon Feb 3 07:31:47 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Mode Lines): Addition. + +Mon Jan 27 17:51:29 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Highlighting and Menus): Removed + `gnus-display-type'. + +Sat Jan 25 08:09:30 1997 Lars Magne Ingebrigtsen + + * gnus.texi (The Active File): Addition. + +Fri Jan 24 05:07:28 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Summary Mail Commands): Addition. + (Required Backend Functions): Deletia. + (Article Washing): Addition. + (Summary Mail Commands): Addition. + +Mon Jan 20 22:19:40 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Followups To Yourself): Fix. + +Fri Jan 17 00:55:51 1997 Lars Magne Ingebrigtsen + + * gnus.texi (NoCeM): Update. + +Wed Jan 15 02:23:03 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Mail Group Commands): Fix. + +Tue Jan 7 09:36:36 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Summary Buffer Lines): Correction. + +Mon Jan 6 22:49:12 1997 Lars Magne Ingebrigtsen + + * gnus.texi (NoCeM): Addition. + +Fri Jan 3 18:13:02 1997 Lars Magne Ingebrigtsen + + * message.texi (Various Commands): Addition. + +Thu Jan 2 16:12:27 1997 Lars Magne Ingebrigtsen + + * gnus.texi (Optional Backend Functions): Fix. + +Mon Dec 16 13:53:28 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Exiting the Summary Buffer): Update. + +Fri Dec 13 01:04:41 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Limiting): Addition. + +Sat Dec 7 21:10:23 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Example Methods): Addition. + +Fri Dec 6 12:38:14 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Group Parameters): Update. + +1996-11-30 Lars Magne Ingebrigtsen + + * gnus.texi (Terminology): Addition. + +Wed Nov 27 03:13:05 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Selecting a Group): Addition. + +Tue Nov 26 12:42:47 1996 Martin Buchholz + + * message.texi: Typo fixes and stuff. + +Thu Nov 21 17:45:57 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Canceling and Superseding): Fix. + +Wed Nov 20 15:42:36 1996 Lars Magne Ingebrigtsen + + * gnus.texi (New Groups): Addition. + (Summary Sorting): Addition. + +Tue Nov 19 20:54:16 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Scanning New Messages): Addition. + +Sat Nov 9 06:04:22 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Group Parameters): Addition. + +Fri Nov 8 04:01:06 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Article Fontisizing): New. + (Fancy Mail Splitting): Addition. + (Summary Post Commands): Addition. + (Mail Spool): Addition. + (Server Commands): Addition. + (Fancy Mail Splitting): Addition. + +Wed Nov 6 06:39:44 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Misc Article): Addition. + (Emacsen): Updated. + +Wed Nov 6 03:52:05 1996 C. R. Oldham + + * Makefile (.texi.dvi): Fix rule. + +Tue Nov 5 10:45:39 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Other Decode Variables): Addition. + (Mail-like Backends): New. + +Tue Nov 5 06:41:46 1996 Hrvoje Niksic + + * gnus.texi (Score File Format): Added warning. + +Mon Oct 28 15:50:08 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Startup Variables): Addition. + +Fri Oct 25 09:04:59 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Summary Mail Commands): Addition. + +Wed Oct 23 08:28:29 1996 Hrvoje Niksic + + * gnus.texi (Fancy Mail Splitting): Removed trailing garbage. + +Tue Oct 22 07:36:02 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Converting Kill Files): New. + +Sat Oct 19 07:17:28 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Saving Articles): Addition. + + * message.texi (Various Message Variables): Addition. + +Thu Oct 17 06:53:04 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Contributors): Added names. + +Fri Oct 11 12:38:59 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Adaptive Scoring): Addition. + +Tue Oct 8 13:16:41 1996 Lars Magne Ingebrigtsen + + * Makefile (all): Make custom. + +Wed Oct 2 01:32:49 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Group Timestamps): New. + +Tue Oct 1 01:34:45 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Expiring Mail): Addition. + (Group Line Specification): Addition. + +Sat Sep 28 21:36:40 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Foreign Groups): Addition. + +Mon Sep 23 22:17:44 1996 Lars Magne Ingebrigtsen + + * gnus.texi (The Summary Buffer): Addition. + +Mon Sep 23 18:25:38 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Thread Commands): Correction. + (Group Information): Correction. + +Sat Sep 21 08:11:43 1996 Lars Magne Ingebrigtsen + + * gnus.texi (New Groups): Split into three nodes. + (Group Parameters): Shortened. + (Browse Foreign Server): Corrected. + +Thu Sep 19 18:45:15 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Mail and Procmail): Addition. + +Wed Sep 18 07:33:11 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Other Marks): Edited. + (The Manual): New. + (Contributors): Updated. + (Asynchronous Fetching): Addition. + (New Features): Split. + ((ding) Gnus): Renamed. + (September Gnus): New. + (Red Gnus): New, + (Undo): New. + +Thu Sep 12 23:55:53 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Archived Messages): Fix. + +Sat Sep 7 12:14:23 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Various Various): Addition. + +Fri Sep 6 07:57:26 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Startup Files): Addition. + (Splitting Mail): Addition. + (Sorting Groups): Addition. + (Topic Sorting): New. + (Really Various Summary Commands): Deletia. + (Summary Generation Commands): New. + (Setting Process Marks): Addition. + +Thu Sep 5 07:34:27 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Terminology): Addition. + (Web Searches): Fix. + (Windows Configuration): Addition. + +Sun Sep 1 11:07:09 1996 Lars Magne Ingebrigtsen + + * gnus.texi (XEmacs Enhancements): New. + +Sat Aug 31 02:55:50 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Washing Mail): Addition. + +Fri Aug 30 09:10:17 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Washing Mail): New. + (Fancy Mail Splitting): Change. + +Fri Aug 30 00:21:59 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Foreign Groups): Change. + +Thu Aug 29 23:51:45 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Daemons): Addition. + +Thu Aug 29 02:09:24 1996 François Pinard + + * gnus.texi (Web Searches): Typo. + +Wed Aug 28 08:21:36 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Server Commands): Addition. + (Really Various Summary Commands): Addition. + +Mon Aug 26 18:29:23 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Optional Backend Functions): Deletia. + (Asynchronous Fetching): Deletia and addition. + +Sun Aug 25 23:39:03 1996 Lars Magne Ingebrigtsen + + * gnus.texi: Include the version number. + +Sun Aug 25 21:31:33 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Really Various Summary Commands): Addition. + +Sat Aug 17 22:24:34 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Startup Files): Addition. + (Anything Groups): Addition. + +Thu Aug 22 17:27:31 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Adaptive Scoring): Addition. + (Adaptive Scoring): Addition. + +Mon Aug 19 00:30:07 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Fancy Mail Splitting): Addition. + (Splitting Mail): Addition. + (Group Parameters): Addition. + (Topic Variables): Addition. + (Mail Group Commands): Addition. + (Group Information): Addition. + (Article Washing): Addition. + +Sun Aug 18 18:06:49 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Web Searches): Change and addition. + +Sat Aug 17 22:24:34 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Startup Files): Addition. + (Anything Groups): Addition. + +Thu Aug 15 17:59:12 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Followups To Yourself): Addition. + (Setting Process Marks): Addition. + (Process/Prefix): Addition. + (Startup Files): Addition. + (Mail-To-News Gateways): New. + +Wed Aug 14 15:02:14 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Home Score File): Fix. + (Various Various): New. + +Tue Aug 13 10:38:47 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Error Messaging): New. + (Mail Backend Variables): Fix. + (Foreign Groups): Added references. + (Sorting Groups): Addition. + +Sun Aug 11 02:52:37 1996 Lars Magne Ingebrigtsen + + * gnus.texi (User-Defined Specs): Correction. + (Unavailable Servers): Addition. + (Moderation): New. + (Summary Mail Commands): Addition. + (Crosspost Handling): Addition. + +Sat Aug 10 00:13:39 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Summary Buffer Lines): Correction. + (Top): Name fix. + (Compilation ): Addition. + (Group Parameters): Addition. + (Troubleshooting): Addition. + +Fri Aug 9 07:17:59 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Selecting a Group): Addition. + (Score Decays): New. + (Score File Format): Addition. + (Changing Servers): Addition. + (Selecting a Group): Addition. + (Really Various Summary Commands): Addition. + +Thu Aug 8 05:39:31 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Read Articles): Addition. + (Foreign Groups): Addition. + (User-Defined Specs): Separated. + (Formatting Fonts): Ditto. + (Advanced Formatting): New. + (Formatting Basics): Addition. + (Formatting Variables): Split. + +Wed Aug 7 22:00:56 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Hooking New Backends Into Gnus): New node. + +Wed Aug 7 01:02:08 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Setting Marks): Addition. + (Formatting Variables): Addition. + +Mon Aug 5 20:20:42 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Formatting Variables): Addition. + +Sun Aug 4 07:15:28 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Score File Format): Addition. + (Adaptive Scoring): Addition. + +Sat Aug 3 17:35:36 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Group Parameters): Addition. + (Home Score File): New. + (Topic Parameters): New. + +Wed Jul 31 15:34:12 1996 Lars Magne Ingebrigtsen + + * gnus.texi (are): Fix. + +Wed Jul 31 15:32:57 1996 David S. Goldberg + + * gnus.texi (buffer-name): Addition. + +Fri Aug 2 00:32:39 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Pick and Read): Addition. + (Article Hiding): Addition. + (Article Signature): Made into own node. + +Thu Aug 1 00:25:41 1996 Lars Magne Ingebrigtsen + + * message.texi (Wide Reply): Addition. + (Bouncing): Addition. + + * gnus.texi (Crosspost Handling): Made into own node. + (Duplicate Suppression): New. + (Document Server Internals): New. + (Changing Servers): New. + +Wed Jul 31 15:37:44 1996 Lars Magne Ingebrigtsen + + * gnus.texi: Fix + +Mon Jul 29 10:12:24 1996 Lars Magne Ingebrigtsen + + * gnus.texi (Misc Article): Addition. + (Advanced Scoring Tips): New. + (Advanced Scoring Example): New. + (Advanced Scoring Syntax): New. + (Advanced Scoring): New. + diff --git a/texi/Makefile b/texi/Makefile new file mode 100644 index 0000000..95b19ee --- /dev/null +++ b/texi/Makefile @@ -0,0 +1,138 @@ +TEXI2DVI=texi2dvi +EMACS=emacs +MAKEINFO=$(EMACS) -batch -q -no-site-file +INFOSWI=-l texinfmt -f texinfo-every-node-update -f texinfo-format-buffer -f save-buffer +XINFOSWI=-l texinfmt -f texinfo-every-node-update -f texinfo-format-buffer -f save-buffer +LATEX=latex +DVIPS=dvips +PERL=perl +INFODIR=/usr/local/info + +all: gnus message + +most: texi2latex.elc latex latexps + +gnus: gnus.texi + $(MAKEINFO) -eval '(find-file "gnus.texi")' $(XINFOSWI) + +message: message.texi + $(MAKEINFO) -eval '(find-file "message.texi")' $(XINFOSWI) + +dvi: gnus.dvi message.dvi + +.texi.dvi : + $(PERL) -n -e 'print unless (/\@iflatex/ .. /\@end iflatex/)' $< > gnustmp.texi + $(TEXI2DVI) gnustmp.texi + cp gnustmp.dvi $*.dvi + rm gnustmp.* + +refcard.dvi: refcard.tex gnuslogo.refcard gnusref.tex + $(LATEX) refcard.tex + +sclean: + rm -f gnus.*.bak *.ky *.cp *.fn *.cps *.kys *.log *.aux *.dvi *.vr \ + *.tp *.toc \ + *.pg gnus.latexi *.aux *.[cgk]idx \ + gnus.ilg gnus.ind gnus.[cgk]ind gnus.idx \ + gnus.tmptexi gnus.tmplatexi gnus.tmplatexi1 texput.log *.orig *.rej \ + gnus.latexi*~* + +clean: + make sclean + rm -f *.latexi + rm tmp/*.ps + +makeinfo: + makeinfo -o gnus gnus.texi + makeinfo -o message message.texi + +texi2latex.elc: texi2latex.el + $(EMACS) -batch -l bytecomp -f batch-byte-recompile-directory + +latex: gnus.texi + $(EMACS) -batch -q -no-site-file gnus.texi -l ./texi2latex.elc -f latexi-translate + +latexps: + make texi2latex.elc + egrep -v "label.*Index|chapter.*Index" gnus.latexi > gnus.tmplatexi1 + $(LATEX) gnus.tmplatexi1 + splitindex + makeindex -o gnus.kind gnus.kidx + makeindex -o gnus.cind gnus.cidx + makeindex -o gnus.gind gnus.gidx + sed 's/\\char 5E\\relax {}/\\symbol{"5E}/' < gnus.kind > gnus.tmpkind + mv gnus.tmpkind gnus.kind + egrep -v "end{document}" gnus.tmplatexi1 > gnus.tmplatexi + cat postamble.tex >> gnus.tmplatexi + $(LATEX) gnus.tmplatexi + $(LATEX) gnus.tmplatexi + $(DVIPS) -f gnus.dvi > /local/tmp/larsi/gnus.ps + +pss: + make latex + make latexps + +psout: + make latex + make latexboth + make out + +latexboth: + rm -f gnus-manual-a4.ps.gz gnus-manual-standard.ps.gz + make latexps + mv /local/tmp/larsi/gnus.ps /local/tmp/larsi/gnus-manual-a4.ps + gzip /local/tmp/larsi/gnus-manual-a4.ps + sed 's/,a4paper//' gnus.latexi > gnus-standard.latexi + mv gnus-standard.latexi gnus.latexi + make latexps + mv /local/tmp/larsi/gnus.ps /local/tmp/larsi/gnus-manual-standard.ps + gzip /local/tmp/larsi/gnus-manual-standard.ps + +out: + cp /local/tmp/larsi/gnus-manual-standard.ps.gz \ + /local/tmp/larsi/gnus-manual-a4.ps.gz \ + /local/ftp/pub/emacs/gnus/manual + mv /local/tmp/larsi/gnus-manual-standard.ps.gz \ + /local/tmp/larsi/gnus-manual-a4.ps.gz \ + /hom/larsi/www_docs/www.gnus.org/documents + +veryclean: + make clean + rm -f gnus.dvi gnus.ps + +distclean: + make clean + rm -f *.orig *.rej *.elc *~ gnus gnus-[0-9] gnus-[0-9][0-9] + rm -f message message-[0-9] + +install: + cp gnus gnus-[0-9] gnus-[0-9][0-9] $(INFODIR) + cp message $(INFODIR) + +tmps: + if [ ! -d /local/tmp/larsi ]; then mkdir /local/tmp/larsi; fi + make screens + make herds + make etc + make piconss + make xfaces + +herds: + cd ps ; for i in new-herd-[0-9]*.gif; do echo $$i; giftoppm $$i | pnmcrop -white | pnmmargin -white 9 | pnmscale 2 | pnmsmooth -size 5 5 | ppmtopgm | pgmtops > ../tmp/`basename $$i .gif`.ps; done + cd ps ; giftoppm new-herd-section.gif | pnmscale 4 | pnmsmooth -size 11 11 | ppmtopgm | pgmtops > ../tmp/new-herd-section.ps + +screens: + cd screen ; for i in *.gif; do echo $$i; giftoppm $$i | pnmmargin -black 1 | ppmtopgm | pgmtops > ../tmp/`basename $$i .gif`.ps; done + giftoppm ps/larsi.gif | ppmtopgm | pgmtops > tmp/larsi.ps + +etc: + cd ../etc/gnus; for i in gnus-*.xpm; do echo $$i; xpmtoppm $$i | ppmtopgm | pgmtops > ../../texi/tmp/`basename $$i .xpm`.ps; done + +piconss: + cd picons; for i in *.xbm; do echo $$i; xbmtopbm $$i | pgmtops > ../tmp/picons-`basename $$i .xbm`.ps; done + cd picons; for i in *.gif; do echo $$i; giftoppm $$i | ppmtopgm | pgmtops > ../tmp/picons-`basename $$i .gif`.ps; done + for i in tmp/picons-*.ps; do echo "\\gnuspicon{$$i}"; done > picons.tmplatexi + +xfaces: + cd xface; for i in *.gif; do echo $$i; giftoppm $$i | ppmtopgm | pgmtops > ../tmp/xface-`basename $$i .gif`.ps; done + for i in tmp/xface-*.ps; do echo "\\gnusxface{$$i}"; done > xface.tmplatexi diff --git a/texi/custom.texi b/texi/custom.texi new file mode 100644 index 0000000..5b6fe4a --- /dev/null +++ b/texi/custom.texi @@ -0,0 +1,695 @@ +\input texinfo.tex + +@c %**start of header +@setfilename custom +@settitle The Customization Library +@iftex +@afourpaper +@headings double +@end iftex +@c %**end of header + +@node Top, Introduction, (dir), (dir) +@comment node-name, next, previous, up +@top The Customization Library + +Version: 1.82 + +@menu +* Introduction:: +* User Commands:: +* The Customization Buffer:: +* Declarations:: +* Utilities:: +* The Init File:: +* Wishlist:: +@end menu + +@node Introduction, User Commands, Top, Top +@comment node-name, next, previous, up +@section Introduction + +This library allows customization of @dfn{user options}. Currently two +types of user options are supported, namely @dfn{variables} and +@dfn{faces}. Each user option can have four different values +simultaneously: +@table @dfn +@item factory setting +The value specified by the programmer. +@item saved value +The value saved by the user as the default for this variable. This +overwrites the factory setting when starting a new emacs. +@item current value +The value used by Emacs. This will not be remembered next time you +run Emacs. +@item widget value +The value entered by the user in a customization buffer, but not yet +applied. +@end table + +Variables also have a @dfn{type}, which specifies what kind of values +the variable can hold, and how the value is presented in a customization +buffer. By default a variable can hold any valid expression, but the +programmer can specify a more limited type when declaring the variable. + +The user options are organized in a number of @dfn{groups}. Each group +can contain a number user options, as well as other groups. The groups +allows the user to concentrate on a specific part of emacs. + +@node User Commands, The Customization Buffer, Introduction, Top +@comment node-name, next, previous, up +@section User Commands + +The following commands will create a customization buffer: + +@table @code +@item customize +Create a customization buffer containing a specific group, by default +the @code{emacs} group. + +@item customize-variable +Create a customization buffer containing a single variable. + +@item customize-face +Create a customization buffer containing a single face. + +@item customize-apropos +Create a customization buffer containing all variables, faces, and +groups that match a user specified regular expression. +@end table + +@node The Customization Buffer, Declarations, User Commands, Top +@comment node-name, next, previous, up +@section The Customization Buffer. + +The customization buffer allows the user to make temporary or permanent +changes to how specific aspects of emacs works, by setting and editing +user options. + +The customization buffer contains three types of text: + +@table @dfn +@item informative text +where the normal editing commands are disabled. + +@item editable fields +where you can edit with the usual emacs commands. Editable fields are +usually displayed with a grey background if your terminal supports +colors, or an italic font otherwise. + +@item buttons +which can be activated by either pressing the @kbd{@key{ret}} while +point is located on the text, or pushing @kbd{mouse-2} while the mouse +pointer is above the tex. Buttons are usually displayed in a bold +font. +@end table + +You can move to the next the next editable field or button by pressing +@kbd{@key{tab}} or the previous with @kbd{M-@key{tab}}. Some buttons +have a small helpful message about their purpose, which will be +displayed when you move to it with the @key{tab} key. + +The buffer is divided into three part, an introductory text, a list of +customization options, and a line of customization buttons. Each part +will be described in the following. + +@menu +* The Introductory Text:: +* The Customization Options:: +* The Variable Options:: +* The Face Options:: +* The Group Options:: +* The State Button:: +* The Customization Buttons:: +@end menu + +@node The Introductory Text, The Customization Options, The Customization Buffer, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Introductory Text + +The start of the buffer contains a short explanation of what it is, and +how to get help. It will typically look like this: + +@example +This is a customization buffer. +Push RET or click mouse-2 on the word _help_ for more information. +@end example + +Rather boring. It is mostly just informative text, but the word +@samp{help} is a button that will bring up this document when +activated. + +@node The Customization Options, The Variable Options, The Introductory Text, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Customization Options + +Each customization option looks similar to the following text: + +@example + *** custom-background-mode: default + State: this item is unchanged from its factory setting. + [ ] [?] The brightness of the background. +@end example + +The option contains the parts described below. + +@table @samp +@item *** +The Level Button. The customization options in the buffer are organized +in a hierarchy, which is indicated by the number of stars in the level +button. The top level options will be shown as @samp{*}. When they are +expanded, the suboptions will be shown as @samp{**}. The example option +is thus a subsuboption. + +Activating the level buttons will toggle between hiding and exposing the +content of that option. The content can either be the value of the +option, as in this example, or a list of suboptions. + +@item custom-background-mode +This is the tag of the the option. The tag is a name of a variable, a +face, or customization group. Activating the tag has an effect that +depends on the exact type of the option. In this particular case, +activating the tag will bring up a menu that will allow you to choose +from the three possible values of the `custom-background-mode' +variable. + +@item default +After the tag, the options value is shown. Depending on its type, you +may be able to edit the value directly. If an option should contain a +file name, it is displayed in an editable field, i.e. you can edit it +using the standard emacs editing commands. + +@item State: this item is unchanged from its factory setting. +The state line. This line will explain the state of the option, +e.g. whether it is currently hidden, or whether it has been modified or +not. Activating the button will allow you to change the state, e.g. set +or reset the changes you have made. This is explained in detail in the +following sections. + +@item [ ] +The magic button. This is an abbreviated version of the state line. + +@item [?] +The documentation button. If the documentation is more than one line, +this button will be present. Activating the button will toggle whether +the complete documentation is shown, or only the first line. + +@item The brightness of the background. +This is a documentation string explaining the purpose of this particular +customization option. + +@end table + +@node The Variable Options, The Face Options, The Customization Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Variable Options + +The most common customization options are emacs lisp variables. The +actual editing of these variables depend on what type values the +variable is expected to contain. For example, a lisp variable whose +value should be a string will typically be represented with an editable +text field in the buffer, where you can change the string directly. If +the value is a list, each item in the list will be presented in the +buffer buffer on a separate line, with buttons to insert new items in +the list, or delete existing items from the list. You may want to see +@ref{User Interface,,, widget, The Widget Library}, where some examples +of editing are discussed. + +You can either choose to edit the value directly, or edit the lisp +value for that variable. The lisp value is a lisp expression that +will be evaluated when you start emacs. The result of the evaluation +will be used as the initial value for that variable. Editing the +lisp value is for experts only, but if the current value of the +variable is of a wrong type (i.e. a symbol where a string is expected), +the `edit lisp' mode will always be selected. + +You can see what mode is currently selected by looking at the state +button. If it uses parenthesises (like @samp{( )}) it is in edit lisp +mode, with square brackets (like @samp{[ ]}) it is normal edit mode. +You can switch mode by activating the state button, and select either +@samp{Edit} or @samp{Edit lisp} from the menu. + +You can change the state of the variable with the other menu items: + +@table @samp +@item Set +When you have made your modifications in the buffer, you need to +activate this item to make the modifications take effect. The +modifications will be forgotten next time you run emacs. + +@item Save +Unless you activate this item instead! This will mark the modification +as permanent, i.e. the changes will be remembered in the next emacs +session. + +@item Reset +If you have made some modifications and not yet applied them, you can +undo the modification by activating this item. + +@item Reset to Saved +Activating this item will reset the value of the variable to the last +value you marked as permanent with `Save'. + +@item Reset to Factory Settings +Activating this item will undo all modifications you have made, and +reset the value to the initial value specified by the program itself. +@end table + +By default, the value of large or complicated variables are hidden. You +can show the value by clicking on the level button. + +@node The Face Options, The Group Options, The Variable Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Face Options + +A face is an object that controls the appearance of some buffer text. +The face has a number of possible attributes, such as boldness, +foreground color, and more. For each attribute you can specify whether +this attribute is controlled by the face, and if so, what the value is. +For example, if the attribute bold is not controlled by a face, using +that face on some buffer text will not affect its boldness. If the bold +attribute is controlled by the face, it can be turned either on or of. + +It is possible to specify that a face should have different attributes +on different device types. For example, a face may make text red on a +color device, and bold on a monochrome device. You do this by +activating `Edit All' in the state menu. + +The way this is presented in the customization buffer is to have a list +of display specifications, and for each display specification a list of +face attributes. For each face attribute, there is a checkbox +specifying whether this attribute has effect and what the value is. +Here is an example: + +@example + *** custom-invalid-face: (sample) + State: this item is unchanged from its factory setting. + [ ] Face used when the customize item is invalid. + [INS] [DEL] Display: [ ] Type: [ ] X [ ] PM [ ] Win32 [ ] DOS [ ] TTY + [X] Class: [X] Color [ ] Grayscale [ ] Monochrome + [ ] Background: [ ] Light [ ] Dark + Attributes: [ ] Bold: off + [ ] Italic: off + [ ] Underline: off + [X] Foreground: yellow (sample) + [X] Background: red (sample) + [ ] Stipple: + [INS] [DEL] Display: all + Attributes: [X] Bold: on + [X] Italic: on + [X] Underline: on + [ ] Foreground: default (sample) + [ ] Background: default (sample) + [ ] Stipple: + [INS] +@end example + +This has two display specifications. The first will match all color +displays, independently on what window system the device belongs to, and +whether background color is dark or light. For devices matching this +specification, @samp{custom-invalid-face} will force text to be +displayed in yellow on red, but leave all other attributes alone. + +The second display will simply match everything. Since the list is +prioritised, this means that it will match all non-color displays. For +these, the face will not affect the foreground or background color, but +force the font to be both bold, italic, and underline. + +You can add or delete display specifications by activating the +@samp{[INS]} and @samp{[DEL]} buttons, and modify them by clicking on +the check boxes. The first checkbox in each line in the display +specification is special. It specify whether this particular property +will even be relevant. By not checking the box in the first display, we +match all device types, also device types other than those listed. + +After modifying the face, you can activate the state button to make the +changes take effect. The menu items in the state button menu is similar +to the state menu items for variables described in the previous section. + +@node The Group Options, The State Button, The Face Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Group Options + +Since Emacs has approximately a zillion configuration options, they have +been organized in groups. Each group can contain other groups, thus +creating a customization hierarchy. The nesting of the customization +within the visible part of this hierarchy is indicated by the number of +stars in the level button. + +Since there is really no customization needed for the group itself, the +menu items in the groups state button will affect all modified group +members recursively. Thus, if you activate the @samp{Set} menu item, +all variables and faces that have been modified and belong to that group +will be applied. For those members that themselves are groups, it will +work as if you had activated the @samp{Set} menu item on them as well. + +@node The State Button, The Customization Buttons, The Group Options, The Customization Buffer +@comment node-name, next, previous, up +@subsection The State Line and The Magic Button + +The state line has two purposes. The first is to hold the state menu, +as described in the previous sections. The second is to indicate the +state of each customization item. + +For the magic button, this is done by the character inside the brackets. +The following states have been defined, the first that applies to the +current item will be used: + +@table @samp +@item - +The option is currently hidden. For group options that means the +members are not shown, for variables and faces that the value is not +shown. You cannot perform any of the state change operations on a +hidden customization option. + +@item * +The value if this option has been modified in the buffer, but not yet +applied. + +@item + +The item has has been set by the user. + +@item : +The current value of this option is different from the saved value. + +@item ! +The saved value of this option is different from the factory setting. + +@item @@ +The factory setting of this option is not known. This occurs when you +try to customize variables or faces that have not been explicitly +declared as customizable. + +@item SPC +The factory setting is still in effect. + +@end table + +For non-hidden group options, the state shown is the most severe state +of its members, where more severe means that it appears earlier in the +list above (except hidden members, which are ignored). + +@node The Customization Buttons, , The State Button, The Customization Buffer +@comment node-name, next, previous, up +@subsection The Customization Buttons + +The last part of the customization buffer looks like this: + +@example +[Set] [Save] [Reset] [Done] +@end example + +Activating the @samp{[Set]}, @samp{[Save]}, or @samp{[Reset]} +button will affect all modified customization items that are visible in +the buffer. @samp{[Done]} will bury the buffer. + +@node Declarations, Utilities, The Customization Buffer, Top +@comment node-name, next, previous, up +@section Declarations + +This section describes how to declare customization groups, variables, +and faces. It doesn't contain any examples, but please look at the file +@file{cus-edit.el} which contains many declarations you can learn from. + +@menu +* Declaring Groups:: +* Declaring Variables:: +* Declaring Faces:: +* Usage for Package Authors:: +@end menu + +All the customization declarations can be changes by keyword arguments. +Groups, variables, and faces all share these common keywords: + +@table @code +@item :group +@var{value} should be a customization group. +Add @var{symbol} to that group. +@item :link +@var{value} should be a widget type. +Add @var{value} to the extrenal links for this customization option. +Useful widget types include @code{custom-manual}, @code{info-link}, and +@code{url-link}. +@item :load +Add @var{value} to the files that should be loaded nefore displaying +this customization option. The value should be iether a string, which +should be a string which will be loaded with @code{load-library} unless +present in @code{load-history}, or a symbol which will be loaded with +@code{require}. +@item :tag +@var{Value} should be a short string used for identifying the option in +customization menus and buffers. By default the tag will be +automatically created from the options name. +@end table + +@node Declaring Groups, Declaring Variables, Declarations, Declarations +@comment node-name, next, previous, up +@subsection Declaring Groups + +Use @code{defgroup} to declare new customization groups. + +@defun defgroup symbol members doc [keyword value]... +Declare @var{symbol} as a customization group containing @var{members}. +@var{symbol} does not need to be quoted. + +@var{doc} is the group documentation. + +@var{members} should be an alist of the form ((@var{name} +@var{widget})...) where @var{name} is a symbol and @var{widget} is a +widget for editing that symbol. Useful widgets are +@code{custom-variable} for editing variables, @code{custom-face} for +editing faces, and @code{custom-group} for editing groups.@refill + +Internally, custom uses the symbol property @code{custom-group} to keep +track of the group members, and @code{group-documentation} for the +documentation string. + +The following additional @var{keyword}'s are defined: + +@table @code +@item :prefix +@var{value} should be a string. If the string is a prefix for the name +of a member of the group, that prefix will be ignored when creating a +tag for that member. +@end table +@end defun + +@node Declaring Variables, Declaring Faces, Declaring Groups, Declarations +@comment node-name, next, previous, up +@subsection Declaring Variables + +Use @code{defcustom} to declare user editable variables. + +@defun defcustom symbol value doc [keyword value]... +Declare @var{symbol} as a customizable variable that defaults to @var{value}. +Neither @var{symbol} nor @var{value} needs to be quoted. +If @var{symbol} is not already bound, initialize it to @var{value}. + +@var{doc} is the variable documentation. + +The following additional @var{keyword}'s are defined: + +@table @code +@item :type +@var{value} should be a widget type. +@item :options +@var{value} should be a list of possible members of the specified type. +For hooks, this is a list of function names. +@end table + +@xref{Sexp Types,,,widget,The Widget Library}, for information about +widgets to use together with the @code{:type} keyword. +@end defun + +Internally, custom uses the symbol property @code{custom-type} to keep +track of the variables type, @code{factory-value} for the program +specified default value, @code{saved-value} for a value saved by the +user, and @code{variable-documentation} for the documentation string. + +Use @code{custom-add-option} to specify that a specific function is +useful as an meber of a hook. + +@defun custom-add-option symbol option +To the variable @var{symbol} add @var{option}. + +If @var{symbol} is a hook variable, @var{option} should be a hook +member. For other types variables, the effect is undefined." +@end defun + +@node Declaring Faces, Usage for Package Authors, Declaring Variables, Declarations +@comment node-name, next, previous, up +@subsection Declaring Faces + +Faces are declared with @code{defface}. + +@defun defface face spec doc [keyword value]... + +Declare @var{face} as a customizable face that defaults to @var{spec}. +@var{face} does not need to be quoted. + +If @var{face} has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to @var{spec}. + +@var{doc} is the face documentation. + +@var{spec} should be an alist of the form @samp{((@var{display} @var{atts})...)}. + +@var{atts} is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, @var{atts} can be a face in which case the attributes of +that face is used. + +The @var{atts} of the first entry in @var{spec} where the @var{display} +matches the frame should take effect in that frame. @var{display} can +either be the symbol `t', which will match all frames, or an alist of +the form @samp{((@var{req} @var{item}...)...)}@refill + +For the @var{display} to match a FRAME, the @var{req} property of the +frame must match one of the @var{item}. The following @var{req} are +defined:@refill + +@table @code +@item type +(the value of (window-system))@* +Should be one of @code{x} or @code{tty}. + +@item class +(the frame's color support)@* +Should be one of @code{color}, @code{grayscale}, or @code{mono}. + +@item background +(what color is used for the background text)@* +Should be one of @code{light} or @code{dark}. +@end table + +Internally, custom uses the symbol property @code{factory-face} for the +program specified default face properties, @code{saved-face} for +properties saved by the user, and @code{face-doc-string} for the +documentation string.@refill + +@end defun + +@node Usage for Package Authors, , Declaring Faces, Declarations +@comment node-name, next, previous, up +@subsection Usage for Package Authors + +The recommended usage for the author of a typical emacs lisp package is +to create one group identifying the package, and make all user options +and faces members of that group. If the package has more than around 20 +such options, they should be divided into a number of subgroups, with +each subgroup being member of the top level group. + +The top level group for the package should itself be member of one or +more of the standard customization groups. There exists a group for +each @emph{finder} keyword. Press @kbd{C-c p} to see a list of finder +keywords, and add you group to each of them, using the @code{:group} +keyword. + +@node Utilities, The Init File, Declarations, Top +@comment node-name, next, previous, up +@section Utilities + +These utilities can come in handy when adding customization support. + +@deffn Widget custom-manual +Widget type for specifying the info manual entry for a customization +option. It takes one argument, an info address. +@end deffn + +@defun custom-add-to-group group member widget +To existing @var{group} add a new @var{member} of type @var{widget}, +If there already is an entry for that member, overwrite it. +@end defun + +@defun custom-add-link symbol widget +To the custom option @var{symbol} add the link @var{widget}. +@end defun + +@defun custom-add-load symbol load +To the custom option @var{symbol} add the dependency @var{load}. +@var{load} should be either a library file name, or a feature name. +@end defun + +@defun custom-menu-create symbol &optional name +Create menu for customization group @var{symbol}. +If optional @var{name} is given, use that as the name of the menu. +Otherwise make up a name from @var{symbol}. +The menu is in a format applicable to @code{easy-menu-define}. +@end defun + +@node The Init File, Wishlist, Utilities, Top +@comment node-name, next, previous, up +@section The Init File + +When you save the customizations, call to @code{custom-set-variables}, +@code{custom-set-faces} are inserted into the file specified by +@code{custom-file}. By default @code{custom-file} is your @file{.emacs} +file. If you use another file, you must explicitly load it yourself. +The two functions will initialize variables and faces as you have +specified. + +@node Wishlist, , The Init File, Top +@comment node-name, next, previous, up +@section Wishlist + +@itemize @bullet +@item +The menu items should be grayed out when the information is +missing. I.e. if a variable doesn't have a factory setting, the user +should not be allowed to select the @samp{Factory} menu item. + +@item +Better support for keyboard operations in the customize buffer. + +@item +Integrate with @file{w3} so you can customization buffers with much +better formatting. I'm thinking about adding a name +tag. The latest w3 have some support for this, so come up with a +convincing example. + +@item +Add an `examples' section, with explained examples of custom type +definitions. + +@item +Support selectable color themes. I.e., change many faces by setting one +variable. + +@item +Support undo using lmi's @file{gnus-undo.el}. + +@item +Make it possible to append to `choice', `radio', and `set' options. + +@item +Make it possible to customize code, for example to enable or disable a +global minor mode. + +@item +Ask whether set or modified variables should be saved in +@code{kill-buffer-hook}. + +Ditto for @code{kill-emacs-query-functions}. + +@item +Command to check if there are any customization options that +does not belong to an existing group. + +@item +Optionally disable the point-cursor and instead highlight the selected +item in XEmacs. This is like the *Completions* buffer in XEmacs. +Suggested by Jens Lautenbacher +@samp{}.@refill + +@item +Empty customization groups should start open (harder than it looks). + +@item +Make it possible to include a comment/remark/annotation when saving an +option. + +@end itemize + +@contents +@bye diff --git a/texi/gnus-faq.texi b/texi/gnus-faq.texi new file mode 100644 index 0000000..a6fb13a --- /dev/null +++ b/texi/gnus-faq.texi @@ -0,0 +1,659 @@ +\input texinfo +@c -*-texinfo-*- +@c Copyright (C) 1995 Free Software Foundation, Inc. +@setfilename gnus-faq.info + +@node Frequently Asked Questions +@section Frequently Asked Questions + +This is the Gnus Frequently Asked Questions list. +If you have a Web browser, the official hypertext version is at +@file{http://www.ccs.neu.edu/software/gnus/}, and has +probably been updated since you got this manual. + +@menu +* Installation FAQ:: Installation of Gnus. +* Customization FAQ:: Customizing Gnus. +* Reading News FAQ:: News Reading Questions. +* Reading Mail FAQ:: Mail Reading Questions. +@end menu + + +@node Installation FAQ +@subsection Installation + +@itemize @bullet +@item +Q1.1 What is the latest version of Gnus? + +The latest (and greatest) version is 5.0.10. You might also run +across something called @emph{September Gnus}. September Gnus +is the alpha version of the next major release of Gnus. It is currently +not stable enough to run unless you are prepared to debug lisp. + +@item +Q1.2 Where do I get Gnus? + +Any of the following locations: + +@itemize @minus +@item +@file{ftp://ftp.ifi.uio.no/pub/emacs/gnus/gnus.tar.gz} + +@item +@file{ftp://ftp.pilgrim.umass.edu/pub/misc/ding/} + +@item +@file{gopher://gopher.pilgrim.umass.edu/11/pub/misc/ding/} + +@item +@file{ftp://aphrodite.nectar.cs.cmu.edu/pub/ding-gnus/} + +@item +@file{ftp://ftp.solace.mh.se:/pub/gnu/elisp/} + +@end itemize + +@item +Q1.3 Which version of Emacs do I need? + +At least GNU Emacs 19.28, or XEmacs 19.12 is recommended. GNU Emacs +19.25 has been reported to work under certain circumstances, but it +doesn't @emph{officially} work on it. 19.27 has also been reported to +work. Gnus has been reported to work under OS/2 as well as Unix. + + +@item +Q1.4 Where is timezone.el? + +Upgrade to XEmacs 19.13. In earlier versions of XEmacs this file was +placed with Gnus 4.1.3, but that has been corrected. + + +@item +Q1.5 When I run Gnus on XEmacs 19.13 I get weird error messages. + +You're running an old version of Gnus. Upgrade to at least version +5.0.4. + + +@item +Q1.6 How do I unsubscribe from the Mailing List? + +Send an e-mail message to @file{ding-request@@ifi.uio.no} with the magic word +@emph{unsubscribe} somewhere in it, and you will be removed. + +If you are reading the digest version of the list, send an e-mail message +to @* +@file{ding-rn-digests-d-request@@moe.shore.net} +with @emph{unsubscribe} as the subject and you will be removed. + + +@item +Q1.7 How do I run Gnus on both Emacs and XEmacs? + +The basic answer is to byte-compile under XEmacs, and then you can +run under either Emacsen. There is, however, a potential version +problem with easymenu.el with Gnu Emacs prior to 19.29. + +Per Abrahamsen writes :@* +The internal easymenu.el interface changed between 19.28 and 19.29 in +order to make it possible to create byte compiled files that can be +shared between Gnu Emacs and XEmacs. The change is upward +compatible, but not downward compatible. +This gives the following compatibility table: + +@example +Compiled with: | Can be used with: +----------------+-------------------------------------- +19.28 | 19.28 19.29 +19.29 | 19.29 XEmacs +XEmacs | 19.29 XEmacs +@end example + +If you have Gnu Emacs 19.28 or earlier, or XEmacs 19.12 or earlier, get +a recent version of auc-menu.el from +@file{ftp://ftp.iesd.auc.dk/pub/emacs-lisp/auc-menu.el}, and install it +under the name easymenu.el somewhere early in your load path. + + +@item +Q1.8 What resources are available? + +There is the newsgroup Gnu.emacs.gnus. Discussion of Gnus 5.x is now +taking place there. There is also a mailing list, send mail to +@file{ding-request@@ifi.uio.no} with the magic word @emph{subscribe} +somewhere in it. + +@emph{NOTE:} the traffic on this list is heavy so you may not want to be +on it (unless you use Gnus as your mailer reader, that is). The mailing +list is mainly for developers and testers. + +Gnus has a home World Wide Web page at@* +@file{http://www.ifi.uio.no/~larsi/ding.html}. + +Gnus has a write up in the X Windows Applications FAQ at@* +@file{http://www.ee.ryerson.ca:8080/~elf/xapps/Q-III.html}. + +The Gnus manual is also available on the World Wide Web. The canonical +source is in Norway at@* +@file{http://www.ifi.uio.no/~larsi/ding-manual/gnus_toc.html}. + +There are three mirrors in the United States: +@enumerate +@item +@file{http://www.miranova.com/gnus-man/} + +@item +@file{http://www.pilgrim.umass.edu/pub/misc/ding/manual/gnus_toc.html} + +@item +@file{http://www.rtd.com/~woo/gnus/} + +@end enumerate + +PostScript copies of the Gnus Reference card are available from@* +@file{ftp://ftp.cs.ualberta.ca/pub/oolog/gnus/}. They are mirrored at@* +@file{ftp://ftp.pilgrim.umass.edu/pub/misc/ding/refcard/} in the +United States. And@* +@file{ftp://marvin.fkphy.uni-duesseldorf.de/pub/gnus/} +in Germany. + +An online version of the Gnus FAQ is available at@* +@file{http://www.miranova.com/~steve/gnus-faq.html}. Off-line formats +are also available:@* +ASCII: @file{ftp://ftp.miranova.com/pub/gnus/gnus-faq}@* +PostScript: @file{ftp://ftp.miranova.com/pub/gnus/gnus-faq.ps}. + + +@item +Q1.9 Gnus hangs on connecting to NNTP server + +I am running XEmacs on SunOS and Gnus prints a message about Connecting +to NNTP server and then just hangs. + +Ben Wing writes :@* +I wonder if you're hitting the infamous @emph{libresolv} problem. +The basic problem is that under SunOS you can compile either +with DNS or NIS name lookup libraries but not both. Try +substituting the IP address and see if that works; if so, you +need to download the sources and recompile. + + +@item +Q1.10 Mailcrypt 3.4 doesn't work + +This problem is verified to still exist in Gnus 5.0.9 and Mailcrypt 3.4. +The answer comes from Peter Arius +. + +I found out that mailcrypt uses +@code{gnus-eval-in-buffer-window}, which is a macro. +It seems as if you have +compiled mailcrypt with plain old GNUS in load path, and the XEmacs byte +compiler has inserted that macro definition into +@file{mc-toplev.elc}. +The solution is to recompile @file{mc-toplev.el} with Gnus 5 in +load-path, and it works fine. + +Steve Baur adds :@* +The problem also manifests itself if neither GNUS 4 nor Gnus 5 is in the +load-path. + + +@item +Q1.11 What other packages work with Gnus? + +@itemize @minus +@item +Mailcrypt. + +Mailcrypt is an Emacs interface to PGP. It works, it installs +without hassle, and integrates very easily. Mailcrypt can be +obtained from@* +@file{ftp://cag.lcs.mit.edu/pub/patl/mailcrypt-3.4.tar.gz}. + +@item +Tools for Mime. + +Tools for Mime is an Emacs MUA interface to MIME. Installation is +a two-step process unlike most other packages, so you should +be prepared to move the byte-compiled code somewhere. There +are currently two versions of this package available. It can +be obtained from@* +@file{ftp://ftp.jaist.ac.jp/pub/GNU/elisp/}. +Be sure to apply the supplied patch. It works with Gnus through +version 5.0.9. In order for all dependencies to work correctly +the load sequence is as follows: +@lisp + (load "tm-setup") + (load "gnus") + (load "mime-compose") +@end lisp + +@emph{NOTE:} Loading the package disables citation highlighting by +default. To get the old behavior back, use the @kbd{M-t} command. + +@end itemize + +@end itemize + + +@node Customization FAQ +@subsection Customization + +@itemize @bullet +@item +Q2.1 Custom Edit does not work under XEmacs + +The custom package has not been ported to XEmacs. + + +@item +Q2.2 How do I quote messages? + +I see lots of messages with quoted material in them. I am wondering +how to have Gnus do it for me. + +This is Gnus, so there are a number of ways of doing this. You can use +the built-in commands to do this. There are the @kbd{F} and @kbd{R} +keys from the summary buffer which automatically include the article +being responded to. These commands are also selectable as @i{Followup +and Yank} and @i{Reply and Yank} in the Post menu. + +@kbd{C-c C-y} grabs the previous message and prefixes each line with +@code{ail-indentation-spaces} spaces or @code{mail-yank-prefix} if that is +non-nil, unless you have set your own @code{mail-citation-hook}, which will +be called to do the job. + +You might also consider the Supercite package, which allows for pretty +arbitrarily complex quoting styles. Some people love it, some people +hate it. + + +@item +Q2.3 How can I keep my nnvirtual:* groups sorted? + +How can I most efficiently arrange matters so as to keep my nnvirtual:* +(etc) groups at the top of my group selection buffer, whilst keeping +everything sorted in alphabetical order. + +If you don't subscribe often to new groups then the easiest way is to +first sort the groups and then manually kill and yank the virtuals +wherever you want them. + + +@item +Q2.4 Any good suggestions on stuff for an all.SCORE file? + +Here is a collection of suggestions from the Gnus mailing list. + +@enumerate +@item +From ``Dave Disser'' @* +I like blasting anything without lowercase letters. Weeds out most of +the make $$ fast, as well as the lame titles like ``IBM'' and ``HP-UX'' +with no further description. +@lisp + (("Subject" + ("^\\(Re: \\)?[^a-z]*$" -200 nil R))) +@end lisp + +@item +From ``Peter Arius'' @* +The most vital entries in my (still young) all.SCORE: +@lisp +(("xref" + ("alt.fan.oj-simpson" -1000 nil s)) + ("subject" + ("\\<\\(make\\|fast\\|big\\)\\s-*\\(money\\|cash\\|bucks?\\)\\>" -1000 nil r) + ("$$$$" -1000 nil s))) +@end lisp + +@item +From ``Per Abrahamsen'' @* +@lisp +(("subject" + ;; CAPS OF THE WORLD, UNITE + ("^..[^a-z]+$" -1 nil R) + ;; $$$ Make Money $$$ (Try work) + ("$" -1 nil s) + ;; I'm important! And I have exclamation marks to prove it! + ("!" -1 nil s))) +@end lisp + +@item +From ``heddy boubaker'' @* +I would like to contribute with mine. +@lisp +( + (read-only t) + ("subject" + ;; ALL CAPS SUBJECTS + ("^\\([Rr][Ee]: +\\)?[^a-z]+$" -1 nil R) + ;; $$$ Make Money $$$ + ("$$" -10 nil s) + ;; Empty subjects are worthless! + ("^ *\\([(<]none[>)]\\|(no subject\\( given\\)?)\\)? *$" -10 nil r) + ;; Sometimes interesting announces occur! + ("ANN?OU?NC\\(E\\|ING\\)" +10 nil r) + ;; Some people think they're on mailing lists + ("\\(un\\)?sub?scribe" -100 nil r) + ;; Stop Micro$oft NOW!! + ("\\(m\\(icro\\)?[s$]\\(oft\\|lot\\)?-?\\)?wind?\\(ows\\|aube\\|oze\\)?[- ]*\\('?95\\|NT\\|3[.]1\\|32\\)" -1001 nil r) + ;; I've nothing to buy + ("\\(for\\|4\\)[- ]*sale" -100 nil r) + ;; SELF-DISCIPLINED people + ("\\[[^a-z0-9 \t\n][^a-z0-9 \t\n]\\]" +100 nil r) + ) + ("from" + ;; To keep track of posters from my site + (".dgac.fr" +1000 nil s)) + ("followup" + ;; Keep track of answers to my posts + ("boubaker" +1000 nil s)) + ("lines" + ;; Some people have really nothing to say!! + (1 -10 nil <=)) + (mark -100) + (expunge -1000) + ) +@end lisp + +@item +From ``Christopher Jones'' @* +The sample @file{all.SCORE} files from Per and boubaker could be +augmented with: +@lisp + (("subject" + ;; No junk mail please! + ("please ignore" -500 nil s) + ("test" -500 nil e)) + ) +@end lisp + +@item +From ``Brian Edmonds'' @* +Augment any of the above with a fast method of scoring down +excessively cross posted articles. +@lisp + ("xref" + ;; the more cross posting, the exponentially worse the article + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+" -1 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -2 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -4 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -8 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -16 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -32 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -64 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -128 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -256 nil r) + ("^xref: \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+ \\S-+" -512 nil r)) +@end lisp + +@end enumerate + + +@item +Q2.5 What do I use to yank-through when replying? + +You should probably reply and followup with @kbd{R} and @kbd{F}, instead +of @kbd{r} and @kbd{f}, which solves your problem. But you could try +something like: + +@example +(defconst mail-yank-ignored-headers + "^.*:" + "Delete these headers from old message when it's inserted in a reply.") +@end example + + +@item +Q2.6 I don't like the default WWW browser + +Now when choosing an URL Gnus starts up a W3 buffer, I would like it +to always use Netscape (I don't browse in text-mode ;-). + +@enumerate +@item +Activate `Customize...' from the `Help' menu. + +@item +Scroll down to the `WWW Browser' field. + +@item +Click `mouse-2' on `WWW Browser'. + +@item +Select `Netscape' from the pop up menu. + +@item +Press `C-c C-c' + +@end enumerate + +If you are using XEmacs then to specify Netscape do +@lisp + (setq gnus-button-url 'gnus-netscape-open-url) +@end lisp + + +@item +Q2.7 What, if any, relation is between ``ask-server'' and ``(setq +gnus-read-active-file 'some)''? + +In order for Gnus to show you the complete list of newsgroups, it will +either have to either store the list locally, or ask the server to +transmit the list. You enable the first with + +@lisp + (setq gnus-save-killed-list t) +@end lisp + +and the second with + +@lisp + (setq gnus-read-active-file t) +@end lisp + +If both are disabled, Gnus will not know what newsgroups exists. There +is no option to get the list by casting a spell. + + +@item +Q2.8 Moving between groups is slow. + +Per Abrahamsen writes:@* + +Do you call @code{define-key} or something like that in one of the +summary mode hooks? This would force Emacs to recalculate the keyboard +shortcuts. Removing the call should speed up @kbd{M-x gnus-summary-mode +RET} by a couple of orders of magnitude. You can use + +@lisp +(define-key gnus-summary-mode-map KEY COMMAND) +@end lisp + +in your @file{.gnus} instead. + +@end itemize + + +@node Reading News FAQ +@subsection Reading News + +@itemize @bullet +@item +Q3.1 How do I convert my kill files to score files? + +A kill-to-score translator was written by Ethan Bradford +. It is available from@* +@file{http://baugi.ifi.uio.no/~larsi/ding-various/gnus-kill-to-score.el}. + + +@item +Q3.2 My news server has a lot of groups, and killing groups is painfully +slow. + +Don't do that then. The best way to get rid of groups that should be +dead is to edit your newsrc directly. This problem will be addressed +in the near future. + + +@item +Q3.3 How do I use an NNTP server with authentication? + +Put the following into your .gnus: +@lisp + (add-hook 'nntp-server-opened-hook 'nntp-send-authinfo) +@end lisp + + +@item +Q3.4 Not reading the first article. + +How do I avoid reading the first article when a group is selected? + +@enumerate +@item +Use @kbd{RET} to select the group instead of @kbd{SPC}. + +@item +@code{(setq gnus-auto-select first nil)} + +@item +Luis Fernandes writes:@* +This is what I use...customize as necessary... + +@lisp +;;; Don't auto-select first article if reading sources, or archives or +;;; jobs postings, etc. and just display the summary buffer +(add-hook 'gnus-select-group-hook + (function + (lambda () + (cond ((string-match "sources" gnus-newsgroup-name) + (setq gnus-auto-select-first nil)) + ((string-match "jobs" gnus-newsgroup-name) + (setq gnus-auto-select-first nil)) + ((string-match "comp\\.archives" gnus-newsgroup-name) + (setq gnus-auto-select-first nil)) + ((string-match "reviews" gnus-newsgroup-name) + (setq gnus-auto-select-first nil)) + ((string-match "announce" gnus-newsgroup-name) + (setq gnus-auto-select-first nil)) + ((string-match "binaries" gnus-newsgroup-name) + (setq gnus-auto-select-first nil)) + (t + (setq gnus-auto-select-first t)))))) +@end lisp + +@item +Per Abrahamsen writes:@* +Another possibility is to create an @file{all.binaries.all.SCORE} file +like this: + +@lisp +((local + (gnus-auto-select-first nil))) +@end lisp + +and insert +@lisp + (setq gnus-auto-select-first t) +@end lisp + +in your @file{.gnus}. + +@end enumerate + +@item +Q3.5 Why aren't BBDB known posters marked in the summary buffer? + +Brian Edmonds writes:@* +Due to changes in Gnus 5.0, @file{bbdb-gnus.el} no longer marks known +posters in the summary buffer. An updated version, @file{gnus-bbdb.el} +is available at the locations listed below. This package also supports +autofiling of incoming mail to folders specified in the BBDB. Extensive +instructions are included as comments in the file. + +Send mail to @file{majordomo@@edmonds.home.cs.ubc.ca} with the following +line in the body of the message: @emph{get misc gnus-bbdb.el}. + +Or get it from the World Wide Web:@* +@file{http://www.cs.ubc.ca/spider/edmonds/gnus-bbdb.el}. + +@end itemize + + +@node Reading Mail FAQ +@subsection Reading Mail + +@itemize @bullet +@item +Q4.1 What does the message ``Buffer has changed on disk'' mean in a mail +group? + +Your filter program should not deliver mail directly to your folders, +instead it should put the mail into spool files. Gnus will then move +the mail safely from the spool files into the folders. This will +eliminate the problem. Look it up in the manual, in the section +entitled ``Mail & Procmail''. + + +@item +Q4.2 How do you make articles un-expirable? + +I am using nnml to read news and have used +@code{gnus-auto-expirable-newsgroups} to automagically expire articles +in some groups (Gnus being one of them). Sometimes there are +interesting articles in these groups that I want to keep. Is there any +way of explicitly marking an article as un-expirable - that is mark it +as read but not expirable? + +Use @kbd{u}, @kbd{!}, @kbd{d} or @kbd{M-u} in the summary buffer. You +just remove the @kbd{E} mark by setting some other mark. It's not +necessary to tick the articles. + + +@item +Q4.3 How do I delete bogus nnml: groups? + +My problem is that I have various mail (nnml) groups generated while +experimenting with Gnus. How do I remove them now? Setting the level to +9 does not help. Also @code{gnus-group-check-bogus-groups} does not +recognize them. + +Removing mail groups is tricky at the moment. (It's on the to-do list, +though.) You basically have to kill the groups in Gnus, shut down Gnus, +edit the active file to exclude these groups, and probably remove the +nnml directories that contained these groups as well. Then start Gnus +back up again. + + +@item +Q4.4 What happened to my new mail groups? + +I got new mail, but I have +never seen the groups they should have been placed in. + +They are probably there, but as zombies. Press @kbd{A z} to list +zombie groups, and then subscribe to the groups you want with @kbd{u}. +This is all documented quite nicely in the user's manual. + + +@item +Q4.5 Not scoring mail groups + +How do you @emph{totally} turn off scoring in mail groups? + +Use an nnbabyl:all.SCORE (or nnmh, or nnml, or whatever) file containing: + +@example +((adapt ignore) + (local (gnus-use-scoring nil)) + (exclude-files "all.SCORE")) +@end example + +@end itemize + + diff --git a/texi/gnus.texi b/texi/gnus.texi new file mode 100644 index 0000000..e70d9f9 --- /dev/null +++ b/texi/gnus.texi @@ -0,0 +1,17790 @@ +\input texinfo @c -*-texinfo-*- + +@setfilename gnus +@settitle Quassia Gnus 0.110 Manual +@synindex fn cp +@synindex vr cp +@synindex pg cp +@iftex +@finalout +@end iftex +@setchapternewpage odd + +@iftex +@iflatex +\documentclass[twoside,a4paper,openright,11pt]{book} +\usepackage[latin1]{inputenc} +\usepackage{pagestyle} +\usepackage{epsfig} +\usepackage{bembo} + +\makeindex +\begin{document} + +\newcommand{\gnuschaptername}{} +\newcommand{\gnussectionname}{} + +\newcommand{\gnusbackslash}{/} + +\newcommand{\gnusxref}[1]{See ``#1'' on page \pageref{#1}} +\newcommand{\gnuspxref}[1]{see ``#1'' on page \pageref{#1}} + +\newcommand{\gnuskindex}[1]{\index{#1}} +\newcommand{\gnusindex}[1]{\index{#1}} + +\newcommand{\gnustt}[1]{{\fontfamily{pfu}\fontsize{10pt}{10}\selectfont #1}} +\newcommand{\gnuscode}[1]{\gnustt{#1}} +\newcommand{\gnussamp}[1]{``{\fontencoding{OT1}\fontfamily{pcr}\fontsize{10pt}{10}\selectfont #1}''} +\newcommand{\gnuslisp}[1]{\gnustt{#1}} +\newcommand{\gnuskbd}[1]{`\gnustt{#1}'} +\newcommand{\gnusfile}[1]{`\gnustt{#1}'} +\newcommand{\gnusdfn}[1]{\textit{#1}} +\newcommand{\gnusi}[1]{\textit{#1}} +\newcommand{\gnusstrong}[1]{\textbf{#1}} +\newcommand{\gnusemph}[1]{\textit{#1}} +\newcommand{\gnusvar}[1]{{\fontsize{10pt}{10}\selectfont\textsl{\textsf{#1}}}} +\newcommand{\gnussc}[1]{\textsc{#1}} +\newcommand{\gnustitle}[1]{{\huge\textbf{#1}}} +\newcommand{\gnusauthor}[1]{{\large\textbf{#1}}} + +\newcommand{\gnusbullet}{{${\bullet}$}} +\newcommand{\gnusdollar}{\$} +\newcommand{\gnusampersand}{\&} +\newcommand{\gnuspercent}{\%} +\newcommand{\gnushash}{\#} +\newcommand{\gnushat}{\symbol{"5E}} +\newcommand{\gnusunderline}{\symbol{"5F}} +\newcommand{\gnusnot}{$\neg$} +\newcommand{\gnustilde}{\symbol{"7E}} +\newcommand{\gnusless}{{$<$}} +\newcommand{\gnusgreater}{{$>$}} + +\newcommand{\gnushead}{\raisebox{-1cm}{\epsfig{figure=gnus-head.eps,height=1cm}}} +\newcommand{\gnusinteresting}{ +\marginpar[\mbox{}\hfill\gnushead]{\gnushead} +} + +\newcommand{\gnuscleardoublepage}{\ifodd\count0\mbox{}\clearpage\thispagestyle{empty}\mbox{}\clearpage\else\clearpage\fi} + +\newcommand{\gnuspagechapter}[1]{ +{\mbox{}} +} + +\newdimen{\gnusdimen} +\gnusdimen 0pt + +\newcommand{\gnuschapter}[2]{ +\gnuscleardoublepage +\ifdim \gnusdimen = 0pt\setcounter{page}{1}\pagestyle{gnus}\pagenumbering{arabic} \gnusdimen 1pt\fi +\chapter{#2} +\renewcommand{\gnussectionname}{} +\renewcommand{\gnuschaptername}{#2} +\thispagestyle{empty} +\hspace*{-2cm} +\begin{picture}(500,500)(0,0) +\put(480,350){\makebox(0,0)[tr]{#1}} +\put(40,300){\makebox(500,50)[bl]{{\Huge\bf{#2}}}} +\end{picture} +\clearpage +} + +\newcommand{\gnusfigure}[3]{ +\begin{figure} +\mbox{}\ifodd\count0\hspace*{-0.8cm}\else\hspace*{-3cm}\fi\begin{picture}(440,#2) +#3 +\end{picture} +\caption{#1} +\end{figure} +} + +\newcommand{\gnusicon}[1]{ +\marginpar[\mbox{}\hfill\raisebox{-1.5cm}{\epsfig{figure=tmp/#1-up.ps,height=1.5cm}}]{\raisebox{-1cm}{\epsfig{figure=tmp/#1-up.ps,height=1cm}}} +} + +\newcommand{\gnuspicon}[1]{ +\marginpar[\mbox{}\hfill\epsfig{figure=#1,height=1.5cm}]{\epsfig{figure=#1,height=1.5cm}} +} + +\newcommand{\gnusxface}[1]{ +\marginpar[\mbox{}\hfill\epsfig{figure=#1,height=1cm}]{\epsfig{figure=#1,height=1cm}} +} + + +\newcommand{\gnusitemx}[1]{\mbox{}\vspace*{-\itemsep}\vspace*{-\parsep}\item#1} + +\newcommand{\gnussection}[1]{ +\renewcommand{\gnussectionname}{#1} +\section{#1} +} + +\newenvironment{codelist}% +{\begin{list}{}{ +} +}{\end{list}} + +\newenvironment{kbdlist}% +{\begin{list}{}{ +\labelwidth=0cm +} +}{\end{list}} + +\newenvironment{dfnlist}% +{\begin{list}{}{ +} +}{\end{list}} + +\newenvironment{stronglist}% +{\begin{list}{}{ +} +}{\end{list}} + +\newenvironment{samplist}% +{\begin{list}{}{ +} +}{\end{list}} + +\newenvironment{varlist}% +{\begin{list}{}{ +} +}{\end{list}} + +\newenvironment{emphlist}% +{\begin{list}{}{ +} +}{\end{list}} + +\newlength\gnusheadtextwidth +\setlength{\gnusheadtextwidth}{\headtextwidth} +\addtolength{\gnusheadtextwidth}{1cm} + +\newpagestyle{gnuspreamble}% +{ +{ +\ifodd\count0 +{ +\hspace*{-0.23cm}\underline{\makebox[\gnusheadtextwidth]{\mbox{}}\textbf{\hfill\roman{page}}} +} +\else +{ +\hspace*{-3.25cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\roman{page}\hfill\mbox{}}} +} +} +\fi +} +} +{ +\ifodd\count0 +\mbox{} \hfill +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\else +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\hfill \mbox{} +\fi +} + +\newpagestyle{gnusindex}% +{ +{ +\ifodd\count0 +{ +\hspace*{-0.23cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\gnuschaptername\hfill\arabic{page}}}} +} +\else +{ +\hspace*{-3.25cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\arabic{page}\hfill\gnuschaptername}}} +} +\fi +} +} +{ +\ifodd\count0 +\mbox{} \hfill +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\else +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\hfill \mbox{} +\fi +} + +\newpagestyle{gnus}% +{ +{ +\ifodd\count0 +{ +\makebox[12cm]{\hspace*{3.1cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\arabic{chapter}.\arabic{section}} \textbf{\gnussectionname\hfill\arabic{page}}}}} +} +\else +{ +\makebox[12cm]{\hspace*{-2.95cm}\underline{\makebox[\gnusheadtextwidth]{\textbf{\arabic{page}\hfill\gnuschaptername}}}} +} +\fi +} +} +{ +\ifodd\count0 +\mbox{} \hfill +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\else +\raisebox{-0.5cm}{\epsfig{figure=gnus-big-logo.eps,height=1cm}} +\hfill \mbox{} +\fi +} + +\pagenumbering{roman} +\pagestyle{gnuspreamble} + +@end iflatex +@end iftex + +@iftex +@iflatex +\begin{titlepage} +{ + +%\addtolength{\oddsidemargin}{-5cm} +%\addtolength{\evensidemargin}{-5cm} +\parindent=0cm +\addtolength{\textheight}{2cm} + +\gnustitle{\gnustitlename}\\ +\rule{15cm}{1mm}\\ +\vfill +\hspace*{0cm}\epsfig{figure=gnus-big-logo.eps,height=15cm} +\vfill +\rule{15cm}{1mm}\\ +\gnusauthor{by Lars Magne Ingebrigtsen} +\newpage +} + +\mbox{} +\vfill + +\thispagestyle{empty} + +Copyright \copyright{} 1995,96 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions. + +\newpage +\end{titlepage} +@end iflatex +@end iftex + +@ifinfo + +This file documents Gnus, the GNU Emacs newsreader. + +Copyright (C) 1995,96 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through Tex and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided also that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions. +@end ifinfo + +@tex + +@titlepage +@title Quassia Gnus 0.110 Manual + +@author by Lars Magne Ingebrigtsen +@page + +@vskip 0pt plus 1filll +Copyright @copyright{} 1995,96,97 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions. + +@end titlepage +@page + +@end tex + + +@node Top +@top The Gnus Newsreader + +@ifinfo + +You can read news (and mail) from within Emacs by using Gnus. The news +can be gotten by any nefarious means you can think of---@sc{nntp}, local +spool or your mbox file. All at the same time, if you want to push your +luck. + +This manual corresponds to Quassia Gnus 0.110. + +@end ifinfo + +@iftex + +@iflatex +\tableofcontents +\gnuscleardoublepage +@end iflatex + +Gnus is the advanced, self-documenting, customizable, extensible +unreal-time newsreader for GNU Emacs. + +Oops. That sounds oddly familiar, so let's start over again to avoid +being accused of plagiarism: + +Gnus is a message-reading laboratory. It will let you look at just +about anything as if it were a newsgroup. You can read mail with it, +you can browse directories with it, you can @code{ftp} with it---you can +even read news with it! + +Gnus tries to empower people who read news the same way Emacs empowers +people who edit text. Gnus sets no limits to what the user should be +allowed to do. Users are encouraged to extend Gnus to make it behave +like they want it to behave. A program should not control people; +people should be empowered to do what they want by using (or abusing) +the program. + +@end iftex + + +@menu +* Starting Up:: Finding news can be a pain. +* The Group Buffer:: Selecting, subscribing and killing groups. +* The Summary Buffer:: Reading, saving and posting articles. +* The Article Buffer:: Displaying and handling articles. +* Composing Messages:: Information on sending mail and news. +* Select Methods:: Gnus reads all messages from various select methods. +* Scoring:: Assigning values to articles. +* Various:: General purpose settings. +* The End:: Farewell and goodbye. +* Appendices:: Terminology, Emacs intro, FAQ, History, Internals. +* Index:: Variable, function and concept index. +* Key Index:: Key Index. +@end menu + +@node Starting Up +@chapter Starting Gnus +@cindex starting up + +@kindex M-x gnus +@findex gnus +If your system administrator has set things up properly, starting Gnus +and reading news is extremely easy---you just type @kbd{M-x gnus} in +your Emacs. + +@findex gnus-other-frame +@kindex M-x gnus-other-frame +If you want to start Gnus in a different frame, you can use the command +@kbd{M-x gnus-other-frame} instead. + +If things do not go smoothly at startup, you have to twiddle some +variables in your @file{~/.gnus} file. This file is similar to +@file{~/.emacs}, but is read when gnus starts. + +@menu +* Finding the News:: Choosing a method for getting news. +* The First Time:: What does Gnus do the first time you start it? +* The Server is Down:: How can I read my mail then? +* Slave Gnusae:: You can have more than one Gnus active at a time. +* Fetching a Group:: Starting Gnus just to read a group. +* New Groups:: What is Gnus supposed to do with new groups? +* Startup Files:: Those pesky startup files---@file{.newsrc}. +* Auto Save:: Recovering from a crash. +* The Active File:: Reading the active file over a slow line Takes Time. +* Changing Servers:: You may want to move from one server to another. +* Startup Variables:: Other variables you might change. +@end menu + + +@node Finding the News +@section Finding the News +@cindex finding news + +@vindex gnus-select-method +@c @head +The @code{gnus-select-method} variable says where Gnus should look for +news. This variable should be a list where the first element says +@dfn{how} and the second element says @dfn{where}. This method is your +native method. All groups not fetched with this method are +foreign groups. + +For instance, if the @samp{news.somewhere.edu} @sc{nntp} server is where +you want to get your daily dosage of news from, you'd say: + +@lisp +(setq gnus-select-method '(nntp "news.somewhere.edu")) +@end lisp + +If you want to read directly from the local spool, say: + +@lisp +(setq gnus-select-method '(nnspool "")) +@end lisp + +If you can use a local spool, you probably should, as it will almost +certainly be much faster. + +@vindex gnus-nntpserver-file +@cindex NNTPSERVER +@cindex @sc{nntp} server +If this variable is not set, Gnus will take a look at the +@code{NNTPSERVER} environment variable. If that variable isn't set, +Gnus will see whether @code{gnus-nntpserver-file} +(@file{/etc/nntpserver} by default) has any opinions on the matter. If +that fails as well, Gnus will try to use the machine running Emacs as an @sc{nntp} server. That's a long shot, though. + +@vindex gnus-nntp-server +If @code{gnus-nntp-server} is set, this variable will override +@code{gnus-select-method}. You should therefore set +@code{gnus-nntp-server} to @code{nil}, which is what it is by default. + +@vindex gnus-secondary-servers +You can also make Gnus prompt you interactively for the name of an +@sc{nntp} server. If you give a non-numerical prefix to @code{gnus} +(i.e., @kbd{C-u M-x gnus}), Gnus will let you choose between the servers +in the @code{gnus-secondary-servers} list (if any). You can also just +type in the name of any server you feel like visiting. + +@findex gnus-group-browse-foreign-server +@kindex B (Group) +However, if you use one @sc{nntp} server regularly and are just +interested in a couple of groups from a different server, you would be +better served by using the @kbd{B} command in the group buffer. It will +let you have a look at what groups are available, and you can subscribe +to any of the groups you want to. This also makes @file{.newsrc} +maintenance much tidier. @xref{Foreign Groups}. + +@vindex gnus-secondary-select-methods +@c @head +A slightly different approach to foreign groups is to set the +@code{gnus-secondary-select-methods} variable. The select methods +listed in this variable are in many ways just as native as the +@code{gnus-select-method} server. They will also be queried for active +files during startup (if that's required), and new newsgroups that +appear on these servers will be subscribed (or not) just as native +groups are. + +For instance, if you use the @code{nnmbox} backend to read your mail, you +would typically set this variable to + +@lisp +(setq gnus-secondary-select-methods '((nnmbox ""))) +@end lisp + + +@node The First Time +@section The First Time +@cindex first time usage + +If no startup files exist, Gnus will try to determine what groups should +be subscribed by default. + +@vindex gnus-default-subscribed-newsgroups +If the variable @code{gnus-default-subscribed-newsgroups} is set, Gnus +will subscribe you to just those groups in that list, leaving the rest +killed. Your system administrator should have set this variable to +something useful. + +Since she hasn't, Gnus will just subscribe you to a few arbitrarily +picked groups (i.e., @samp{*.newusers}). (@dfn{Arbitrary} is defined +here as @dfn{whatever Lars thinks you should read}.) + +You'll also be subscribed to the Gnus documentation group, which should +help you with most common problems. + +If @code{gnus-default-subscribed-newsgroups} is @code{t}, Gnus will just +use the normal functions for handling new groups, and not do anything +special. + + +@node The Server is Down +@section The Server is Down +@cindex server errors + +If the default server is down, Gnus will understandably have some +problems starting. However, if you have some mail groups in addition to +the news groups, you may want to start Gnus anyway. + +Gnus, being the trusting sort of program, will ask whether to proceed +without a native select method if that server can't be contacted. This +will happen whether the server doesn't actually exist (i.e., you have +given the wrong address) or the server has just momentarily taken ill +for some reason or other. If you decide to continue and have no foreign +groups, you'll find it difficult to actually do anything in the group +buffer. But, hey, that's your problem. Blllrph! + +@findex gnus-no-server +@kindex M-x gnus-no-server +@c @head +If you know that the server is definitely down, or you just want to read +your mail without bothering with the server at all, you can use the +@code{gnus-no-server} command to start Gnus. That might come in handy +if you're in a hurry as well. This command will not attempt to contact +your primary server---instead, it will just activate all groups on level +1 and 2. (You should preferably keep no native groups on those two +levels.) + + +@node Slave Gnusae +@section Slave Gnusae +@cindex slave + +You might want to run more than one Emacs with more than one Gnus at the +same time. If you are using different @file{.newsrc} files (e.g., if you +are using the two different Gnusae to read from two different servers), +that is no problem whatsoever. You just do it. + +The problem appears when you want to run two Gnusae that use the same +@code{.newsrc} file. + +To work around that problem some, we here at the Think-Tank at the Gnus +Towers have come up with a new concept: @dfn{Masters} and +@dfn{slaves}. (We have applied for a patent on this concept, and have +taken out a copyright on those words. If you wish to use those words in +conjunction with each other, you have to send $1 per usage instance to +me. Usage of the patent (@dfn{Master/Slave Relationships In Computer +Applications}) will be much more expensive, of course.) + +Anyways, you start one Gnus up the normal way with @kbd{M-x gnus} (or +however you do it). Each subsequent slave Gnusae should be started with +@kbd{M-x gnus-slave}. These slaves won't save normal @file{.newsrc} +files, but instead save @dfn{slave files} that contain information only +on what groups have been read in the slave session. When a master Gnus +starts, it will read (and delete) these slave files, incorporating all +information from them. (The slave files will be read in the sequence +they were created, so the latest changes will have precedence.) + +Information from the slave files has, of course, precedence over the +information in the normal (i.e., master) @code{.newsrc} file. + + +@node Fetching a Group +@section Fetching a Group +@cindex fetching a group + +@findex gnus-fetch-group +It is sometimes convenient to be able to just say ``I want to read this +group and I don't care whether Gnus has been started or not''. This is +perhaps more useful for people who write code than for users, but the +command @code{gnus-fetch-group} provides this functionality in any case. +It takes the group name as a parameter. + + +@node New Groups +@section New Groups +@cindex new groups +@cindex subscription + +@vindex gnus-check-new-newsgroups +If you are satisfied that you really never want to see any new groups, +you can set @code{gnus-check-new-newsgroups} to @code{nil}. This will +also save you some time at startup. Even if this variable is +@code{nil}, you can always subscribe to the new groups just by pressing +@kbd{U} in the group buffer (@pxref{Group Maintenance}). This variable +is @code{ask-server} by default. If you set this variable to +@code{always}, then Gnus will query the backends for new groups even +when you do the @kbd{g} command (@pxref{Scanning New Messages}). + +@menu +* Checking New Groups:: Determining what groups are new. +* Subscription Methods:: What Gnus should do with new groups. +* Filtering New Groups:: Making Gnus ignore certain new groups. +@end menu + + +@node Checking New Groups +@subsection Checking New Groups + +Gnus normally determines whether a group is new or not by comparing the +list of groups from the active file(s) with the lists of subscribed and +dead groups. This isn't a particularly fast method. If +@code{gnus-check-new-newsgroups} is @code{ask-server}, Gnus will ask the +server for new groups since the last time. This is both faster and +cheaper. This also means that you can get rid of the list of killed +groups altogether, so you may set @code{gnus-save-killed-list} to +@code{nil}, which will save time both at startup, at exit, and all over. +Saves disk space, too. Why isn't this the default, then? +Unfortunately, not all servers support this command. + +I bet I know what you're thinking now: How do I find out whether my +server supports @code{ask-server}? No? Good, because I don't have a +fail-safe answer. I would suggest just setting this variable to +@code{ask-server} and see whether any new groups appear within the next +few days. If any do, then it works. If none do, then it doesn't +work. I could write a function to make Gnus guess whether the server +supports @code{ask-server}, but it would just be a guess. So I won't. +You could @code{telnet} to the server and say @code{HELP} and see +whether it lists @samp{NEWGROUPS} among the commands it understands. If +it does, then it might work. (But there are servers that lists +@samp{NEWGROUPS} without supporting the function properly.) + +This variable can also be a list of select methods. If so, Gnus will +issue an @code{ask-server} command to each of the select methods, and +subscribe them (or not) using the normal methods. This might be handy +if you are monitoring a few servers for new groups. A side effect is +that startup will take much longer, so you can meditate while waiting. +Use the mantra ``dingnusdingnusdingnus'' to achieve permanent bliss. + + +@node Subscription Methods +@subsection Subscription Methods + +@vindex gnus-subscribe-newsgroup-method +What Gnus does when it encounters a new group is determined by the +@code{gnus-subscribe-newsgroup-method} variable. + +This variable should contain a function. This function will be called +with the name of the new group as the only parameter. + +Some handy pre-fab functions are: + +@table @code + +@item gnus-subscribe-zombies +@vindex gnus-subscribe-zombies +Make all new groups zombies. This is the default. You can browse the +zombies later (with @kbd{A z}) and either kill them all off properly +(with @kbd{S z}), or subscribe to them (with @kbd{u}). + +@item gnus-subscribe-randomly +@vindex gnus-subscribe-randomly +Subscribe all new groups in arbitrary order. This really means that all +new groups will be added at ``the top'' of the grop buffer. + +@item gnus-subscribe-alphabetically +@vindex gnus-subscribe-alphabetically +Subscribe all new groups in alphabetical order. + +@item gnus-subscribe-hierarchically +@vindex gnus-subscribe-hierarchically +Subscribe all new groups hierarchically. The difference between this +function and @code{gnus-subscribe-alphabetically} is slight. +@code{gnus-subscribe-alphabetically} will subscribe new groups in a strictly +alphabetical fashion, while this function will enter groups into it's +hierarchy. So if you want to have the @samp{rec} hierarchy before the +@samp{comp} hierarchy, this function will not mess that configuration +up. Or something like that. + +@item gnus-subscribe-interactively +@vindex gnus-subscribe-interactively +Subscribe new groups interactively. This means that Gnus will ask +you about @strong{all} new groups. The groups you choose to subscribe +to will be subscribed hierarchically. + +@item gnus-subscribe-killed +@vindex gnus-subscribe-killed +Kill all new groups. + +@end table + +@vindex gnus-subscribe-hierarchical-interactive +A closely related variable is +@code{gnus-subscribe-hierarchical-interactive}. (That's quite a +mouthful.) If this variable is non-@code{nil}, Gnus will ask you in a +hierarchical fashion whether to subscribe to new groups or not. Gnus +will ask you for each sub-hierarchy whether you want to descend the +hierarchy or not. + +One common mistake is to set the variable a few paragraphs above +(@code{gnus-subscribe-newsgroup-method}) to +@code{gnus-subscribe-hierarchical-interactive}. This is an error. This +will not work. This is ga-ga. So don't do it. + + +@node Filtering New Groups +@subsection Filtering New Groups + +A nice and portable way to control which new newsgroups should be +subscribed (or ignored) is to put an @dfn{options} line at the start of +the @file{.newsrc} file. Here's an example: + +@example +options -n !alt.all !rec.all sci.all +@end example + +@vindex gnus-subscribe-options-newsgroup-method +This line obviously belongs to a serious-minded intellectual scientific +person (or she may just be plain old boring), because it says that all +groups that have names beginning with @samp{alt} and @samp{rec} should +be ignored, and all groups with names beginning with @samp{sci} should +be subscribed. Gnus will not use the normal subscription method for +subscribing these groups. +@code{gnus-subscribe-options-newsgroup-method} is used instead. This +variable defaults to @code{gnus-subscribe-alphabetically}. + +@vindex gnus-options-not-subscribe +@vindex gnus-options-subscribe +If you don't want to mess with your @file{.newsrc} file, you can just +set the two variables @code{gnus-options-subscribe} and +@code{gnus-options-not-subscribe}. These two variables do exactly the +same as the @file{.newsrc} @samp{options -n} trick. Both are regexps, +and if the new group matches the former, it will be unconditionally +subscribed, and if it matches the latter, it will be ignored. + +@vindex gnus-auto-subscribed-groups +Yet another variable that meddles here is +@code{gnus-auto-subscribed-groups}. It works exactly like +@code{gnus-options-subscribe}, and is therefore really superfluous, but I +thought it would be nice to have two of these. This variable is more +meant for setting some ground rules, while the other variable is used +more for user fiddling. By default this variable makes all new groups +that come from mail backends (@code{nnml}, @code{nnbabyl}, +@code{nnfolder}, @code{nnmbox}, and @code{nnmh}) subscribed. If you +don't like that, just set this variable to @code{nil}. + +New groups that match this regexp are subscribed using +@code{gnus-subscribe-options-newsgroup-method}. + + +@node Changing Servers +@section Changing Servers +@cindex changing servers + +Sometimes it is necessary to move from one @sc{nntp} server to another. +This happens very rarely, but perhaps you change jobs, or one server is +very flaky and you want to use another. + +Changing the server is pretty easy, right? You just change +@code{gnus-select-method} to point to the new server? + +@emph{Wrong!} + +Article numbers are not (in any way) kept synchronized between different +@sc{nntp} servers, and the only way Gnus keeps track of what articles +you have read is by keeping track of article numbers. So when you +change @code{gnus-select-method}, your @file{.newsrc} file becomes +worthless. + +Gnus provides a few functions to attempt to translate a @file{.newsrc} +file from one server to another. They all have one thing in +common---they take a looong time to run. You don't want to use these +functions more than absolutely necessary. + +@kindex M-x gnus-change-server +@findex gnus-change-server +If you have access to both servers, Gnus can request the headers for all +the articles you have read and compare @code{Message-ID}s and map the +article numbers of the read articles and article marks. The @kbd{M-x +gnus-change-server} command will do this for all your native groups. It +will prompt for the method you want to move to. + +@kindex M-x gnus-group-move-group-to-server +@findex gnus-group-move-group-to-server +You can also move individual groups with the @kbd{M-x +gnus-group-move-group-to-server} command. This is useful if you want to +move a (foreign) group from one server to another. + +@kindex M-x gnus-group-clear-data-on-native-groups +@findex gnus-group-clear-data-on-native-groups +If you don't have access to both the old and new server, all your marks +and read ranges have become worthless. You can use the @kbd{M-x +gnus-group-clear-data-on-native-groups} command to clear out all data +that you have on your native groups. Use with caution. + + +@node Startup Files +@section Startup Files +@cindex startup files +@cindex .newsrc +@cindex .newsrc.el +@cindex .newsrc.eld + +Now, you all know about the @file{.newsrc} file. All subscription +information is traditionally stored in this file. + +Things got a bit more complicated with @sc{gnus}. In addition to +keeping the @file{.newsrc} file updated, it also used a file called +@file{.newsrc.el} for storing all the information that didn't fit into +the @file{.newsrc} file. (Actually, it also duplicated everything in +the @file{.newsrc} file.) @sc{gnus} would read whichever one of these +files was the most recently saved, which enabled people to swap between +@sc{gnus} and other newsreaders. + +That was kinda silly, so Gnus went one better: In addition to the +@file{.newsrc} and @file{.newsrc.el} files, Gnus also has a file called +@file{.newsrc.eld}. It will read whichever of these files that are most +recent, but it will never write a @file{.newsrc.el} file. + +@vindex gnus-save-newsrc-file +You can turn off writing the @file{.newsrc} file by setting +@code{gnus-save-newsrc-file} to @code{nil}, which means you can delete +the file and save some space, as well as making exit from Gnus faster. +However, this will make it impossible to use other newsreaders than +Gnus. But hey, who would want to, right? + +@vindex gnus-save-killed-list +If @code{gnus-save-killed-list} (default @code{t}) is @code{nil}, Gnus +will not save the list of killed groups to the startup file. This will +save both time (when starting and quitting) and space (on disk). It +will also mean that Gnus has no record of what groups are new or old, +so the automatic new groups subscription methods become meaningless. +You should always set @code{gnus-check-new-newsgroups} to @code{nil} or +@code{ask-server} if you set this variable to @code{nil} (@pxref{New +Groups}). This variable can also be a regular expression. If that's +the case, remove all groups that do not match this regexp before +saving. This can be useful in certain obscure situations that involve +several servers where not all servers support @code{ask-server}. + +@vindex gnus-startup-file +The @code{gnus-startup-file} variable says where the startup files are. +The default value is @file{~/.newsrc}, with the Gnus (El Dingo) startup +file being whatever that one is, with a @samp{.eld} appended. + +@vindex gnus-save-newsrc-hook +@vindex gnus-save-quick-newsrc-hook +@vindex gnus-save-standard-newsrc-hook +@code{gnus-save-newsrc-hook} is called before saving any of the newsrc +files, while @code{gnus-save-quick-newsrc-hook} is called just before +saving the @file{.newsrc.eld} file, and +@code{gnus-save-standard-newsrc-hook} is called just before saving the +@file{.newsrc} file. The latter two are commonly used to turn version +control on or off. Version control is on by default when saving the +startup files. If you want to turn backup creation off, say something like: + +@lisp +(defun turn-off-backup () + (set (make-local-variable 'backup-inhibited) t)) + +(add-hook 'gnus-save-quick-newsrc-hook 'turn-off-backup) +(add-hook 'gnus-save-standard-newsrc-hook 'turn-off-backup) +@end lisp + +@vindex gnus-init-file +When Gnus starts, it will read the @code{gnus-site-init-file} +(@file{.../site-lisp/gnus} by default) and @code{gnus-init-file} +(@file{~/.gnus} by default) files. These are normal Emacs Lisp files +and can be used to avoid cluttering your @file{~/.emacs} and +@file{site-init} files with Gnus stuff. Gnus will also check for files +with the same names as these, but with @file{.elc} and @file{.el} +suffixes. In other words, if you have set @code{gnus-init-file} to +@file{~/.gnus}, it will look for @file{~/.gnus.elc}, @file{~/.gnus.el}, +and finally @file{~/.gnus} (in this order). + + + +@node Auto Save +@section Auto Save +@cindex dribble file +@cindex auto-save + +Whenever you do something that changes the Gnus data (reading articles, +catching up, killing/subscribing groups), the change is added to a +special @dfn{dribble buffer}. This buffer is auto-saved the normal +Emacs way. If your Emacs should crash before you have saved the +@file{.newsrc} files, all changes you have made can be recovered from +this file. + +If Gnus detects this file at startup, it will ask the user whether to +read it. The auto save file is deleted whenever the real startup file is +saved. + +@vindex gnus-use-dribble-file +If @code{gnus-use-dribble-file} is @code{nil}, Gnus won't create and +maintain a dribble buffer. The default is @code{t}. + +@vindex gnus-dribble-directory +Gnus will put the dribble file(s) in @code{gnus-dribble-directory}. If +this variable is @code{nil}, which it is by default, Gnus will dribble +into the directory where the @file{.newsrc} file is located. (This is +normally the user's home directory.) The dribble file will get the same +file permissions as the @code{.newsrc} file. + + +@node The Active File +@section The Active File +@cindex active file +@cindex ignored groups + +When Gnus starts, or indeed whenever it tries to determine whether new +articles have arrived, it reads the active file. This is a very large +file that lists all the active groups and articles on the server. + +@vindex gnus-ignored-newsgroups +Before examining the active file, Gnus deletes all lines that match the +regexp @code{gnus-ignored-newsgroups}. This is done primarily to reject +any groups with bogus names, but you can use this variable to make Gnus +ignore hierarchies you aren't ever interested in. However, this is not +recommended. In fact, it's highly discouraged. Instead, @pxref{New +Groups} for an overview of other variables that can be used instead. + +@c This variable is +@c @code{nil} by default, and will slow down active file handling somewhat +@c if you set it to anything else. + +@vindex gnus-read-active-file +@c @head +The active file can be rather Huge, so if you have a slow network, you +can set @code{gnus-read-active-file} to @code{nil} to prevent Gnus from +reading the active file. This variable is @code{some} by default. + +Gnus will try to make do by getting information just on the groups that +you actually subscribe to. + +Note that if you subscribe to lots and lots of groups, setting this +variable to @code{nil} will probably make Gnus slower, not faster. At +present, having this variable @code{nil} will slow Gnus down +considerably, unless you read news over a 2400 baud modem. + +This variable can also have the value @code{some}. Gnus will then +attempt to read active info only on the subscribed groups. On some +servers this is quite fast (on sparkling, brand new INN servers that +support the @code{LIST ACTIVE group} command), on others this isn't fast +at all. In any case, @code{some} should be faster than @code{nil}, and +is certainly faster than @code{t} over slow lines. + +If this variable is @code{nil}, Gnus will ask for group info in total +lock-step, which isn't very fast. If it is @code{some} and you use an +@sc{nntp} server, Gnus will pump out commands as fast as it can, and +read all the replies in one swoop. This will normally result in better +performance, but if the server does not support the aforementioned +@code{LIST ACTIVE group} command, this isn't very nice to the server. + +In any case, if you use @code{some} or @code{nil}, you should definitely +kill all groups that you aren't interested in to speed things up. + +Note that this variable also affects active file retrieval from +secondary select methods. + + +@node Startup Variables +@section Startup Variables + +@table @code + +@item gnus-load-hook +@vindex gnus-load-hook +A hook run while Gnus is being loaded. Note that this hook will +normally be run just once in each Emacs session, no matter how many +times you start Gnus. + +@item gnus-before-startup-hook +@vindex gnus-before-startup-hook +A hook run after starting up Gnus successfully. + +@item gnus-startup-hook +@vindex gnus-startup-hook +A hook run as the very last thing after starting up Gnus + +@item gnus-started-hook +@vindex gnus-started-hook +A hook that is run as the very last thing after starting up Gnus +successfully. + +@item gnus-started-hook +@vindex gnus-started-hook +A hook that is run after reading the @file{.newsrc} file(s), but before +generating the group buffer. + +@item gnus-check-bogus-newsgroups +@vindex gnus-check-bogus-newsgroups +If non-@code{nil}, Gnus will check for and delete all bogus groups at +startup. A @dfn{bogus group} is a group that you have in your +@file{.newsrc} file, but doesn't exist on the news server. Checking for +bogus groups can take quite a while, so to save time and resources it's +best to leave this option off, and do the checking for bogus groups once +in a while from the group buffer instead (@pxref{Group Maintenance}). + +@item gnus-inhibit-startup-message +@vindex gnus-inhibit-startup-message +If non-@code{nil}, the startup message won't be displayed. That way, +your boss might not notice as easily that you are reading news instead +of doing your job. Note that this variable is used before +@file{.gnus.el} is loaded, so it should be set in @code{.emacs} instead. + +@item gnus-no-groups-message +@vindex gnus-no-groups-message +Message displayed by Gnus when no groups are available. + +@item gnus-play-startup-jingle +@vindex gnus-play-startup-jingle +If non-@code{nil}, play the Gnus jingle at startup. + +@item gnus-startup-jingle +@vindex gnus-startup-jingle +Jingle to be played if the above variable is non-@code{nil}. The +default is @samp{Tuxedomoon.Jingle4.au}. + +@end table + + +@node The Group Buffer +@chapter The Group Buffer +@cindex group buffer + +The @dfn{group buffer} lists all (or parts) of the available groups. It +is the first buffer shown when Gnus starts, and will never be killed as +long as Gnus is active. + +@iftex +@iflatex +\gnusfigure{The Group Buffer}{320}{ +\put(75,50){\epsfig{figure=tmp/group.ps,height=9cm}} +\put(120,37){\makebox(0,0)[t]{Buffer name}} +\put(120,38){\vector(1,2){10}} +\put(40,60){\makebox(0,0)[r]{Mode line}} +\put(40,58){\vector(1,0){30}} +\put(200,28){\makebox(0,0)[t]{Native select method}} +\put(200,26){\vector(-1,2){15}} +} +@end iflatex +@end iftex + +@menu +* Group Buffer Format:: Information listed and how you can change it. +* Group Maneuvering:: Commands for moving in the group buffer. +* Selecting a Group:: Actually reading news. +* Group Data:: Changing the info for a group. +* Subscription Commands:: Unsubscribing, killing, subscribing. +* Group Levels:: Levels? What are those, then? +* Group Score:: A mechanism for finding out what groups you like. +* Marking Groups:: You can mark groups for later processing. +* Foreign Groups:: Creating and editing groups. +* Group Parameters:: Each group may have different parameters set. +* Listing Groups:: Gnus can list various subsets of the groups. +* Sorting Groups:: Re-arrange the group order. +* Group Maintenance:: Maintaining a tidy @file{.newsrc} file. +* Browse Foreign Server:: You can browse a server. See what it has to offer. +* Exiting Gnus:: Stop reading news and get some work done. +* Group Topics:: A folding group mode divided into topics. +* Misc Group Stuff:: Other stuff that you can to do. +@end menu + + +@node Group Buffer Format +@section Group Buffer Format + +@menu +* Group Line Specification:: Deciding how the group buffer is to look. +* Group Modeline Specification:: The group buffer modeline. +* Group Highlighting:: Having nice colors in the group buffer. +@end menu + + +@node Group Line Specification +@subsection Group Line Specification +@cindex group buffer format + +The default format of the group buffer is nice and dull, but you can +make it as exciting and ugly as you feel like. + +Here's a couple of example group lines: + +@example + 25: news.announce.newusers + * 0: alt.fan.andrea-dworkin +@end example + +Quite simple, huh? + +You can see that there are 25 unread articles in +@samp{news.announce.newusers}. There are no unread articles, but some +ticked articles, in @samp{alt.fan.andrea-dworkin} (see that little +asterisk at the beginning of the line?). + +@vindex gnus-group-line-format +You can change that format to whatever you want by fiddling with the +@code{gnus-group-line-format} variable. This variable works along the +lines of a @code{format} specification, which is pretty much the same as +a @code{printf} specifications, for those of you who use (feh!) C. +@xref{Formatting Variables}. + +@samp{%M%S%5y: %(%g%)\n} is the value that produced those lines above. + +There should always be a colon on the line; the cursor always moves to +the colon after performing an operation. Nothing else is required---not +even the group name. All displayed text is just window dressing, and is +never examined by Gnus. Gnus stores all real information it needs using +text properties. + +(Note that if you make a really strange, wonderful, spreadsheet-like +layout, everybody will believe you are hard at work with the accounting +instead of wasting time reading news.) + +Here's a list of all available format characters: + +@table @samp + +@item M +An asterisk if the group only has marked articles. + +@item S +Whether the group is subscribed. + +@item L +Level of subscribedness. + +@item N +Number of unread articles. + +@item I +Number of dormant articles. + +@item T +Number of ticked articles. + +@item R +Number of read articles. + +@item t +Estimated total number of articles. (This is really @var{max-number} +minus @var{min-number} plus 1.) + +@item y +Number of unread, unticked, non-dormant articles. + +@item i +Number of ticked and dormant articles. + +@item g +Full group name. + +@item G +Group name. + +@item D +Newsgroup description. + +@item o +@samp{m} if moderated. + +@item O +@samp{(m)} if moderated. + +@item s +Select method. + +@item n +Select from where. + +@item z +A string that looks like @samp{<%s:%n>} if a foreign select method is +used. + +@item P +Indentation based on the level of the topic (@pxref{Group Topics}). + +@item c +@vindex gnus-group-uncollapsed-levels +Short (collapsed) group name. The @code{gnus-group-uncollapsed-levels} +variable says how many levels to leave at the end of the group name. +The default is 1---this will mean that group names like +@samp{gnu.emacs.gnus} will be shortened to @samp{g.emacs.gnus}. + +@item m +@vindex gnus-new-mail-mark +@cindex % +@samp{%} (@code{gnus-new-mail-mark}) if there has arrived new mail to +the group lately. + +@item d +A string that says when you last read the group (@pxref{Group +Timestamp}). + +@item u +User defined specifier. The next character in the format string should +be a letter. Gnus will call the function +@code{gnus-user-format-function-}@samp{X}, where @samp{X} is the letter +following @samp{%u}. The function will be passed a single dummy +parameter as argument. The function should return a string, which will +be inserted into the buffer just like information from any other +specifier. +@end table + +@cindex * +All the ``number-of'' specs will be filled with an asterisk (@samp{*}) +if no info is available---for instance, if it is a non-activated foreign +group, or a bogus native group. + + +@node Group Modeline Specification +@subsection Group Modeline Specification +@cindex group modeline + +@vindex gnus-group-mode-line-format +The mode line can be changed by setting +@code{gnus-group-mode-line-format} (@pxref{Formatting Variables}). It +doesn't understand that many format specifiers: + +@table @samp +@item S +The native news server. +@item M +The native select method. +@end table + + +@node Group Highlighting +@subsection Group Highlighting +@cindex highlighting +@cindex group highlighting + +@vindex gnus-group-highlight +Highlighting in the group buffer is controlled by the +@code{gnus-group-highlight} variable. This is an alist with elements +that look like @var{(form . face)}. If @var{form} evaluates to +something non-@code{nil}, the @var{face} will be used on the line. + +Here's an example value for this variable that might look nice if the +background is dark: + +@lisp +(setq gnus-group-highlight + `(((> unread 200) . + ,(custom-face-lookup "Red" nil nil t nil nil)) + ((and (< level 3) (zerop unread)) . + ,(custom-face-lookup "SeaGreen" nil nil t nil nil)) + ((< level 3) . + ,(custom-face-lookup "SpringGreen" nil nil t nil nil)) + ((zerop unread) . + ,(custom-face-lookup "SteelBlue" nil nil t nil nil)) + (t . + ,(custom-face-lookup "SkyBlue" nil nil t nil nil)))) +@end lisp + +Variables that are dynamically bound when the forms are evaluated +include: + +@table @code +@item group +The group name. +@item unread +The number of unread articles in the group. +@item method +The select method. +@item mailp +Whether the group is a mail group. +@item level +The level of the group. +@item score +The score of the group. +@item ticked +The number of ticked articles in the group. +@item total +The total number of articles in the group. Or rather, MAX-NUMBER minus +MIN-NUMBER plus one. +@item topic +When using the topic minor mode, this variable is bound to the current +topic being inserted. +@end table + +When the forms are @code{eval}ed, point is at the beginning of the line +of the group in question, so you can use many of the normal Gnus +functions for snarfing info on the group. + +@vindex gnus-group-update-hook +@findex gnus-group-highlight-line +@code{gnus-group-update-hook} is called when a group line is changed. +It will not be called when @code{gnus-visual} is @code{nil}. This hook +calls @code{gnus-group-highlight-line} by default. + + +@node Group Maneuvering +@section Group Maneuvering +@cindex group movement + +All movement commands understand the numeric prefix and will behave as +expected, hopefully. + +@table @kbd + +@item n +@kindex n (Group) +@findex gnus-group-next-unread-group +Go to the next group that has unread articles +(@code{gnus-group-next-unread-group}). + +@item p +@itemx DEL +@kindex DEL (Group) +@kindex p (Group) +@findex gnus-group-prev-unread-group +Go to the previous group that has unread articles +(@code{gnus-group-prev-unread-group}). + +@item N +@kindex N (Group) +@findex gnus-group-next-group +Go to the next group (@code{gnus-group-next-group}). + +@item P +@kindex P (Group) +@findex gnus-group-prev-group +Go to the previous group (@code{gnus-group-prev-group}). + +@item M-p +@kindex M-p (Group) +@findex gnus-group-next-unread-group-same-level +Go to the next unread group on the same (or lower) level +(@code{gnus-group-next-unread-group-same-level}). + +@item M-n +@kindex M-n (Group) +@findex gnus-group-prev-unread-group-same-level +Go to the previous unread group on the same (or lower) level +(@code{gnus-group-prev-unread-group-same-level}). +@end table + +Three commands for jumping to groups: + +@table @kbd + +@item j +@kindex j (Group) +@findex gnus-group-jump-to-group +Jump to a group (and make it visible if it isn't already) +(@code{gnus-group-jump-to-group}). Killed groups can be jumped to, just +like living groups. + +@item , +@kindex , (Group) +@findex gnus-group-best-unread-group +Jump to the unread group with the lowest level +(@code{gnus-group-best-unread-group}). + +@item . +@kindex . (Group) +@findex gnus-group-first-unread-group +Jump to the first group with unread articles +(@code{gnus-group-first-unread-group}). +@end table + +@vindex gnus-group-goto-unread +If @code{gnus-group-goto-unread} is @code{nil}, all the movement +commands will move to the next group, not the next unread group. Even +the commands that say they move to the next unread group. The default +is @code{t}. + + +@node Selecting a Group +@section Selecting a Group +@cindex group selection + +@table @kbd + +@item SPACE +@kindex SPACE (Group) +@findex gnus-group-read-group +Select the current group, switch to the summary buffer and display the +first unread article (@code{gnus-group-read-group}). If there are no +unread articles in the group, or if you give a non-numerical prefix to +this command, Gnus will offer to fetch all the old articles in this +group from the server. If you give a numerical prefix @var{N}, @var{N} +determines the number of articles Gnus will fetch. If @var{N} is +positive, Gnus fetches the @var{N} newest articles, if @var{N} is +negative, Gnus fetches the @var{abs(N)} oldest articles. + +@item RET +@kindex RET (Group) +@findex gnus-group-select-group +Select the current group and switch to the summary buffer +(@code{gnus-group-select-group}). Takes the same arguments as +@code{gnus-group-read-group}---the only difference is that this command +does not display the first unread article automatically upon group +entry. + +@item M-RET +@kindex M-RET (Group) +@findex gnus-group-quick-select-group +This does the same as the command above, but tries to do it with the +minimum amount of fuzz (@code{gnus-group-quick-select-group}). No +scoring/killing will be performed, there will be no highlights and no +expunging. This might be useful if you're in a real hurry and have to +enter some humongous group. If you give a 0 prefix to this command +(i.e., @kbd{0 M-RET}), Gnus won't even generate the summary buffer, +which is useful if you want to toggle threading before generating the +summary buffer (@pxref{Summary Generation Commands}). + +@item M-SPACE +@kindex M-SPACE (Group) +@findex gnus-group-visible-select-group +This is yet one more command that does the same as the @kbd{RET} +command, but this one does it without expunging and hiding dormants +(@code{gnus-group-visible-select-group}). + +@item M-C-RET +@kindex M-C-RET (Group) +@findex gnus-group-select-group-ephemerally +Finally, this command selects the current group ephemerally without +doing any processing of its contents +(@code{gnus-group-select-group-ephemerally}). Even threading has been +turned off. Everything you do in the group after selecting it in this +manner will have no permanent effects. + +@end table + +@vindex gnus-large-newsgroup +The @code{gnus-large-newsgroup} variable says what Gnus should consider +to be a big group. This is 200 by default. If the group has more +(unread and/or ticked) articles than this, Gnus will query the user +before entering the group. The user can then specify how many articles +should be fetched from the server. If the user specifies a negative +number (@code{-n}), the @code{n} oldest articles will be fetched. If it +is positive, the @code{n} articles that have arrived most recently will +be fetched. + +@vindex gnus-select-group-hook +@vindex gnus-auto-select-first +@code{gnus-auto-select-first} control whether any articles are selected +automatically when entering a group with the @kbd{SPACE} command. + +@table @code + +@item nil +Don't select any articles when entering the group. Just display the +full summary buffer. + +@item t +Select the first unread article when entering the group. + +@item best +Select the most high-scored article in the group when entering the +group. +@end table + +If you want to prevent automatic selection in some group (say, in a +binary group with Huge articles) you can set this variable to @code{nil} +in @code{gnus-select-group-hook}, which is called when a group is +selected. + + +@node Subscription Commands +@section Subscription Commands +@cindex subscription + +@table @kbd + +@item S t +@itemx u +@kindex S t (Group) +@kindex u (Group) +@findex gnus-group-unsubscribe-current-group +@c @icon{gnus-group-unsubscribe} +Toggle subscription to the current group +(@code{gnus-group-unsubscribe-current-group}). + +@item S s +@itemx U +@kindex S s (Group) +@kindex U (Group) +@findex gnus-group-unsubscribe-group +Prompt for a group to subscribe, and then subscribe it. If it was +subscribed already, unsubscribe it instead +(@code{gnus-group-unsubscribe-group}). + +@item S k +@itemx C-k +@kindex S k (Group) +@kindex C-k (Group) +@findex gnus-group-kill-group +@c @icon{gnus-group-kill-group} +Kill the current group (@code{gnus-group-kill-group}). + +@item S y +@itemx C-y +@kindex S y (Group) +@kindex C-y (Group) +@findex gnus-group-yank-group +Yank the last killed group (@code{gnus-group-yank-group}). + +@item C-x C-t +@kindex C-x C-t (Group) +@findex gnus-group-transpose-groups +Transpose two groups (@code{gnus-group-transpose-groups}). This isn't +really a subscription command, but you can use it instead of a +kill-and-yank sequence sometimes. + +@item S w +@itemx C-w +@kindex S w (Group) +@kindex C-w (Group) +@findex gnus-group-kill-region +Kill all groups in the region (@code{gnus-group-kill-region}). + +@item S z +@kindex S z (Group) +@findex gnus-group-kill-all-zombies +Kill all zombie groups (@code{gnus-group-kill-all-zombies}). + +@item S C-k +@kindex S C-k (Group) +@findex gnus-group-kill-level +Kill all groups on a certain level (@code{gnus-group-kill-level}). +These groups can't be yanked back after killing, so this command should +be used with some caution. The only time where this command comes in +really handy is when you have a @file{.newsrc} with lots of unsubscribed +groups that you want to get rid off. @kbd{S C-k} on level 7 will +kill off all unsubscribed groups that do not have message numbers in the +@file{.newsrc} file. + +@end table + +Also @pxref{Group Levels}. + + +@node Group Data +@section Group Data + +@table @kbd + +@item c +@kindex c (Group) +@findex gnus-group-catchup-current +@vindex gnus-group-catchup-group-hook +@c @icon{gnus-group-catchup-current} +Mark all unticked articles in this group as read +(@code{gnus-group-catchup-current}). +@code{gnus-group-catchup-group-hook} is called when catching up a group from +the group buffer. + +@item C +@kindex C (Group) +@findex gnus-group-catchup-current-all +Mark all articles in this group, even the ticked ones, as read +(@code{gnus-group-catchup-current-all}). + +@item M-c +@kindex M-c (Group) +@findex gnus-group-clear-data +Clear the data from the current group---nix out marks and the list of +read articles (@code{gnus-group-clear-data}). + +@item M-x gnus-group-clear-data-on-native-groups +@kindex M-x gnus-group-clear-data-on-native-groups +@findex gnus-group-clear-data-on-native-groups +If you have switched from one @sc{nntp} server to another, all your marks +and read ranges have become worthless. You can use this command to +clear out all data that you have on your native groups. Use with +caution. + +@end table + + +@node Group Levels +@section Group Levels +@cindex group level +@cindex level + +All groups have a level of @dfn{subscribedness}. For instance, if a +group is on level 2, it is more subscribed than a group on level 5. You +can ask Gnus to just list groups on a given level or lower +(@pxref{Listing Groups}), or to just check for new articles in groups on +a given level or lower (@pxref{Scanning New Messages}). + +Remember: The higher the level of the group, the less important it is. + +@table @kbd + +@item S l +@kindex S l (Group) +@findex gnus-group-set-current-level +Set the level of the current group. If a numeric prefix is given, the +next @var{n} groups will have their levels set. The user will be +prompted for a level. +@end table + +@vindex gnus-level-killed +@vindex gnus-level-zombie +@vindex gnus-level-unsubscribed +@vindex gnus-level-subscribed +Gnus considers groups from levels 1 to +@code{gnus-level-subscribed} (inclusive) (default 5) to be subscribed, +@code{gnus-level-subscribed} (exclusive) and +@code{gnus-level-unsubscribed} (inclusive) (default 7) to be +unsubscribed, @code{gnus-level-zombie} to be zombies (walking dead) +(default 8) and @code{gnus-level-killed} to be killed (completely dead) +(default 9). Gnus treats subscribed and unsubscribed groups exactly the +same, but zombie and killed groups have no information on what articles +you have read, etc, stored. This distinction between dead and living +groups isn't done because it is nice or clever, it is done purely for +reasons of efficiency. + +It is recommended that you keep all your mail groups (if any) on quite +low levels (e.g. 1 or 2). + +If you want to play with the level variables, you should show some care. +Set them once, and don't touch them ever again. Better yet, don't touch +them at all unless you know exactly what you're doing. + +@vindex gnus-level-default-unsubscribed +@vindex gnus-level-default-subscribed +Two closely related variables are @code{gnus-level-default-subscribed} +(default 3) and @code{gnus-level-default-unsubscribed} (default 6), +which are the levels that new groups will be put on if they are +(un)subscribed. These two variables should, of course, be inside the +relevant valid ranges. + +@vindex gnus-keep-same-level +If @code{gnus-keep-same-level} is non-@code{nil}, some movement commands +will only move to groups of the same level (or lower). In +particular, going from the last article in one group to the next group +will go to the next group of the same level (or lower). This might be +handy if you want to read the most important groups before you read the +rest. + +@vindex gnus-group-default-list-level +All groups with a level less than or equal to +@code{gnus-group-default-list-level} will be listed in the group buffer +by default. + +@vindex gnus-group-list-inactive-groups +If @code{gnus-group-list-inactive-groups} is non-@code{nil}, non-active +groups will be listed along with the unread groups. This variable is +@code{t} by default. If it is @code{nil}, inactive groups won't be +listed. + +@vindex gnus-group-use-permanent-levels +If @code{gnus-group-use-permanent-levels} is non-@code{nil}, once you +give a level prefix to @kbd{g} or @kbd{l}, all subsequent commands will +use this level as the ``work'' level. + +@vindex gnus-activate-level +Gnus will normally just activate (i. e., query the server about) groups +on level @code{gnus-activate-level} or less. If you don't want to +activate unsubscribed groups, for instance, you might set this variable +to 5. The default is 6. + + +@node Group Score +@section Group Score +@cindex group score + +You would normally keep important groups on high levels, but that scheme +is somewhat restrictive. Don't you wish you could have Gnus sort the +group buffer according to how often you read groups, perhaps? Within +reason? + +This is what @dfn{group score} is for. You can assign a score to each +group. You can then sort the group buffer based on this score. +Alternatively, you can sort on score and then level. (Taken together, +the level and the score is called the @dfn{rank} of the group. A group +that is on level 4 and has a score of 1 has a higher rank than a group +on level 5 that has a score of 300. (The level is the most significant +part and the score is the least significant part.)) + +@findex gnus-summary-bubble-group +If you want groups you read often to get higher scores than groups you +read seldom you can add the @code{gnus-summary-bubble-group} function to +the @code{gnus-summary-exit-hook} hook. This will result (after +sorting) in a bubbling sort of action. If you want to see that in +action after each summary exit, you can add +@code{gnus-group-sort-groups-by-rank} or +@code{gnus-group-sort-groups-by-score} to the same hook, but that will +slow things down somewhat. + + +@node Marking Groups +@section Marking Groups +@cindex marking groups + +If you want to perform some command on several groups, and they appear +subsequently in the group buffer, you would normally just give a +numerical prefix to the command. Most group commands will then do your +bidding on those groups. + +However, if the groups are not in sequential order, you can still +perform a command on several groups. You simply mark the groups first +with the process mark and then execute the command. + +@table @kbd + +@item # +@kindex # (Group) +@itemx M m +@kindex M m (Group) +@findex gnus-group-mark-group +Set the mark on the current group (@code{gnus-group-mark-group}). + +@item M-# +@kindex M-# (Group) +@itemx M u +@kindex M u (Group) +@findex gnus-group-unmark-group +Remove the mark from the current group +(@code{gnus-group-unmark-group}). + +@item M U +@kindex M U (Group) +@findex gnus-group-unmark-all-groups +Remove the mark from all groups (@code{gnus-group-unmark-all-groups}). + +@item M w +@kindex M w (Group) +@findex gnus-group-mark-region +Mark all groups between point and mark (@code{gnus-group-mark-region}). + +@item M b +@kindex M b (Group) +@findex gnus-group-mark-buffer +Mark all groups in the buffer (@code{gnus-group-mark-buffer}). + +@item M r +@kindex M r (Group) +@findex gnus-group-mark-regexp +Mark all groups that match some regular expression +(@code{gnus-group-mark-regexp}). +@end table + +Also @pxref{Process/Prefix}. + +@findex gnus-group-universal-argument +If you want to execute some command on all groups that have been marked +with the process mark, you can use the @kbd{M-&} +(@code{gnus-group-universal-argument}) command. It will prompt you for +the command to be executed. + + +@node Foreign Groups +@section Foreign Groups +@cindex foreign groups + +Below are some group mode commands for making and editing general foreign +groups, as well as commands to ease the creation of a few +special-purpose groups. All these commands insert the newly created +groups under point---@code{gnus-subscribe-newsgroup-method} is not +consulted. + +@table @kbd + +@item G m +@kindex G m (Group) +@findex gnus-group-make-group +@cindex making groups +Make a new group (@code{gnus-group-make-group}). Gnus will prompt you +for a name, a method and possibly an @dfn{address}. For an easier way +to subscribe to @sc{nntp} groups, @pxref{Browse Foreign Server}. + +@item G r +@kindex G r (Group) +@findex gnus-group-rename-group +@cindex renaming groups +Rename the current group to something else +(@code{gnus-group-rename-group}). This is valid only on some +groups---mail groups mostly. This command might very well be quite slow +on some backends. + +@item G c +@kindex G c (Group) +@cindex customizing +@findex gnus-group-customize +Customize the group parameters (@code{gnus-group-customize}). + +@item G e +@kindex G e (Group) +@findex gnus-group-edit-group-method +@cindex renaming groups +Enter a buffer where you can edit the select method of the current +group (@code{gnus-group-edit-group-method}). + +@item G p +@kindex G p (Group) +@findex gnus-group-edit-group-parameters +Enter a buffer where you can edit the group parameters +(@code{gnus-group-edit-group-parameters}). + +@item G E +@kindex G E (Group) +@findex gnus-group-edit-group +Enter a buffer where you can edit the group info +(@code{gnus-group-edit-group}). + +@item G d +@kindex G d (Group) +@findex gnus-group-make-directory-group +@cindex nndir +Make a directory group (@pxref{Directory Groups}). You will be prompted +for a directory name (@code{gnus-group-make-directory-group}). + +@item G h +@kindex G h (Group) +@cindex help group +@findex gnus-group-make-help-group +Make the Gnus help group (@code{gnus-group-make-help-group}). + +@item G a +@kindex G a (Group) +@cindex (ding) archive +@cindex archive group +@findex gnus-group-make-archive-group +@vindex gnus-group-archive-directory +@vindex gnus-group-recent-archive-directory +Make a Gnus archive group (@code{gnus-group-make-archive-group}). By +default a group pointing to the most recent articles will be created +(@code{gnus-group-recent-archive-directory}), but given a prefix, a full +group will be created from @code{gnus-group-archive-directory}. + +@item G k +@kindex G k (Group) +@findex gnus-group-make-kiboze-group +@cindex nnkiboze +Make a kiboze group. You will be prompted for a name, for a regexp to +match groups to be ``included'' in the kiboze group, and a series of +strings to match on headers (@code{gnus-group-make-kiboze-group}). +@xref{Kibozed Groups}. + +@item G D +@kindex G D (Group) +@findex gnus-group-enter-directory +@cindex nneething +Read an arbitrary directory as if it were a newsgroup with the +@code{nneething} backend (@code{gnus-group-enter-directory}). +@xref{Anything Groups}. + +@item G f +@kindex G f (Group) +@findex gnus-group-make-doc-group +@cindex ClariNet Briefs +@cindex nndoc +Make a group based on some file or other +(@code{gnus-group-make-doc-group}). If you give a prefix to this +command, you will be prompted for a file name and a file type. +Currently supported types are @code{babyl}, @code{mbox}, @code{digest}, +@code{mmdf}, @code{news}, @code{rnews}, @code{clari-briefs}, +@code{rfc934}, @code{rfc822-forward}, and @code{forward}. If you run +this command without a prefix, Gnus will guess at the file type. +@xref{Document Groups}. + +@item G w +@kindex G w (Group) +@findex gnus-group-make-web-group +@cindex DejaNews +@cindex Alta Vista +@cindex InReference +@cindex nnweb +Make an ephemeral group based on a web search +(@code{gnus-group-make-web-group}). If you give a prefix to this +command, make a solid group instead. You will be prompted for the +search engine type and the search string. Valid search engine types +include @code{dejanews}, @code{altavista} and @code{reference}. +@xref{Web Searches}. + +@item G DEL +@kindex G DEL (Group) +@findex gnus-group-delete-group +This function will delete the current group +(@code{gnus-group-delete-group}). If given a prefix, this function will +actually delete all the articles in the group, and forcibly remove the +group itself from the face of the Earth. Use a prefix only if you are +absolutely sure of what you are doing. This command can't be used on +read-only groups (like @code{nntp} group), though. + +@item G V +@kindex G V (Group) +@findex gnus-group-make-empty-virtual +Make a new, fresh, empty @code{nnvirtual} group +(@code{gnus-group-make-empty-virtual}). @xref{Virtual Groups}. + +@item G v +@kindex G v (Group) +@findex gnus-group-add-to-virtual +Add the current group to an @code{nnvirtual} group +(@code{gnus-group-add-to-virtual}). Uses the process/prefix convention. +@end table + +@xref{Select Methods} for more information on the various select +methods. + +@vindex gnus-activate-foreign-newsgroups +If @code{gnus-activate-foreign-newsgroups} is a positive number, +Gnus will check all foreign groups with this level or lower at startup. +This might take quite a while, especially if you subscribe to lots of +groups from different @sc{nntp} servers. + + +@node Group Parameters +@section Group Parameters +@cindex group parameters + +The group parameters store information local to a particular group: + +@table @code +@item to-address +@cindex to-address +If the group parameter list contains an element that looks like +@code{(to-address . "some@@where.com")}, that address will be used by +the backend when doing followups and posts. This is primarily useful in +mail groups that represent closed mailing lists---mailing lists where +it's expected that everybody that writes to the mailing list is +subscribed to it. Since using this parameter ensures that the mail only +goes to the mailing list itself, it means that members won't receive two +copies of your followups. + +Using @code{to-address} will actually work whether the group is foreign +or not. Let's say there's a group on the server that is called +@samp{fa.4ad-l}. This is a real newsgroup, but the server has gotten +the articles from a mail-to-news gateway. Posting directly to this +group is therefore impossible---you have to send mail to the mailing +list address instead. + +@item to-list +@cindex to-list +If the group parameter list has an element that looks like +@code{(to-list . "some@@where.com")}, that address will be used when +doing a @kbd{a} in that group. It is totally ignored when doing a +followup---except that if it is present in a news group, you'll get mail +group semantics when doing @kbd{f}. + +If you do an @kbd{a} command in a mail group and you don't have a +@code{to-list} group parameter, one will be added automatically upon +sending the message. + +@item visible +@cindex visible +If the group parameter list has the element @code{(visible . t)}, +that group will always be visible in the Group buffer, regardless +of whether it has any unread articles. + +@item broken-reply-to +@cindex broken-reply-to +Elements like @code{(broken-reply-to . t)} signals that @code{Reply-To} +headers in this group are to be ignored. This can be useful if you're +reading a mailing list group where the listserv has inserted +@code{Reply-To} headers that point back to the listserv itself. This is +broken behavior. So there! + +@item to-group +@cindex to-group +Elements like @code{(to-group . "some.group.name")} means that all +posts in that group will be sent to @code{some.group.name}. + +@item newsgroup +@cindex newsgroup +If this symbol is present in the group parameter list, Gnus will treat +all responses as if they were responses to news articles. This can be +useful if you have a mail group that's really a mirror of a news group. + +@item gcc-self +@cindex gcc-self +If this symbol is present in the group parameter list and set to +@code{t}, newly composed messages will be @code{Gcc}'d to the current +group. If it is present and set to @code{none}, no @code{Gcc:} header +will be generated, if it is present and a string, this string will be +inserted literally as a @code{gcc} header (this symbol takes precedence +over any default @code{Gcc} rules as described later). @xref{Archived +Messages} + +@item auto-expire +@cindex auto-expire +If the group parameter has an element that looks like @code{(auto-expire +. t)}, all articles read will be marked as expirable. For an +alternative approach, @pxref{Expiring Mail}. + +@item total-expire +@cindex total-expire +If the group parameter has an element that looks like +@code{(total-expire . t)}, all read articles will be put through the +expiry process, even if they are not marked as expirable. Use with +caution. Unread, ticked and dormant articles are not eligible for +expiry. + +@item expiry-wait +@cindex expiry-wait +@vindex nnmail-expiry-wait-function +If the group parameter has an element that looks like @code{(expiry-wait +. 10)}, this value will override any @code{nnmail-expiry-wait} and +@code{nnmail-expiry-wait-function} when expiring expirable messages. +The value can either be a number of days (not necessarily an integer) or +the symbols @code{never} or @code{immediate}. + +@item score-file +@cindex score file group parameter +Elements that look like @code{(score-file . "file")} will make +@file{file} into the current adaptive score file for the group in +question. All adaptive score entries will be put into this file. + +@item adapt-file +@cindex adapt file group parameter +Elements that look like @code{(adapt-file . "file")} will make +@file{file} into the current adaptive file for the group in question. +All adaptive score entries will be put into this file. + +@item admin-address +When unsubscribing from a mailing list you should never send the +unsubscription notice to the mailing list itself. Instead, you'd send +messages to the administrative address. This parameter allows you to +put the admin address somewhere convenient. + +@item display +Elements that look like @code{(display . MODE)} say which articles to +display on entering the group. Valid values are: + +@table @code +@item all +Display all articles, both read and unread. + +@item default +Display the default visible articles, which normally includes unread and +ticked articles. +@end table + +@item comment +Elements that look like @code{(comment . "This is a comment")} +are arbitrary comments on the group. They are currently ignored by +Gnus, but provide a place for you to store information on particular +groups. + +@item @var{(variable form)} +You can use the group parameters to set variables local to the group you +are entering. If you want to turn threading off in @samp{news.answers}, +you could put @code{(gnus-show-threads nil)} in the group parameters of +that group. @code{gnus-show-threads} will be made into a local variable +in the summary buffer you enter, and the form @code{nil} will be +@code{eval}ed there. + +This can also be used as a group-specific hook function, if you'd like. +If you want to hear a beep when you enter a group, you could put +something like @code{(dummy-variable (ding))} in the parameters of that +group. @code{dummy-variable} will be set to the result of the +@code{(ding)} form, but who cares? + +@end table + +Use the @kbd{G p} command to edit group parameters of a group. + +@pxref{Topic Parameters}. + +Here's an example group parameter list: + +@example +((to-address . "ding@@gnus.org") + (auto-expiry . t)) +@end example + + +@node Listing Groups +@section Listing Groups +@cindex group listing + +These commands all list various slices of the groups available. + +@table @kbd + +@item l +@itemx A s +@kindex A s (Group) +@kindex l (Group) +@findex gnus-group-list-groups +List all groups that have unread articles +(@code{gnus-group-list-groups}). If the numeric prefix is used, this +command will list only groups of level ARG and lower. By default, it +only lists groups of level five (i. e., +@code{gnus-group-default-list-level}) or lower (i.e., just subscribed +groups). + +@item L +@itemx A u +@kindex A u (Group) +@kindex L (Group) +@findex gnus-group-list-all-groups +List all groups, whether they have unread articles or not +(@code{gnus-group-list-all-groups}). If the numeric prefix is used, +this command will list only groups of level ARG and lower. By default, +it lists groups of level seven or lower (i.e., just subscribed and +unsubscribed groups). + +@item A l +@kindex A l (Group) +@findex gnus-group-list-level +List all unread groups on a specific level +(@code{gnus-group-list-level}). If given a prefix, also list the groups +with no unread articles. + +@item A k +@kindex A k (Group) +@findex gnus-group-list-killed +List all killed groups (@code{gnus-group-list-killed}). If given a +prefix argument, really list all groups that are available, but aren't +currently (un)subscribed. This could entail reading the active file +from the server. + +@item A z +@kindex A z (Group) +@findex gnus-group-list-zombies +List all zombie groups (@code{gnus-group-list-zombies}). + +@item A m +@kindex A m (Group) +@findex gnus-group-list-matching +List all unread, subscribed groups with names that match a regexp +(@code{gnus-group-list-matching}). + +@item A M +@kindex A M (Group) +@findex gnus-group-list-all-matching +List groups that match a regexp (@code{gnus-group-list-all-matching}). + +@item A A +@kindex A A (Group) +@findex gnus-group-list-active +List absolutely all groups in the active file(s) of the +server(s) you are connected to (@code{gnus-group-list-active}). This +might very well take quite a while. It might actually be a better idea +to do a @kbd{A M} to list all matching, and just give @samp{.} as the +thing to match on. Also note that this command may list groups that +don't exist (yet)---these will be listed as if they were killed groups. +Take the output with some grains of salt. + +@item A a +@kindex A a (Group) +@findex gnus-group-apropos +List all groups that have names that match a regexp +(@code{gnus-group-apropos}). + +@item A d +@kindex A d (Group) +@findex gnus-group-description-apropos +List all groups that have names or descriptions that match a regexp +(@code{gnus-group-description-apropos}). + +@end table + +@vindex gnus-permanently-visible-groups +@cindex visible group parameter +Groups that match the @code{gnus-permanently-visible-groups} regexp will +always be shown, whether they have unread articles or not. You can also +add the @code{visible} element to the group parameters in question to +get the same effect. + +@vindex gnus-list-groups-with-ticked-articles +Groups that have just ticked articles in it are normally listed in the +group buffer. If @code{gnus-list-groups-with-ticked-articles} is +@code{nil}, these groups will be treated just like totally empty +groups. It is @code{t} by default. + + +@node Sorting Groups +@section Sorting Groups +@cindex sorting groups + +@kindex C-c C-s (Group) +@findex gnus-group-sort-groups +@vindex gnus-group-sort-function +The @kbd{C-c C-s} (@code{gnus-group-sort-groups}) command sorts the +group buffer according to the function(s) given by the +@code{gnus-group-sort-function} variable. Available sorting functions +include: + +@table @code + +@item gnus-group-sort-by-alphabet +@findex gnus-group-sort-by-alphabet +Sort the group names alphabetically. This is the default. + +@item gnus-group-sort-by-real-name +@findex gnus-group-sort-by-real-name +Sort the group alphabetically on the real (unprefixed) group names. + +@item gnus-group-sort-by-level +@findex gnus-group-sort-by-level +Sort by group level. + +@item gnus-group-sort-by-score +@findex gnus-group-sort-by-score +Sort by group score. + +@item gnus-group-sort-by-rank +@findex gnus-group-sort-by-rank +Sort by group score and then the group level. The level and the score +are, when taken together, the group's @dfn{rank}. + +@item gnus-group-sort-by-unread +@findex gnus-group-sort-by-unread +Sort by number of unread articles. + +@item gnus-group-sort-by-method +@findex gnus-group-sort-by-method +Sort alphabetically on the select method. + + +@end table + +@code{gnus-group-sort-function} can also be a list of sorting +functions. In that case, the most significant sort key function must be +the last one. + + +There are also a number of commands for sorting directly according to +some sorting criteria: + +@table @kbd +@item G S a +@kindex G S a (Group) +@findex gnus-group-sort-groups-by-alphabet +Sort the group buffer alphabetically by group name +(@code{gnus-group-sort-groups-by-alphabet}). + +@item G S u +@kindex G S u (Group) +@findex gnus-group-sort-groups-by-unread +Sort the group buffer by the number of unread articles +(@code{gnus-group-sort-groups-by-unread}). + +@item G S l +@kindex G S l (Group) +@findex gnus-group-sort-groups-by-level +Sort the group buffer by group level +(@code{gnus-group-sort-groups-by-level}). + +@item G S v +@kindex G S v (Group) +@findex gnus-group-sort-groups-by-score +Sort the group buffer by group score +(@code{gnus-group-sort-groups-by-score}). + +@item G S r +@kindex G S r (Group) +@findex gnus-group-sort-groups-by-rank +Sort the group buffer by group rank +(@code{gnus-group-sort-groups-by-rank}). + +@item G S m +@kindex G S m (Group) +@findex gnus-group-sort-groups-by-method +Sort the group buffer alphabetically by backend name +(@code{gnus-group-sort-groups-by-method}). + +@end table + +When given a prefix, all these commands will sort in reverse order. + +You can also sort a subset of the groups: + +@table @kbd +@item G P a +@kindex G P a (Group) +@findex gnus-group-sort-selected-groups-by-alphabet +Sort the process/prefixed groups in the group buffer alphabetically by +group name (@code{gnus-group-sort-selected-groups-by-alphabet}). + +@item G P u +@kindex G P u (Group) +@findex gnus-group-sort-selected-groups-by-unread +Sort the process/prefixed groups in the group buffer by the number of +unread articles (@code{gnus-group-sort-selected-groups-by-unread}). + +@item G P l +@kindex G P l (Group) +@findex gnus-group-sort-selected-groups-by-level +Sort the process/prefixed groups in the group buffer by group level +(@code{gnus-group-sort-selected-groups-by-level}). + +@item G P v +@kindex G P v (Group) +@findex gnus-group-sort-selected-groups-by-score +Sort the process/prefixed groups in the group buffer by group score +(@code{gnus-group-sort-selected-groups-by-score}). + +@item G P r +@kindex G P r (Group) +@findex gnus-group-sort-selected-groups-by-rank +Sort the process/prefixed groups in the group buffer by group rank +(@code{gnus-group-sort-selected-groups-by-rank}). + +@item G P m +@kindex G P m (Group) +@findex gnus-group-sort-selected-groups-by-method +Sort the process/prefixed groups in the group buffer alphabetically by +backend name (@code{gnus-group-sort-selected-groups-by-method}). + +@end table + + + +@node Group Maintenance +@section Group Maintenance +@cindex bogus groups + +@table @kbd +@item b +@kindex b (Group) +@findex gnus-group-check-bogus-groups +Find bogus groups and delete them +(@code{gnus-group-check-bogus-groups}). + +@item F +@kindex F (Group) +@findex gnus-group-find-new-groups +Find new groups and process them (@code{gnus-group-find-new-groups}). +If given a prefix, use the @code{ask-server} method to query the server +for new groups. + +@item C-c C-x +@kindex C-c C-x (Group) +@findex gnus-group-expire-articles +Run all expirable articles in the current group through the expiry +process (if any) (@code{gnus-group-expire-articles}). + +@item C-c M-C-x +@kindex C-c M-C-x (Group) +@findex gnus-group-expire-all-groups +Run all articles in all groups through the expiry process +(@code{gnus-group-expire-all-groups}). + +@end table + + +@node Browse Foreign Server +@section Browse Foreign Server +@cindex foreign servers +@cindex browsing servers + +@table @kbd +@item B +@kindex B (Group) +@findex gnus-group-browse-foreign-server +You will be queried for a select method and a server name. Gnus will +then attempt to contact this server and let you browse the groups there +(@code{gnus-group-browse-foreign-server}). +@end table + +@findex gnus-browse-mode +A new buffer with a list of available groups will appear. This buffer +will use the @code{gnus-browse-mode}. This buffer looks a bit (well, +a lot) like a normal group buffer. + +Here's a list of keystrokes available in the browse mode: + +@table @kbd +@item n +@kindex n (Browse) +@findex gnus-group-next-group +Go to the next group (@code{gnus-group-next-group}). + +@item p +@kindex p (Browse) +@findex gnus-group-prev-group +Go to the previous group (@code{gnus-group-prev-group}). + +@item SPACE +@kindex SPACE (Browse) +@findex gnus-browse-read-group +Enter the current group and display the first article +(@code{gnus-browse-read-group}). + +@item RET +@kindex RET (Browse) +@findex gnus-browse-select-group +Enter the current group (@code{gnus-browse-select-group}). + +@item u +@kindex u (Browse) +@findex gnus-browse-unsubscribe-current-group +Unsubscribe to the current group, or, as will be the case here, +subscribe to it (@code{gnus-browse-unsubscribe-current-group}). + +@item l +@itemx q +@kindex q (Browse) +@kindex l (Browse) +@findex gnus-browse-exit +Exit browse mode (@code{gnus-browse-exit}). + +@item ? +@kindex ? (Browse) +@findex gnus-browse-describe-briefly +Describe browse mode briefly (well, there's not much to describe, is +there) (@code{gnus-browse-describe-briefly}). +@end table + + +@node Exiting Gnus +@section Exiting Gnus +@cindex exiting Gnus + +Yes, Gnus is ex(c)iting. + +@table @kbd +@item z +@kindex z (Group) +@findex gnus-group-suspend +Suspend Gnus (@code{gnus-group-suspend}). This doesn't really exit Gnus, +but it kills all buffers except the Group buffer. I'm not sure why this +is a gain, but then who am I to judge? + +@item q +@kindex q (Group) +@findex gnus-group-exit +@c @icon{gnus-group-exit} +Quit Gnus (@code{gnus-group-exit}). + +@item Q +@kindex Q (Group) +@findex gnus-group-quit +Quit Gnus without saving the @file{.newsrc} files (@code{gnus-group-quit}). +The dribble file will be saved, though (@pxref{Auto Save}). +@end table + +@vindex gnus-exit-gnus-hook +@vindex gnus-suspend-gnus-hook +@code{gnus-suspend-gnus-hook} is called when you suspend Gnus and +@code{gnus-exit-gnus-hook} is called when you quit Gnus, while +@code{gnus-after-exiting-gnus-hook} is called as the final item when +exiting Gnus. + +@findex gnus-unload +@cindex unloading +If you wish to completely unload Gnus and all its adherents, you can use +the @code{gnus-unload} command. This command is also very handy when +trying to customize meta-variables. + +Note: + +@quotation +Miss Lisa Cannifax, while sitting in English class, felt her feet go +numbly heavy and herself fall into a hazy trance as the boy sitting +behind her drew repeated lines with his pencil across the back of her +plastic chair. +@end quotation + + +@node Group Topics +@section Group Topics +@cindex topics + +If you read lots and lots of groups, it might be convenient to group +them hierarchically according to topics. You put your Emacs groups over +here, your sex groups over there, and the rest (what, two groups or so?) +you put in some misc section that you never bother with anyway. You can +even group the Emacs sex groups as a sub-topic to either the Emacs +groups or the sex groups---or both! Go wild! + +@iftex +@iflatex +\gnusfigure{Group Topics}{400}{ +\put(75,50){\epsfig{figure=tmp/group-topic.ps,height=9cm}} +} +@end iflatex +@end iftex + +Here's an example: + +@example +Gnus + Emacs -- I wuw it! + 3: comp.emacs + 2: alt.religion.emacs + Naughty Emacs + 452: alt.sex.emacs + 0: comp.talk.emacs.recovery + Misc + 8: comp.binaries.fractals + 13: comp.sources.unix +@end example + +@findex gnus-topic-mode +@kindex t (Group) +To get this @emph{fab} functionality you simply turn on (ooh!) the +@code{gnus-topic} minor mode---type @kbd{t} in the group buffer. (This +is a toggling command.) + +Go ahead, just try it. I'll still be here when you get back. La de +dum... Nice tune, that... la la la... What, you're back? Yes, and now +press @kbd{l}. There. All your groups are now listed under +@samp{misc}. Doesn't that make you feel all warm and fuzzy? Hot and +bothered? + +If you want this permanently enabled, you should add that minor mode to +the hook for the group mode: + +@lisp +(add-hook 'gnus-group-mode-hook 'gnus-topic-mode) +@end lisp + +@menu +* Topic Variables:: How to customize the topics the Lisp Way. +* Topic Commands:: Interactive E-Z commands. +* Topic Sorting:: Sorting each topic individually. +* Topic Topology:: A map of the world. +* Topic Parameters:: Parameters that apply to all groups in a topic. +@end menu + + +@node Topic Variables +@subsection Topic Variables +@cindex topic variables + +Now, if you select a topic, it will fold/unfold that topic, which is +really neat, I think. + +@vindex gnus-topic-line-format +The topic lines themselves are created according to the +@code{gnus-topic-line-format} variable (@pxref{Formatting Variables}). +Valid elements are: + +@table @samp +@item i +Indentation. +@item n +Topic name. +@item v +Visibility. +@item l +Level. +@item g +Number of groups in the topic. +@item a +Number of unread articles in the topic. +@item A +Number of unread articles in the topic and all its subtopics. +@end table + +@vindex gnus-topic-indent-level +Each sub-topic (and the groups in the sub-topics) will be indented with +@code{gnus-topic-indent-level} times the topic level number of spaces. +The default is 2. + +@vindex gnus-topic-mode-hook +@code{gnus-topic-mode-hook} is called in topic minor mode buffers. + +@vindex gnus-topic-display-empty-topics +The @code{gnus-topic-display-empty-topics} says whether to display even +topics that have no unread articles in them. The default is @code{t}. + + +@node Topic Commands +@subsection Topic Commands +@cindex topic commands + +When the topic minor mode is turned on, a new @kbd{T} submap will be +available. In addition, a few of the standard keys change their +definitions slightly. + +@table @kbd + +@item T n +@kindex T n (Topic) +@findex gnus-topic-create-topic +Prompt for a new topic name and create it +(@code{gnus-topic-create-topic}). + +@item T m +@kindex T m (Topic) +@findex gnus-topic-move-group +Move the current group to some other topic +(@code{gnus-topic-move-group}). This command uses the process/prefix +convention (@pxref{Process/Prefix}). + +@item T c +@kindex T c (Topic) +@findex gnus-topic-copy-group +Copy the current group to some other topic +(@code{gnus-topic-copy-group}). This command uses the process/prefix +convention (@pxref{Process/Prefix}). + +@item T D +@kindex T D (Topic) +@findex gnus-topic-remove-group +Remove a group from the current topic (@code{gnus-topic-remove-group}). +This command uses the process/prefix convention +(@pxref{Process/Prefix}). + +@item T M +@kindex T M (Topic) +@findex gnus-topic-move-matching +Move all groups that match some regular expression to a topic +(@code{gnus-topic-move-matching}). + +@item T C +@kindex T C (Topic) +@findex gnus-topic-copy-matching +Copy all groups that match some regular expression to a topic +(@code{gnus-topic-copy-matching}). + +@item T h +@kindex T h (Topic) +@findex gnus-topic-toggle-display-empty-topics +Toggle hiding empty topics +(@code{gnus-topic-toggle-display-empty-topics}). + +@item T # +@kindex T # (Topic) +@findex gnus-topic-mark-topic +Mark all groups in the current topic with the process mark +(@code{gnus-topic-mark-topic}). + +@item T M-# +@kindex T M-# (Topic) +@findex gnus-topic-unmark-topic +Remove the process mark from all groups in the current topic +(@code{gnus-topic-unmark-topic}). + +@item RET +@kindex RET (Topic) +@findex gnus-topic-select-group +@itemx SPACE +Either select a group or fold a topic (@code{gnus-topic-select-group}). +When you perform this command on a group, you'll enter the group, as +usual. When done on a topic line, the topic will be folded (if it was +visible) or unfolded (if it was folded already). So it's basically a +toggling command on topics. In addition, if you give a numerical +prefix, group on that level (and lower) will be displayed. + +@item T TAB +@kindex T TAB (Topic) +@findex gnus-topic-indent +``Indent'' the current topic so that it becomes a sub-topic of the +previous topic (@code{gnus-topic-indent}). If given a prefix, +``un-indent'' the topic instead. + +@item C-k +@kindex C-k (Topic) +@findex gnus-topic-kill-group +Kill a group or topic (@code{gnus-topic-kill-group}). All groups in the +topic will be removed along with the topic. + +@item C-y +@kindex C-y (Topic) +@findex gnus-topic-yank-group +Yank the previously killed group or topic +(@code{gnus-topic-yank-group}). Note that all topics will be yanked +before all groups. + +@item T r +@kindex T r (Topic) +@findex gnus-topic-rename +Rename a topic (@code{gnus-topic-rename}). + +@item T DEL +@kindex T DEL (Topic) +@findex gnus-topic-delete +Delete an empty topic (@code{gnus-topic-delete}). + +@item A T +@kindex A T (Topic) +@findex gnus-topic-list-active +List all groups that Gnus knows about in a topics-ified way +(@code{gnus-topic-list-active}). + +@item G p +@kindex G p (Topic) +@findex gnus-topic-edit-parameters +@cindex group parameters +@cindex topic parameters +@cindex parameters +Edit the topic parameters (@code{gnus-topic-edit-parameters}). +@xref{Topic Parameters}. + +@end table + + +@node Topic Sorting +@subsection Topic Sorting +@cindex topic sorting + +You can sort the groups in each topic individually with the following +commands: + + +@table @kbd +@item T S a +@kindex T S a (Topic) +@findex gnus-topic-sort-groups-by-alphabet +Sort the current topic alphabetically by group name +(@code{gnus-topic-sort-groups-by-alphabet}). + +@item T S u +@kindex T S u (Topic) +@findex gnus-topic-sort-groups-by-unread +Sort the current topic by the number of unread articles +(@code{gnus-topic-sort-groups-by-unread}). + +@item T S l +@kindex T S l (Topic) +@findex gnus-topic-sort-groups-by-level +Sort the current topic by group level +(@code{gnus-topic-sort-groups-by-level}). + +@item T S v +@kindex T S v (Topic) +@findex gnus-topic-sort-groups-by-score +Sort the current topic by group score +(@code{gnus-topic-sort-groups-by-score}). + +@item T S r +@kindex T S r (Topic) +@findex gnus-topic-sort-groups-by-rank +Sort the current topic by group rank +(@code{gnus-topic-sort-groups-by-rank}). + +@item T S m +@kindex T S m (Topic) +@findex gnus-topic-sort-groups-by-method +Sort the current topic alphabetically by backend name +(@code{gnus-topic-sort-groups-by-method}). + +@end table + +@xref{Sorting Groups} for more information about group sorting. + + +@node Topic Topology +@subsection Topic Topology +@cindex topic topology +@cindex topology + +So, let's have a look at an example group buffer: + +@example +Gnus + Emacs -- I wuw it! + 3: comp.emacs + 2: alt.religion.emacs + Naughty Emacs + 452: alt.sex.emacs + 0: comp.talk.emacs.recovery + Misc + 8: comp.binaries.fractals + 13: comp.sources.unix +@end example + +So, here we have one top-level topic (@samp{Gnus}), two topics under +that, and one sub-topic under one of the sub-topics. (There is always +just one (1) top-level topic). This topology can be expressed as +follows: + +@lisp +(("Gnus" visible) + (("Emacs -- I wuw it!" visible) + (("Naughty Emacs" visible))) + (("Misc" visible))) +@end lisp + +@vindex gnus-topic-topology +This is in fact how the variable @code{gnus-topic-topology} would look +for the display above. That variable is saved in the @file{.newsrc.eld} +file, and shouldn't be messed with manually---unless you really want +to. Since this variable is read from the @file{.newsrc.eld} file, +setting it in any other startup files will have no effect. + +This topology shows what topics are sub-topics of what topics (right), +and which topics are visible. Two settings are currently +allowed---@code{visible} and @code{invisible}. + + +@node Topic Parameters +@subsection Topic Parameters +@cindex topic parameters + +All groups in a topic will inherit group parameters from the parent (and +ancestor) topic parameters. All valid group parameters are valid topic +parameters (@pxref{Group Parameters}). + +Group parameters (of course) override topic parameters, and topic +parameters in sub-topics override topic parameters in super-topics. You +know. Normal inheritance rules. (@dfn{Rules} is here a noun, not a +verb, although you may feel free to disagree with me here.) + +@example +Gnus + Emacs + 3: comp.emacs + 2: alt.religion.emacs + 452: alt.sex.emacs + Relief + 452: alt.sex.emacs + 0: comp.talk.emacs.recovery + Misc + 8: comp.binaries.fractals + 13: comp.sources.unix + 452: alt.sex.emacs +@end example + +The @samp{Emacs} topic has the topic parameter @code{(score-file +. "emacs.SCORE")}; the @samp{Relief} topic has the topic parameter +@code{(score-file . "relief.SCORE")}; and the @samp{Misc} topic has the +topic parameter @code{(score-file . "emacs.SCORE")}. In addition, +@samp{alt.religion.emacs} has the group parameter @code{(score-file +. "religion.SCORE")}. + +Now, when you enter @samp{alt.sex.emacs} in the @samp{Relief} topic, you +will get the @file{relief.SCORE} home score file. If you enter the same +group in the @samp{Emacs} topic, you'll get the @file{emacs.SCORE} home +score file. If you enter the group @samp{alt.religion.emacs}, you'll +get the @file{religion.SCORE} home score file. + +This seems rather simple and self-evident, doesn't it? Well, yes. But +there are some problems, especially with the @code{total-expiry} +parameter. Say you have a mail group in two topics; one with +@code{total-expiry} and one without. What happens when you do @kbd{M-x +gnus-expire-all-expirable-groups}? Gnus has no way of telling which one +of these topics you mean to expire articles from, so anything may +happen. In fact, I hereby declare that it is @dfn{undefined} what +happens. You just have to be careful if you do stuff like that. + + +@node Misc Group Stuff +@section Misc Group Stuff + +@menu +* Scanning New Messages:: Asking Gnus to see whether new messages have arrived. +* Group Information:: Information and help on groups and Gnus. +* Group Timestamp:: Making Gnus keep track of when you last read a group. +* File Commands:: Reading and writing the Gnus files. +@end menu + +@table @kbd + +@item ^ +@kindex ^ (Group) +@findex gnus-group-enter-server-mode +Enter the server buffer (@code{gnus-group-enter-server-mode}). +@xref{The Server Buffer}. + +@item a +@kindex a (Group) +@findex gnus-group-post-news +Post an article to a group (@code{gnus-group-post-news}). If given a +prefix, the current group name will be used as the default. + +@item m +@kindex m (Group) +@findex gnus-group-mail +Mail a message somewhere (@code{gnus-group-mail}). + +@end table + +Variables for the group buffer: + +@table @code + +@item gnus-group-mode-hook +@vindex gnus-group-mode-hook +is called after the group buffer has been +created. + +@item gnus-group-prepare-hook +@vindex gnus-group-prepare-hook +is called after the group buffer is +generated. It may be used to modify the buffer in some strange, +unnatural way. + +@item gnus-permanently-visible-groups +@vindex gnus-permanently-visible-groups +Groups matching this regexp will always be listed in the group buffer, +whether they are empty or not. + +@end table + + +@node Scanning New Messages +@subsection Scanning New Messages +@cindex new messages +@cindex scanning new news + +@table @kbd + +@item g +@kindex g (Group) +@findex gnus-group-get-new-news +@c @icon{gnus-group-get-new-news} +Check the server(s) for new articles. If the numerical prefix is used, +this command will check only groups of level @var{arg} and lower +(@code{gnus-group-get-new-news}). If given a non-numerical prefix, this +command will force a total re-reading of the active file(s) from the +backend(s). + +@item M-g +@kindex M-g (Group) +@findex gnus-group-get-new-news-this-group +@vindex gnus-goto-next-group-when-activating +@c @icon{gnus-group-get-new-news-this-group} +Check whether new articles have arrived in the current group +(@code{gnus-group-get-new-news-this-group}). +@code{gnus-goto-next-group-when-activating} says whether this command is +to move point to the next group or not. It is @code{t} by default. + +@findex gnus-activate-all-groups +@cindex activating groups +@item C-c M-g +@kindex C-c M-g (Group) +Activate absolutely all groups (@code{gnus-activate-all-groups}). + +@item R +@kindex R (Group) +@cindex restarting +@findex gnus-group-restart +Restart Gnus (@code{gnus-group-restart}). This saves the @file{.newsrc} +file(s), closes the connection to all servers, clears up all run-time +Gnus variables, and then starts Gnus all over again. + +@end table + +@vindex gnus-get-new-news-hook +@code{gnus-get-new-news-hook} is run just before checking for new news. + +@vindex gnus-after-getting-new-news-hook +@code{gnus-after-getting-new-news-hook} is run after checking for new +news. + + +@node Group Information +@subsection Group Information +@cindex group information +@cindex information on groups + +@table @kbd + + +@item H f +@kindex H f (Group) +@findex gnus-group-fetch-faq +@vindex gnus-group-faq-directory +@cindex FAQ +@cindex ange-ftp +Try to fetch the FAQ for the current group +(@code{gnus-group-fetch-faq}). Gnus will try to get the FAQ from +@code{gnus-group-faq-directory}, which is usually a directory on a +remote machine. This variable can also be a list of directories. In +that case, giving a prefix to this command will allow you to choose +between the various sites. @code{ange-ftp} (or @code{efs}) will be used +for fetching the file. + +If fetching from the first site is unsuccessful, Gnus will attempt to go +through @code{gnus-group-faq-directory} and try to open them one by one. + +@item H d +@itemx C-c C-d +@c @icon{gnus-group-describe-group} +@kindex H d (Group) +@kindex C-c C-d (Group) +@cindex describing groups +@cindex group description +@findex gnus-group-describe-group +Describe the current group (@code{gnus-group-describe-group}). If given +a prefix, force Gnus to re-read the description from the server. + +@item M-d +@kindex M-d (Group) +@findex gnus-group-describe-all-groups +Describe all groups (@code{gnus-group-describe-all-groups}). If given a +prefix, force Gnus to re-read the description file from the server. + +@item H v +@itemx V +@kindex V (Group) +@kindex H v (Group) +@cindex version +@findex gnus-version +Display current Gnus version numbers (@code{gnus-version}). + +@item ? +@kindex ? (Group) +@findex gnus-group-describe-briefly +Give a very short help message (@code{gnus-group-describe-briefly}). + +@item C-c C-i +@kindex C-c C-i (Group) +@cindex info +@cindex manual +@findex gnus-info-find-node +Go to the Gnus info node (@code{gnus-info-find-node}). +@end table + + +@node Group Timestamp +@subsection Group Timestamp +@cindex timestamps +@cindex group timestamps + +It can be convenient to let Gnus keep track of when you last read a +group. To set the ball rolling, you should add +@code{gnus-group-set-timestamp} to @code{gnus-select-group-hook}: + +@lisp +(add-hook 'gnus-select-group-hook 'gnus-group-set-timestamp) +@end lisp + +After doing this, each time you enter a group, it'll be recorded. + +This information can be displayed in various ways---the easiest is to +use the @samp{%d} spec in the group line format: + +@lisp +(setq gnus-group-line-format + "%M\%S\%p\%P\%5y: %(%-40,40g%) %d\n") +@end lisp + +This will result in lines looking like: + +@example +* 0: mail.ding 19961002T012943 + 0: custom 19961002T012713 +@end example + +As you can see, the date is displayed in compact ISO 8601 format. This +may be a bit too much, so to just display the date, you could say +something like: + +@lisp +(setq gnus-group-line-format + "%M\%S\%p\%P\%5y: %(%-40,40g%) %6,6~(cut 2)d\n") +@end lisp + + +@node File Commands +@subsection File Commands +@cindex file commands + +@table @kbd + +@item r +@kindex r (Group) +@findex gnus-group-read-init-file +@vindex gnus-init-file +@cindex reading init file +Re-read the init file (@code{gnus-init-file}, which defaults to +@file{~/.gnus}) (@code{gnus-group-read-init-file}). + +@item s +@kindex s (Group) +@findex gnus-group-save-newsrc +@cindex saving .newsrc +Save the @file{.newsrc.eld} file (and @file{.newsrc} if wanted) +(@code{gnus-group-save-newsrc}). If given a prefix, force saving the +file(s) whether Gnus thinks it is necessary or not. + +@c @item Z +@c @kindex Z (Group) +@c @findex gnus-group-clear-dribble +@c Clear the dribble buffer (@code{gnus-group-clear-dribble}). + +@end table + + +@node The Summary Buffer +@chapter The Summary Buffer +@cindex summary buffer + +A line for each article is displayed in the summary buffer. You can +move around, read articles, post articles and reply to articles. + +The most common way to a summary buffer is to select a group from the +group buffer (@pxref{Selecting a Group}). + +You can have as many summary buffers open as you wish. + +@menu +* Summary Buffer Format:: Deciding how the summary buffer is to look. +* Summary Maneuvering:: Moving around the summary buffer. +* Choosing Articles:: Reading articles. +* Paging the Article:: Scrolling the current article. +* Reply Followup and Post:: Posting articles. +* Canceling and Superseding:: ``Whoops, I shouldn't have called him that.'' +* Marking Articles:: Marking articles as read, expirable, etc. +* Limiting:: You can limit the summary buffer. +* Threading:: How threads are made. +* Sorting:: How articles and threads are sorted. +* Asynchronous Fetching:: Gnus might be able to pre-fetch articles. +* Article Caching:: You may store articles in a cache. +* Persistent Articles:: Making articles expiry-resistant. +* Article Backlog:: Having already read articles hang around. +* Saving Articles:: Ways of customizing article saving. +* Decoding Articles:: Gnus can treat series of (uu)encoded articles. +* Article Treatment:: The article buffer can be mangled at will. +* Article Commands:: Doing various things with the article buffer. +* Summary Sorting:: Sorting the summary buffer in various ways. +* Finding the Parent:: No child support? Get the parent. +* Alternative Approaches:: Reading using non-default summaries. +* Tree Display:: A more visual display of threads. +* Mail Group Commands:: Some commands can only be used in mail groups. +* Various Summary Stuff:: What didn't fit anywhere else. +* Exiting the Summary Buffer:: Returning to the Group buffer. +* Crosspost Handling:: How crossposted articles are dealt with. +* Duplicate Suppression:: An alternative when crosspost handling fails. +@end menu + + +@node Summary Buffer Format +@section Summary Buffer Format +@cindex summary buffer format + +@iftex +@iflatex +\gnusfigure{The Summary Buffer}{180}{ +\put(0,0){\epsfig{figure=tmp/summary.ps,width=7.5cm}} +\put(445,0){\makebox(0,0)[br]{\epsfig{figure=tmp/summary-article.ps,width=7.5cm}}} +} +@end iflatex +@end iftex + +@menu +* Summary Buffer Lines:: You can specify how summary lines should look. +* Summary Buffer Mode Line:: You can say how the mode line should look. +* Summary Highlighting:: Making the summary buffer all pretty and nice. +@end menu + +@findex mail-extract-address-components +@findex gnus-extract-address-components +@vindex gnus-extract-address-components +Gnus will use the value of the @code{gnus-extract-address-components} +variable as a function for getting the name and address parts of a +@code{From} header. Two pre-defined functions exist: +@code{gnus-extract-address-components}, which is the default, quite +fast, and too simplistic solution; and +@code{mail-extract-address-components}, which works very nicely, but is +slower. The default function will return the wrong answer in 5% of the +cases. If this is unacceptable to you, use the other function instead. + +@vindex gnus-summary-same-subject +@code{gnus-summary-same-subject} is a string indicating that the current +article has the same subject as the previous. This string will be used +with those specs that require it. The default is @samp{}. + + +@node Summary Buffer Lines +@subsection Summary Buffer Lines + +@vindex gnus-summary-line-format +You can change the format of the lines in the summary buffer by changing +the @code{gnus-summary-line-format} variable. It works along the same +lines as a normal @code{format} string, with some extensions +(@pxref{Formatting Variables}). + +The default string is @samp{%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n}. + +The following format specification characters are understood: + +@table @samp +@item N +Article number. +@item S +Subject string. +@item s +Subject if the article is the root of the thread or the previous article +had a different subject, @code{gnus-summary-same-subject} otherwise. +(@code{gnus-summary-same-subject} defaults to @samp{}.) +@item F +Full @code{From} header. +@item n +The name (from the @code{From} header). +@item a +The name (from the @code{From} header). This differs from the @code{n} +spec in that it uses the function designated by the +@code{gnus-extract-address-components} variable, which is slower, but +may be more thorough. +@item A +The address (from the @code{From} header). This works the same way as +the @code{a} spec. +@item L +Number of lines in the article. +@item c +Number of characters in the article. +@item I +Indentation based on thread level (@pxref{Customizing Threading}). +@item T +Nothing if the article is a root and lots of spaces if it isn't (it +pushes everything after it off the screen). +@item [ +Opening bracket, which is normally @samp{[}, but can also be @samp{<} +for adopted articles (@pxref{Customizing Threading}). +@item ] +Closing bracket, which is normally @samp{]}, but can also be @samp{>} +for adopted articles. +@item > +One space for each thread level. +@item < +Twenty minus thread level spaces. +@item U +Unread. +@item R +Replied. +@item i +Score as a number (@pxref{Scoring}). +@item z +@vindex gnus-summary-zcore-fuzz +Zcore, @samp{+} if above the default level and @samp{-} if below the +default level. If the difference between +@code{gnus-summary-default-level} and the score is less than +@code{gnus-summary-zcore-fuzz}, this spec will not be used. +@item V +Total thread score. +@item x +@code{Xref}. +@item D +@code{Date}. +@item d +The @code{Date} in @code{DD-MMM} format. +@item o +The @code{Date} in @var{YYYYMMDD}@code{T}@var{HHMMSS} format. +@item M +@code{Message-ID}. +@item r +@code{References}. +@item t +Number of articles in the current sub-thread. Using this spec will slow +down summary buffer generation somewhat. +@item e +An @samp{=} (@code{gnus-not-empty-thread-mark}) will be displayed if the +article has any children. +@item P +The line number. +@item O +Download mark. +@item u +User defined specifier. The next character in the format string should +be a letter. Gnus will call the function +@code{gnus-user-format-function-}@samp{X}, where @samp{X} is the letter +following @samp{%u}. The function will be passed the current header as +argument. The function should return a string, which will be inserted +into the summary just like information from any other summary specifier. +@end table + +The @samp{%U} (status), @samp{%R} (replied) and @samp{%z} (zcore) specs +have to be handled with care. For reasons of efficiency, Gnus will +compute what column these characters will end up in, and ``hard-code'' +that. This means that it is invalid to have these specs after a +variable-length spec. Well, you might not be arrested, but your summary +buffer will look strange, which is bad enough. + +The smart choice is to have these specs as far to the left as possible. +(Isn't that the case with everything, though? But I digress.) + +This restriction may disappear in later versions of Gnus. + + +@node Summary Buffer Mode Line +@subsection Summary Buffer Mode Line + +@vindex gnus-summary-mode-line-format +You can also change the format of the summary mode bar. Set +@code{gnus-summary-mode-line-format} to whatever you like. The default +is @samp{Gnus: %%b [%A] %Z}. + +Here are the elements you can play with: + +@table @samp +@item G +Group name. +@item p +Unprefixed group name. +@item A +Current article number. +@item V +Gnus version. +@item U +Number of unread articles in this group. +@item e +Number of unread articles in this group that aren't displayed in the +summary buffer. +@item Z +A string with the number of unread and unselected articles represented +either as @samp{<%U(+%e) more>} if there are both unread and unselected +articles, and just as @samp{<%U more>} if there are just unread articles +and no unselected ones. +@item g +Shortish group name. For instance, @samp{rec.arts.anime} will be +shortened to @samp{r.a.anime}. +@item S +Subject of the current article. +@item u +User-defined spec (@pxref{User-Defined Specs}). +@item s +Name of the current score file (@pxref{Scoring}). +@item d +Number of dormant articles (@pxref{Unread Articles}). +@item t +Number of ticked articles (@pxref{Unread Articles}). +@item r +Number of articles that have been marked as read in this session. +@item E +Number of articles expunged by the score files. +@end table + + +@node Summary Highlighting +@subsection Summary Highlighting + +@table @code + +@item gnus-visual-mark-article-hook +@vindex gnus-visual-mark-article-hook +This hook is run after selecting an article. It is meant to be used for +highlighting the article in some way. It is not run if +@code{gnus-visual} is @code{nil}. + +@item gnus-summary-update-hook +@vindex gnus-summary-update-hook +This hook is called when a summary line is changed. It is not run if +@code{gnus-visual} is @code{nil}. + +@item gnus-summary-selected-face +@vindex gnus-summary-selected-face +This is the face (or @dfn{font} as some people call it) used to +highlight the current article in the summary buffer. + +@item gnus-summary-highlight +@vindex gnus-summary-highlight +Summary lines are highlighted according to this variable, which is a +list where the elements are of the format @var{(FORM . FACE)}. If you +would, for instance, like ticked articles to be italic and high-scored +articles to be bold, you could set this variable to something like +@lisp +(((eq mark gnus-ticked-mark) . italic) + ((> score default) . bold)) +@end lisp +As you may have guessed, if @var{FORM} returns a non-@code{nil} value, +@var{FACE} will be applied to the line. +@end table + + +@node Summary Maneuvering +@section Summary Maneuvering +@cindex summary movement + +All the straight movement commands understand the numeric prefix and +behave pretty much as you'd expect. + +None of these commands select articles. + +@table @kbd +@item G M-n +@itemx M-n +@kindex M-n (Summary) +@kindex G M-n (Summary) +@findex gnus-summary-next-unread-subject +Go to the next summary line of an unread article +(@code{gnus-summary-next-unread-subject}). + +@item G M-p +@itemx M-p +@kindex M-p (Summary) +@kindex G M-p (Summary) +@findex gnus-summary-prev-unread-subject +Go to the previous summary line of an unread article +(@code{gnus-summary-prev-unread-subject}). + +@item G j +@itemx j +@kindex j (Summary) +@kindex G j (Summary) +@findex gnus-summary-goto-article +Ask for an article number or @code{Message-ID}, and then go to that +article (@code{gnus-summary-goto-article}). + +@item G g +@kindex G g (Summary) +@findex gnus-summary-goto-subject +Ask for an article number and then go to the summary line of that article +without displaying the article (@code{gnus-summary-goto-subject}). +@end table + +If Gnus asks you to press a key to confirm going to the next group, you +can use the @kbd{C-n} and @kbd{C-p} keys to move around the group +buffer, searching for the next group to read without actually returning +to the group buffer. + +Variables related to summary movement: + +@table @code + +@vindex gnus-auto-select-next +@item gnus-auto-select-next +If you issue one of the movement commands (like @kbd{n}) and there are +no more unread articles after the current one, Gnus will offer to go to +the next group. If this variable is @code{t} and the next group is +empty, Gnus will exit summary mode and return to the group buffer. If +this variable is neither @code{t} nor @code{nil}, Gnus will select the +next group, no matter whether it has any unread articles or not. As a +special case, if this variable is @code{quietly}, Gnus will select the +next group without asking for confirmation. If this variable is +@code{almost-quietly}, the same will happen only if you are located on +the last article in the group. Finally, if this variable is +@code{slightly-quietly}, the @kbd{Z n} command will go to the next group +without confirmation. Also @pxref{Group Levels}. + +@item gnus-auto-select-same +@vindex gnus-auto-select-same +If non-@code{nil}, all the movement commands will try to go to the next +article with the same subject as the current. (@dfn{Same} here might +mean @dfn{roughly equal}. See @code{gnus-summary-gather-subject-limit} +for details (@pxref{Customizing Threading}).) This variable is not +particularly useful if you use a threaded display. + +@item gnus-summary-check-current +@vindex gnus-summary-check-current +If non-@code{nil}, all the ``unread'' movement commands will not proceed +to the next (or previous) article if the current article is unread. +Instead, they will choose the current article. + +@item gnus-auto-center-summary +@vindex gnus-auto-center-summary +If non-@code{nil}, Gnus will keep the point in the summary buffer +centered at all times. This makes things quite tidy, but if you have a +slow network connection, or simply do not like this un-Emacsism, you can +set this variable to @code{nil} to get the normal Emacs scrolling +action. This will also inhibit horizontal re-centering of the summary +buffer, which might make it more inconvenient to read extremely long +threads. + +@end table + + +@node Choosing Articles +@section Choosing Articles +@cindex selecting articles + +@menu +* Choosing Commands:: Commands for choosing articles. +* Choosing Variables:: Variables that influence these commands. +@end menu + + +@node Choosing Commands +@subsection Choosing Commands + +None of the following movement commands understand the numeric prefix, +and they all select and display an article. + +@table @kbd +@item SPACE +@kindex SPACE (Summary) +@findex gnus-summary-next-page +Select the current article, or, if that one's read already, the next +unread article (@code{gnus-summary-next-page}). + +@item G n +@itemx n +@kindex n (Summary) +@kindex G n (Summary) +@findex gnus-summary-next-unread-article +@c @icon{gnus-summary-next-unread} +Go to next unread article (@code{gnus-summary-next-unread-article}). + +@item G p +@itemx p +@kindex p (Summary) +@findex gnus-summary-prev-unread-article +@c @icon{gnus-summary-prev-unread} +Go to previous unread article (@code{gnus-summary-prev-unread-article}). + +@item G N +@itemx N +@kindex N (Summary) +@kindex G N (Summary) +@findex gnus-summary-next-article +Go to the next article (@code{gnus-summary-next-article}). + +@item G P +@itemx P +@kindex P (Summary) +@kindex G P (Summary) +@findex gnus-summary-prev-article +Go to the previous article (@code{gnus-summary-prev-article}). + +@item G C-n +@kindex G C-n (Summary) +@findex gnus-summary-next-same-subject +Go to the next article with the same subject +(@code{gnus-summary-next-same-subject}). + +@item G C-p +@kindex G C-p (Summary) +@findex gnus-summary-prev-same-subject +Go to the previous article with the same subject +(@code{gnus-summary-prev-same-subject}). + +@item G f +@itemx . +@kindex G f (Summary) +@kindex . (Summary) +@findex gnus-summary-first-unread-article +Go to the first unread article +(@code{gnus-summary-first-unread-article}). + +@item G b +@itemx , +@kindex G b (Summary) +@kindex , (Summary) +@findex gnus-summary-best-unread-article +Go to the article with the highest score +(@code{gnus-summary-best-unread-article}). + +@item G l +@itemx l +@kindex l (Summary) +@kindex G l (Summary) +@findex gnus-summary-goto-last-article +Go to the previous article read (@code{gnus-summary-goto-last-article}). + +@item G o +@kindex G o (Summary) +@findex gnus-summary-pop-article +@cindex history +@cindex article history +Pop an article off the summary history and go to this article +(@code{gnus-summary-pop-article}). This command differs from the +command above in that you can pop as many previous articles off the +history as you like. For a somewhat related issue (if you use this +command a lot), @pxref{Article Backlog}. +@end table + + +@node Choosing Variables +@subsection Choosing Variables + +Some variables relevant for moving and selecting articles: + +@table @code +@item gnus-auto-extend-newsgroup +@vindex gnus-auto-extend-newsgroup +All the movement commands will try to go to the previous (or next) +article, even if that article isn't displayed in the Summary buffer if +this variable is non-@code{nil}. Gnus will then fetch the article from +the server and display it in the article buffer. + +@item gnus-select-article-hook +@vindex gnus-select-article-hook +This hook is called whenever an article is selected. By default it +exposes any threads hidden under the selected article. + +@item gnus-mark-article-hook +@vindex gnus-mark-article-hook +@findex gnus-summary-mark-unread-as-read +@findex gnus-summary-mark-read-and-unread-as-read +@findex gnus-unread-mark +This hook is called whenever an article is selected. It is intended to +be used for marking articles as read. The default value is +@code{gnus-summary-mark-read-and-unread-as-read}, and will change the +mark of almost any article you read to @code{gnus-unread-mark}. The +only articles not affected by this function are ticked, dormant, and +expirable articles. If you'd instead like to just have unread articles +marked as read, you can use @code{gnus-summary-mark-unread-as-read} +instead. It will leave marks like @code{gnus-low-score-mark}, +@code{gnus-del-mark} (and so on) alone. + +@end table + + +@node Paging the Article +@section Scrolling the Article +@cindex article scrolling + +@table @kbd + +@item SPACE +@kindex SPACE (Summary) +@findex gnus-summary-next-page +Pressing @kbd{SPACE} will scroll the current article forward one page, +or, if you have come to the end of the current article, will choose the +next article (@code{gnus-summary-next-page}). + +@item DEL +@kindex DEL (Summary) +@findex gnus-summary-prev-page +Scroll the current article back one page (@code{gnus-summary-prev-page}). + +@item RET +@kindex RET (Summary) +@findex gnus-summary-scroll-up +Scroll the current article one line forward +(@code{gnus-summary-scroll-up}). + +@item A g +@itemx g +@kindex A g (Summary) +@kindex g (Summary) +@findex gnus-summary-show-article +(Re)fetch the current article (@code{gnus-summary-show-article}). If +given a prefix, fetch the current article, but don't run any of the +article treatment functions. This will give you a ``raw'' article, just +the way it came from the server. + +@item A < +@itemx < +@kindex < (Summary) +@kindex A < (Summary) +@findex gnus-summary-beginning-of-article +Scroll to the beginning of the article +(@code{gnus-summary-beginning-of-article}). + +@item A > +@itemx > +@kindex > (Summary) +@kindex A > (Summary) +@findex gnus-summary-end-of-article +Scroll to the end of the article (@code{gnus-summary-end-of-article}). + +@item A s +@itemx s +@kindex A s (Summary) +@kindex s (Summary) +@findex gnus-summary-isearch-article +Perform an isearch in the article buffer +(@code{gnus-summary-isearch-article}). + +@end table + + +@node Reply Followup and Post +@section Reply, Followup and Post + +@menu +* Summary Mail Commands:: Sending mail. +* Summary Post Commands:: Sending news. +@end menu + + +@node Summary Mail Commands +@subsection Summary Mail Commands +@cindex mail +@cindex composing mail + +Commands for composing a mail message: + +@table @kbd + +@item S r +@itemx r +@kindex S r (Summary) +@kindex r (Summary) +@findex gnus-summary-reply +@c @icon{gnus-summary-mail-reply} +@c @icon{gnus-summary-reply} +Mail a reply to the author of the current article +(@code{gnus-summary-reply}). + +@item S R +@itemx R +@kindex R (Summary) +@kindex S R (Summary) +@findex gnus-summary-reply-with-original +@c @icon{gnus-summary-reply-with-original} +Mail a reply to the author of the current article and include the +original message (@code{gnus-summary-reply-with-original}). This +command uses the process/prefix convention. + +@item S w +@kindex S w (Summary) +@findex gnus-summary-wide-reply +Mail a wide reply to the author of the current article +(@code{gnus-summary-wide-reply}). A @dfn{wide reply} is a reply that +goes out to all people listed in the @code{To}, @code{From} (or +@code{Reply-to}) and @code{Cc} headers. + +@item S W +@kindex S W (Summary) +@findex gnus-summary-wide-reply-with-original +Mail a wide reply to the current article and include the original +message (@code{gnus-summary-reply-with-original}). This command uses +the process/prefix convention. + +@item S o m +@kindex S o m (Summary) +@findex gnus-summary-mail-forward +@c @icon{gnus-summary-mail-forward} +Forward the current article to some other person +(@code{gnus-summary-mail-forward}). If given a prefix, include the full +headers of the forwarded article. + +@item S m +@itemx m +@kindex m (Summary) +@kindex S m (Summary) +@findex gnus-summary-mail-other-window +@c @icon{gnus-summary-mail-originate} +Send a mail to some other person +(@code{gnus-summary-mail-other-window}). + +@item S D b +@kindex S D b (Summary) +@findex gnus-summary-resend-bounced-mail +@cindex bouncing mail +If you have sent a mail, but the mail was bounced back to you for some +reason (wrong address, transient failure), you can use this command to +resend that bounced mail (@code{gnus-summary-resend-bounced-mail}). You +will be popped into a mail buffer where you can edit the headers before +sending the mail off again. If you give a prefix to this command, and +the bounced mail is a reply to some other mail, Gnus will try to fetch +that mail and display it for easy perusal of its headers. This might +very well fail, though. + +@item S D r +@kindex S D r (Summary) +@findex gnus-summary-resend-message +Not to be confused with the previous command, +@code{gnus-summary-resend-message} will prompt you for an address to +send the current message off to, and then send it to that place. The +headers of the message won't be altered---but lots of headers that say +@code{Resent-To}, @code{Resent-From} and so on will be added. This +means that you actually send a mail to someone that has a @code{To} +header that (probably) points to yourself. This will confuse people. +So, natcherly you'll only do that if you're really eVIl. + +This command is mainly used if you have several accounts and want to +ship a mail to a different account of yours. (If you're both +@code{root} and @code{postmaster} and get a mail for @code{postmaster} +to the @code{root} account, you may want to resend it to +@code{postmaster}. Ordnung muß sein! + +This command understands the process/prefix convention +(@pxref{Process/Prefix}). + +@item S O m +@kindex S O m (Summary) +@findex gnus-uu-digest-mail-forward +Digest the current series (@pxref{Decoding Articles}) and forward the +result using mail (@code{gnus-uu-digest-mail-forward}). This command +uses the process/prefix convention (@pxref{Process/Prefix}). + +@item S M-c +@kindex S M-c (Summary) +@findex gnus-summary-mail-crosspost-complaint +@cindex crossposting +@cindex excessive crossposting +Send a complaint about excessive crossposting to the author of the +current article (@code{gnus-summary-mail-crosspost-complaint}). + +@findex gnus-crosspost-complaint +This command is provided as a way to fight back agains the current +crossposting pandemic that's sweeping Usenet. It will compose a reply +using the @code{gnus-crosspost-complaint} variable as a preamble. This +command understands the process/prefix convention +(@pxref{Process/Prefix}) and will prompt you before sending each mail. + +@end table + + +@node Summary Post Commands +@subsection Summary Post Commands +@cindex post +@cindex composing news + +Commands for posting a news article: + +@table @kbd +@item S p +@itemx a +@kindex a (Summary) +@kindex S p (Summary) +@findex gnus-summary-post-news +@c @icon{gnus-summary-post-news} +Post an article to the current group +(@code{gnus-summary-post-news}). + +@item S f +@itemx f +@kindex f (Summary) +@kindex S f (Summary) +@findex gnus-summary-followup +@c @icon{gnus-summary-followup} +Post a followup to the current article (@code{gnus-summary-followup}). + +@item S F +@itemx F +@kindex S F (Summary) +@kindex F (Summary) +@c @icon{gnus-summary-followup-with-original} +@findex gnus-summary-followup-with-original +Post a followup to the current article and include the original message +(@code{gnus-summary-followup-with-original}). This command uses the +process/prefix convention. + +@item S n +@kindex S n (Summary) +@findex gnus-summary-followup-to-mail +Post a followup to the current article via news, even if you got the +message through mail (@code{gnus-summary-followup-to-mail}). + +@item S n +@kindex S n (Summary) +@findex gnus-summary-followup-to-mail +Post a followup to the current article via news, even if you got the +message through mail and include the original message +(@code{gnus-summary-followup-to-mail-with-original}). This command uses +the process/prefix convention. + +@item S o p +@kindex S o p (Summary) +@findex gnus-summary-post-forward +Forward the current article to a newsgroup +(@code{gnus-summary-post-forward}). If given a prefix, include the full +headers of the forwarded article. + +@item S O p +@kindex S O p (Summary) +@findex gnus-uu-digest-post-forward +@cindex digests +@cindex making digests +Digest the current series and forward the result to a newsgroup +(@code{gnus-uu-digest-mail-forward}). This command uses the +process/prefix convention. + +@item S u +@kindex S u (Summary) +@findex gnus-uu-post-news +@c @icon{gnus-uu-post-news} +Uuencode a file, split it into parts, and post it as a series +(@code{gnus-uu-post-news}). (@pxref{Uuencoding and Posting}). +@end table + + +@node Canceling and Superseding +@section Canceling Articles +@cindex canceling articles +@cindex superseding articles + +Have you ever written something, and then decided that you really, +really, really wish you hadn't posted that? + +Well, you can't cancel mail, but you can cancel posts. + +@findex gnus-summary-cancel-article +@kindex C (Summary) +@c @icon{gnus-summary-cancel-article} +Find the article you wish to cancel (you can only cancel your own +articles, so don't try any funny stuff). Then press @kbd{C} or @kbd{S +c} (@code{gnus-summary-cancel-article}). Your article will be +canceled---machines all over the world will be deleting your article. + +Be aware, however, that not all sites honor cancels, so your article may +live on here and there, while most sites will delete the article in +question. + +If you discover that you have made some mistakes and want to do some +corrections, you can post a @dfn{superseding} article that will replace +your original article. + +@findex gnus-summary-supersede-article +@kindex S (Summary) +Go to the original article and press @kbd{S s} +(@code{gnus-summary-supersede-article}). You will be put in a buffer +where you can edit the article all you want before sending it off the +usual way. + +The same goes for superseding as for canceling, only more so: Some +sites do not honor superseding. On those sites, it will appear that you +have posted almost the same article twice. + +If you have just posted the article, and change your mind right away, +there is a trick you can use to cancel/supersede the article without +waiting for the article to appear on your site first. You simply return +to the post buffer (which is called @code{*sent ...*}). There you will +find the article you just posted, with all the headers intact. Change +the @code{Message-ID} header to a @code{Cancel} or @code{Supersedes} +header by substituting one of those words for the word +@code{Message-ID}. Then just press @kbd{C-c C-c} to send the article as +you would do normally. The previous article will be +canceled/superseded. + +Just remember, kids: There is no 'c' in 'supersede'. + + +@node Marking Articles +@section Marking Articles +@cindex article marking +@cindex article ticking +@cindex marks + +There are several marks you can set on an article. + +You have marks that decide the @dfn{readedness} (whoo, neato-keano +neologism ohoy!) of the article. Alphabetic marks generally mean +@dfn{read}, while non-alphabetic characters generally mean @dfn{unread}. + +In addition, you also have marks that do not affect readedness. + +@menu +* Unread Articles:: Marks for unread articles. +* Read Articles:: Marks for read articles. +* Other Marks:: Marks that do not affect readedness. +@end menu + +@ifinfo +There's a plethora of commands for manipulating these marks: +@end ifinfo + +@menu +* Setting Marks:: How to set and remove marks. +* Setting Process Marks:: How to mark articles for later processing. +@end menu + + +@node Unread Articles +@subsection Unread Articles + +The following marks mark articles as (kinda) unread, in one form or +other. + +@table @samp +@item ! +@vindex gnus-ticked-mark +Marked as ticked (@code{gnus-ticked-mark}). + +@dfn{Ticked articles} are articles that will remain visible always. If +you see an article that you find interesting, or you want to put off +reading it, or replying to it, until sometime later, you'd typically +tick it. However, articles can be expired, so if you want to keep an +article forever, you'll have to make it persistent (@pxref{Persistent +Articles}). + +@item ? +@vindex gnus-dormant-mark +Marked as dormant (@code{gnus-dormant-mark}). + +@dfn{Dormant articles} will only appear in the summary buffer if there +are followups to it. If you want to see them even if they don't have +followups, you can use the @kbd{/ D} command (@pxref{Limiting}). + +@item SPACE +@vindex gnus-unread-mark +Markes as unread (@code{gnus-unread-mark}). + +@dfn{Unread articles} are articles that haven't been read at all yet. +@end table + + +@node Read Articles +@subsection Read Articles +@cindex expirable mark + +All the following marks mark articles as read. + +@table @samp + +@item r +@vindex gnus-del-mark +These are articles that the user has marked as read with the @kbd{d} +command manually, more or less (@code{gnus-del-mark}). + +@item R +@vindex gnus-read-mark +Articles that have actually been read (@code{gnus-read-mark}). + +@item O +@vindex gnus-ancient-mark +Articles that were marked as read in previous sessions and are now +@dfn{old} (@code{gnus-ancient-mark}). + +@item K +@vindex gnus-killed-mark +Marked as killed (@code{gnus-killed-mark}). + +@item X +@vindex gnus-kill-file-mark +Marked as killed by kill files (@code{gnus-kill-file-mark}). + +@item Y +@vindex gnus-low-score-mark +Marked as read by having too low a score (@code{gnus-low-score-mark}). + +@item C +@vindex gnus-catchup-mark +Marked as read by a catchup (@code{gnus-catchup-mark}). + +@item G +@vindex gnus-canceled-mark +Canceled article (@code{gnus-canceled-mark}) + +@item F +@vindex gnus-souped-mark +@sc{SOUP}ed article (@code{gnus-souped-mark}). @xref{SOUP}. + +@item Q +@vindex gnus-sparse-mark +Sparsely reffed article (@code{gnus-sparse-mark}). @xref{Customizing +Threading}. + +@item M +@vindex gnus-duplicate-mark +Article marked as read by duplicate suppression +(@code{gnus-duplicated-mark}). @xref{Duplicate Suppression}. + +@end table + +All these marks just mean that the article is marked as read, really. +They are interpreted differently when doing adaptive scoring, though. + +One more special mark, though: + +@table @samp +@item E +@vindex gnus-expirable-mark +Marked as expirable (@code{gnus-expirable-mark}). + +Marking articles as @dfn{expirable} (or have them marked as such +automatically) doesn't make much sense in normal groups---a user doesn't +control expiring of news articles, but in mail groups, for instance, +articles marked as @dfn{expirable} can be deleted by Gnus at +any time. +@end table + + +@node Other Marks +@subsection Other Marks +@cindex process mark +@cindex bookmarks + +There are some marks that have nothing to do with whether the article is +read or not. + +@itemize @bullet + +@item +You can set a bookmark in the current article. Say you are reading a +long thesis on cats' urinary tracts, and have to go home for dinner +before you've finished reading the thesis. You can then set a bookmark +in the article, and Gnus will jump to this bookmark the next time it +encounters the article. @xref{Setting Marks} + +@item +@vindex gnus-replied-mark +All articles that you have replied to or made a followup to (i.e., have +answered) will be marked with an @samp{A} in the second column +(@code{gnus-replied-mark}). + +@item +@vindex gnus-cached-mark +Articles stored in the article cache will be marked with an @samp{*} in +the second column (@code{gnus-cached-mark}). @xref{Article Caching} + +@item +@vindex gnus-saved-mark +Articles ``saved'' (in some manner or other; not necessarily +religiously) are marked with an @samp{S} in the second column +(@code{gnus-saved-mark}). + +@item +@vindex gnus-not-empty-thread-mark +@vindex gnus-empty-thread-mark +If the @samp{%e} spec is used, the presence of threads or not will be +marked with @code{gnus-not-empty-thread-mark} and +@code{gnus-empty-thread-mark} in the third column, respectively. + +@item +@vindex gnus-process-mark +Finally we have the @dfn{process mark} (@code{gnus-process-mark}). A +variety of commands react to the presence of the process mark. For +instance, @kbd{X u} (@code{gnus-uu-decode-uu}) will uudecode and view +all articles that have been marked with the process mark. Articles +marked with the process mark have a @samp{#} in the second column. + +@end itemize + +You might have noticed that most of these ``non-readedness'' marks +appear in the second column by default. So if you have a cached, saved, +replied article that you have process-marked, what will that look like? + +Nothing much. The precedence rules go as follows: process -> cache -> +replied -> saved. So if the article is in the cache and is replied, +you'll only see the cache mark and not the replied mark. + + +@node Setting Marks +@subsection Setting Marks +@cindex setting marks + +All the marking commands understand the numeric prefix. + +@table @kbd +@item M c +@itemx M-u +@kindex M c (Summary) +@kindex M-u (Summary) +@findex gnus-summary-clear-mark-forward +@cindex mark as unread +Clear all readedness-marks from the current article +(@code{gnus-summary-clear-mark-forward}). In other words, mark the +article as unread. + +@item M t +@itemx ! +@kindex ! (Summary) +@kindex M t (Summary) +@findex gnus-summary-tick-article-forward +Tick the current article (@code{gnus-summary-tick-article-forward}). +@xref{Article Caching} + +@item M ? +@itemx ? +@kindex ? (Summary) +@kindex M ? (Summary) +@findex gnus-summary-mark-as-dormant +Mark the current article as dormant +(@code{gnus-summary-mark-as-dormant}). @xref{Article Caching} + +@item M d +@itemx d +@kindex M d (Summary) +@kindex d (Summary) +@findex gnus-summary-mark-as-read-forward +Mark the current article as read +(@code{gnus-summary-mark-as-read-forward}). + +@item D +@kindex D (Summary) +@findex gnus-summary-mark-as-read-backward +Mark the current article as read and move point to the previous line +(@code{gnus-summary-mark-as-read-backward}). + +@item M k +@itemx k +@kindex k (Summary) +@kindex M k (Summary) +@findex gnus-summary-kill-same-subject-and-select +Mark all articles that have the same subject as the current one as read, +and then select the next unread article +(@code{gnus-summary-kill-same-subject-and-select}). + +@item M K +@itemx C-k +@kindex M K (Summary) +@kindex C-k (Summary) +@findex gnus-summary-kill-same-subject +Mark all articles that have the same subject as the current one as read +(@code{gnus-summary-kill-same-subject}). + +@item M C +@kindex M C (Summary) +@findex gnus-summary-catchup +@c @icon{gnus-summary-catchup} +Mark all unread articles as read (@code{gnus-summary-catchup}). + +@item M C-c +@kindex M C-c (Summary) +@findex gnus-summary-catchup-all +Mark all articles in the group as read---even the ticked and dormant +articles (@code{gnus-summary-catchup-all}). + +@item M H +@kindex M H (Summary) +@findex gnus-summary-catchup-to-here +Catchup the current group to point +(@code{gnus-summary-catchup-to-here}). + +@item C-w +@kindex C-w (Summary) +@findex gnus-summary-mark-region-as-read +Mark all articles between point and mark as read +(@code{gnus-summary-mark-region-as-read}). + +@item M V k +@kindex M V k (Summary) +@findex gnus-summary-kill-below +Kill all articles with scores below the default score (or below the +numeric prefix) (@code{gnus-summary-kill-below}). + +@item M e +@itemx E +@kindex M e (Summary) +@kindex E (Summary) +@findex gnus-summary-mark-as-expirable +Mark the current article as expirable +(@code{gnus-summary-mark-as-expirable}). + +@item M b +@kindex M b (Summary) +@findex gnus-summary-set-bookmark +Set a bookmark in the current article +(@code{gnus-summary-set-bookmark}). + +@item M B +@kindex M B (Summary) +@findex gnus-summary-remove-bookmark +Remove the bookmark from the current article +(@code{gnus-summary-remove-bookmark}). + +@item M V c +@kindex M V c (Summary) +@findex gnus-summary-clear-above +Clear all marks from articles with scores over the default score (or +over the numeric prefix) (@code{gnus-summary-clear-above}). + +@item M V u +@kindex M V u (Summary) +@findex gnus-summary-tick-above +Tick all articles with scores over the default score (or over the +numeric prefix) (@code{gnus-summary-tick-above}). + +@item M V m +@kindex M V m (Summary) +@findex gnus-summary-mark-above +Prompt for a mark, and mark all articles with scores over the default +score (or over the numeric prefix) with this mark +(@code{gnus-summary-clear-above}). +@end table + +@vindex gnus-summary-goto-unread +The @code{gnus-summary-goto-unread} variable controls what action should +be taken after setting a mark. If non-@code{nil}, point will move to +the next/previous unread article. If @code{nil}, point will just move +one line up or down. As a special case, if this variable is +@code{never}, all the marking commands as well as other commands (like +@kbd{SPACE}) will move to the next article, whether it is unread or not. +The default is @code{t}. + + +@node Setting Process Marks +@subsection Setting Process Marks +@cindex setting process marks + +@table @kbd + +@item M P p +@itemx # +@kindex # (Summary) +@kindex M P p (Summary) +@findex gnus-summary-mark-as-processable +Mark the current article with the process mark +(@code{gnus-summary-mark-as-processable}). +@findex gnus-summary-unmark-as-processable + +@item M P u +@itemx M-# +@kindex M P u (Summary) +@kindex M-# (Summary) +Remove the process mark, if any, from the current article +(@code{gnus-summary-unmark-as-processable}). + +@item M P U +@kindex M P U (Summary) +@findex gnus-summary-unmark-all-processable +Remove the process mark from all articles +(@code{gnus-summary-unmark-all-processable}). + +@item M P i +@kindex M P i (Summary) +@findex gnus-uu-invert-processable +Invert the list of process marked articles +(@code{gnus-uu-invert-processable}). + +@item M P R +@kindex M P R (Summary) +@findex gnus-uu-mark-by-regexp +Mark articles by a regular expression (@code{gnus-uu-mark-by-regexp}). + +@item M P r +@kindex M P r (Summary) +@findex gnus-uu-mark-region +Mark articles in region (@code{gnus-uu-mark-region}). + +@item M P t +@kindex M P t (Summary) +@findex gnus-uu-mark-thread +Mark all articles in the current (sub)thread +(@code{gnus-uu-mark-thread}). + +@item M P T +@kindex M P T (Summary) +@findex gnus-uu-unmark-thread +Unmark all articles in the current (sub)thread +(@code{gnus-uu-unmark-thread}). + +@item M P v +@kindex M P v (Summary) +@findex gnus-uu-mark-over +Mark all articles that have a score above the prefix argument +(@code{gnus-uu-mark-over}). + +@item M P s +@kindex M P s (Summary) +@findex gnus-uu-mark-series +Mark all articles in the current series (@code{gnus-uu-mark-series}). + +@item M P S +@kindex M P S (Summary) +@findex gnus-uu-mark-sparse +Mark all series that have already had some articles marked +(@code{gnus-uu-mark-sparse}). + +@item M P a +@kindex M P a (Summary) +@findex gnus-uu-mark-all +Mark all articles in series order (@code{gnus-uu-mark-series}). + +@item M P b +@kindex M P b (Summary) +@findex gnus-uu-mark-buffer +Mark all articles in the buffer in the order they appear +(@code{gnus-uu-mark-buffer}). + +@item M P k +@kindex M P k (Summary) +@findex gnus-summary-kill-process-mark +Push the current process mark set onto the stack and unmark all articles +(@code{gnus-summary-kill-process-mark}). + +@item M P y +@kindex M P y (Summary) +@findex gnus-summary-yank-process-mark +Pop the previous process mark set from the stack and restore it +(@code{gnus-summary-yank-process-mark}). + +@item M P w +@kindex M P w (Summary) +@findex gnus-summary-save-process-mark +Push the current process mark set onto the stack +(@code{gnus-summary-save-process-mark}). + +@end table + + +@node Limiting +@section Limiting +@cindex limiting + +It can be convenient to limit the summary buffer to just show some +subset of the articles currently in the group. The effect most limit +commands have is to remove a few (or many) articles from the summary +buffer. + +@table @kbd + +@item / / +@itemx / s +@kindex / / (Summary) +@findex gnus-summary-limit-to-subject +Limit the summary buffer to articles that match some subject +(@code{gnus-summary-limit-to-subject}). + +@item / a +@kindex / a (Summary) +@findex gnus-summary-limit-to-author +Limit the summary buffer to articles that match some author +(@code{gnus-summary-limit-to-author}). + +@item / u +@itemx x +@kindex / u (Summary) +@kindex x (Summary) +@findex gnus-summary-limit-to-unread +Limit the summary buffer to articles not marked as read +(@code{gnus-summary-limit-to-unread}). If given a prefix, limit the +buffer to articles strictly unread. This means that ticked and +dormant articles will also be excluded. + +@item / m +@kindex / m (Summary) +@findex gnus-summary-limit-to-marks +Ask for a mark and then limit to all articles that have not been marked +with that mark (@code{gnus-summary-limit-to-marks}). + +@item / t +@kindex / t (Summary) +@findex gnus-summary-limit-to-age +Ask for a number and then limit the summary buffer to articles older than (or equal to) that number of days +(@code{gnus-summary-limit-to-marks}). If given a prefix, limit to +articles younger than that number of days. + +@item / n +@kindex / n (Summary) +@findex gnus-summary-limit-to-articles +Limit the summary buffer to the current article +(@code{gnus-summary-limit-to-articles}). Uses the process/prefix +convention (@pxref{Process/Prefix}). + +@item / w +@kindex / w (Summary) +@findex gnus-summary-pop-limit +Pop the previous limit off the stack and restore it +(@code{gnus-summary-pop-limit}). If given a prefix, pop all limits off +the stack. + +@item / v +@kindex / v (Summary) +@findex gnus-summary-limit-to-score +Limit the summary buffer to articles that have a score at or above some +score (@code{gnus-summary-limit-to-score}). + +@item / E +@itemx M S +@kindex M S (Summary) +@kindex / E (Summary) +@findex gnus-summary-limit-include-expunged +Display all expunged articles +(@code{gnus-summary-limit-include-expunged}). + +@item / D +@kindex / D (Summary) +@findex gnus-summary-limit-include-dormant +Display all dormant articles (@code{gnus-summary-limit-include-dormant}). + +@item / d +@kindex / d (Summary) +@findex gnus-summary-limit-exclude-dormant +Hide all dormant articles (@code{gnus-summary-limit-exclude-dormant}). + +@item / T +@kindex / T (Summary) +@findex gnus-summary-limit-include-thread +Include all the articles in the current thread. + +@item / c +@kindex / c (Summary) +@findex gnus-summary-limit-exclude-childless-dormant +Hide all dormant articles that have no children +(@code{gnus-summary-limit-exclude-childless-dormant}). + +@item / C +@kindex / C (Summary) +@findex gnus-summary-limit-mark-excluded-as-read +Mark all excluded unread articles as read +(@code{gnus-summary-limit-mark-excluded-as-read}). If given a prefix, +also mark excluded ticked and dormant articles as read. + +@end table + + +@node Threading +@section Threading +@cindex threading +@cindex article threading + +Gnus threads articles by default. @dfn{To thread} is to put responses +to articles directly after the articles they respond to---in a +hierarchical fashion. + +Threading is done by looking at the @code{References} headers of the +articles. In a perfect world, this would be enough to build pretty +trees, but unfortunately, the @code{References} header is often broken +or simply missing. Weird news propagration excarcerbates the problem, +so one has to employ other heuristics to get pleasing results. A +plethora of approaches exists, as detailed in horrible detail in +@pxref{Customizing Threading}. + +First, a quick overview of the concepts: + +@table @dfn +@item root +The top-most article in a thread; the first article in the thread. + +@item thread +A tree-like article structure. + +@item sub-thread +A small(er) section of this tree-like structure. + +@item loose threads +Threads often lose their roots due to article expiry, or due to the root +already having been read in a previous session, and not displayed in the +summary buffer. We then typicall have many sub-threads that really +belong to one thread, but are without connecting roots. These are +called loose threads. + +@item thread gathering +An attempt to gather loose threads into bigger threads. + +@item sparse threads +A thread where the missing articles have been ``guessed'' at, and are +displayed as empty lines in the summary buffer. + +@end table + + +@menu +* Customizing Threading:: Variables you can change to affect the threading. +* Thread Commands:: Thread based commands in the summary buffer. +@end menu + + +@node Customizing Threading +@subsection Customizing Threading +@cindex customizing threading + +@menu +* Loose Threads:: How Gnus gathers loose threads into bigger threads. +* Filling In Threads:: Making the threads displayed look fuller. +* More Threading:: Even more variables for fiddling with threads. +* Low-Level Threading:: You thought it was over... but you were wrong! +@end menu + + +@node Loose Threads +@subsubsection Loose Threads +@cindex < +@cindex > +@cindex loose threads + +@table @code +@item gnus-summary-make-false-root +@vindex gnus-summary-make-false-root +If non-@code{nil}, Gnus will gather all loose subtrees into one big tree +and create a dummy root at the top. (Wait a minute. Root at the top? +Yup.) Loose subtrees occur when the real root has expired, or you've +read or killed the root in a previous session. + +When there is no real root of a thread, Gnus will have to fudge +something. This variable says what fudging method Gnus should use. +There are four possible values: + +@iftex +@iflatex +\gnusfigure{The Summary Buffer}{390}{ +\put(0,0){\epsfig{figure=tmp/summary-adopt.ps,width=7.5cm}} +\put(445,0){\makebox(0,0)[br]{\epsfig{figure=tmp/summary-empty.ps,width=7.5cm}}} +\put(0,400){\makebox(0,0)[tl]{\epsfig{figure=tmp/summary-none.ps,width=7.5cm}}} +\put(445,400){\makebox(0,0)[tr]{\epsfig{figure=tmp/summary-dummy.ps,width=7.5cm}}} +} +@end iflatex +@end iftex + +@cindex adopting articles + +@table @code + +@item adopt +Gnus will make the first of the orphaned articles the parent. This +parent will adopt all the other articles. The adopted articles will be +marked as such by pointy brackets (@samp{<>}) instead of the standard +square brackets (@samp{[]}). This is the default method. + +@item dummy +@vindex gnus-summary-dummy-line-format +Gnus will create a dummy summary line that will pretend to be the +parent. This dummy line does not correspond to any real article, so +selecting it will just select the first real article after the dummy +article. @code{gnus-summary-dummy-line-format} is used to specify the +format of the dummy roots. It accepts only one format spec: @samp{S}, +which is the subject of the article. @xref{Formatting Variables}. + +@item empty +Gnus won't actually make any article the parent, but simply leave the +subject field of all orphans except the first empty. (Actually, it will +use @code{gnus-summary-same-subject} as the subject (@pxref{Summary +Buffer Format}).) + +@item none +Don't make any article parent at all. Just gather the threads and +display them after one another. + +@item nil +Don't gather loose threads. +@end table + +@item gnus-summary-gather-subject-limit +@vindex gnus-summary-gather-subject-limit +Loose threads are gathered by comparing subjects of articles. If this +variable is @code{nil}, Gnus requires an exact match between the +subjects of the loose threads before gathering them into one big +super-thread. This might be too strict a requirement, what with the +presence of stupid newsreaders that chop off long subject lines. If +you think so, set this variable to, say, 20 to require that only the +first 20 characters of the subjects have to match. If you set this +variable to a really low number, you'll find that Gnus will gather +everything in sight into one thread, which isn't very helpful. + +@cindex fuzzy article gathering +If you set this variable to the special value @code{fuzzy}, Gnus will +use a fuzzy string comparison algorithm on the subjects (@pxref{Fuzzy +Matching}). + +@item gnus-simplify-subject-fuzzy-regexp +@vindex gnus-simplify-subject-fuzzy-regexp +This can either be a regular expression or list of regular expressions +that match strings that will be removed from subjects if fuzzy subject +simplification is used. + +@item gnus-simplify-ignored-prefixes +@vindex gnus-simplify-ignored-prefixes +If you set @code{gnus-summary-gather-subject-limit} to something as low +as 10, you might consider setting this variable to something sensible: + +@c Written by Michael Ernst +@lisp +(setq gnus-simplify-ignored-prefixes + (concat + "\\`\\[?\\(" + (mapconcat + 'identity + '("looking" + "wanted" "followup" "summary\\( of\\)?" + "help" "query" "problem" "question" + "answer" "reference" "announce" + "How can I" "How to" "Comparison of" + ;; ... + ) + "\\|") + "\\)\\s *\\(" + (mapconcat 'identity + '("for" "for reference" "with" "about") + "\\|") + "\\)?\\]?:?[ \t]*")) +@end lisp + +All words that match this regexp will be removed before comparing two +subjects. + +@item gnus-simplify-subject-functions +@vindex gnus-simplify-subject-functions +If non-@code{nil}, this variable overrides +@code{gnus-summary-gather-subject-limit}. This variable should be a +list of functions to apply to the @code{Subject} string iteratively to +arrive at the simplified version of the string. + +Useful functions to put in this list include: + +@table @code +@item gnus-simplify-subject-re +@findex gnus-simplify-subject-re +Strip the leading @samp{Re:}. + +@item gnus-simplify-subject-fuzzy +@findex gnus-simplify-subject-fuzzy +Simplify fuzzily. + +@item gnus-simplify-whitespace +@findex gnus-simplify-whitespace +Remove excessive whitespace. +@end table + +You may also write your own functions, of course. + + +@item gnus-summary-gather-exclude-subject +@vindex gnus-summary-gather-exclude-subject +Since loose thread gathering is done on subjects only, that might lead +to many false hits, especially with certain common subjects like +@samp{} and @samp{(none)}. To make the situation slightly better, +you can use the regexp @code{gnus-summary-gather-exclude-subject} to say +what subjects should be excluded from the gathering process.@* +The default is @samp{^ *$\\|^(none)$}. + +@item gnus-summary-thread-gathering-function +@vindex gnus-summary-thread-gathering-function +Gnus gathers threads by looking at @code{Subject} headers. This means +that totally unrelated articles may end up in the same ``thread'', which +is confusing. An alternate approach is to look at all the +@code{Message-ID}s in all the @code{References} headers to find matches. +This will ensure that no gathered threads ever include unrelated +articles, but it also means that people who have posted with broken +newsreaders won't be gathered properly. The choice is yours---plague or +cholera: + +@table @code +@item gnus-gather-threads-by-subject +@findex gnus-gather-threads-by-subject +This function is the default gathering function and looks at +@code{Subject}s exclusively. + +@item gnus-gather-threads-by-references +@findex gnus-gather-threads-by-references +This function looks at @code{References} headers exclusively. +@end table + +If you want to test gathering by @code{References}, you could say +something like: + +@lisp +(setq gnus-summary-thread-gathering-function + 'gnus-gather-threads-by-references) +@end lisp + +@end table + + +@node Filling In Threads +@subsubsection Filling In Threads + +@table @code +@item gnus-fetch-old-headers +@vindex gnus-fetch-old-headers +If non-@code{nil}, Gnus will attempt to build old threads by fetching +more old headers---headers to articles marked as read. If you +would like to display as few summary lines as possible, but still +connect as many loose threads as possible, you should set this variable +to @code{some} or a number. If you set it to a number, no more than +that number of extra old headers will be fetched. In either case, +fetching old headers only works if the backend you are using carries +overview files---this would normally be @code{nntp}, @code{nnspool} and +@code{nnml}. Also remember that if the root of the thread has been +expired by the server, there's not much Gnus can do about that. + +This variable can also be set to @code{invisible}. This won't have any +visible effects, but is useful if you use the @kbd{A T} command a lot +(@pxref{Finding the Parent}). + +@item gnus-build-sparse-threads +@vindex gnus-build-sparse-threads +Fetching old headers can be slow. A low-rent similar effect can be +gotten by setting this variable to @code{some}. Gnus will then look at +the complete @code{References} headers of all articles and try to string +together articles that belong in the same thread. This will leave +@dfn{gaps} in the threading display where Gnus guesses that an article +is missing from the thread. (These gaps appear like normal summary +lines. If you select a gap, Gnus will try to fetch the article in +question.) If this variable is @code{t}, Gnus will display all these +``gaps'' without regard for whether they are useful for completing the +thread or not. Finally, if this variable is @code{more}, Gnus won't cut +off sparse leaf nodes that don't lead anywhere. This variable is +@code{nil} by default. + +@end table + + +@node More Threading +@subsubsection More Threading + +@table @code +@item gnus-show-threads +@vindex gnus-show-threads +If this variable is @code{nil}, no threading will be done, and all of +the rest of the variables here will have no effect. Turning threading +off will speed group selection up a bit, but it is sure to make reading +slower and more awkward. + +@item gnus-thread-hide-subtree +@vindex gnus-thread-hide-subtree +If non-@code{nil}, all threads will be hidden when the summary buffer is +generated. + +@item gnus-thread-expunge-below +@vindex gnus-thread-expunge-below +All threads that have a total score (as defined by +@code{gnus-thread-score-function}) less than this number will be +expunged. This variable is @code{nil} by default, which means that no +threads are expunged. + +@item gnus-thread-hide-killed +@vindex gnus-thread-hide-killed +if you kill a thread and this variable is non-@code{nil}, the subtree +will be hidden. + +@item gnus-thread-ignore-subject +@vindex gnus-thread-ignore-subject +Sometimes somebody changes the subject in the middle of a thread. If +this variable is non-@code{nil}, the subject change is ignored. If it +is @code{nil}, which is the default, a change in the subject will result +in a new thread. + +@item gnus-thread-indent-level +@vindex gnus-thread-indent-level +This is a number that says how much each sub-thread should be indented. +The default is 4. + +@end table + + +@node Low-Level Threading +@subsubsection Low-Level Threading + +@table @code + +@item gnus-parse-headers-hook +@vindex gnus-parse-headers-hook +Hook run before parsing any headers. The default value is +@code{(gnus-decode-rfc1522)}, which means that QPized headers will be +slightly decoded in a hackish way. This is likely to change in the +future when Gnus becomes @sc{MIME}ified. + +@item gnus-alter-header-function +@vindex gnus-alter-header-function +If non-@code{nil}, this function will be called to allow alteration of +article header structures. The function is called with one parameter, +the article header vector, which it may alter in any way. For instance, +if you have a mail-to-news gateway which alters the @code{Message-ID}s +in systematic ways (by adding prefixes and such), you can use this +variable to un-scramble the @code{Message-ID}s so that they are more +meaningful. Here's one example: + +@lisp +(setq gnus-alter-header-function 'my-alter-message-id) + +(defun my-alter-message-id (header) + (let ((id (mail-header-id header))) + (when (string-match + "\\(<[^<>@@]*\\)\\.?cygnus\\..*@@\\([^<>@@]*>\\)" id) + (mail-header-set-id + (concat (match-string 1 id) "@@" (match-string 2 id)) + header)))) +@end lisp + +@end table + + +@node Thread Commands +@subsection Thread Commands +@cindex thread commands + +@table @kbd + +@item T k +@itemx M-C-k +@kindex T k (Summary) +@kindex M-C-k (Summary) +@findex gnus-summary-kill-thread +Mark all articles in the current (sub-)thread as read +(@code{gnus-summary-kill-thread}). If the prefix argument is positive, +remove all marks instead. If the prefix argument is negative, tick +articles instead. + +@item T l +@itemx M-C-l +@kindex T l (Summary) +@kindex M-C-l (Summary) +@findex gnus-summary-lower-thread +Lower the score of the current (sub-)thread +(@code{gnus-summary-lower-thread}). + +@item T i +@kindex T i (Summary) +@findex gnus-summary-raise-thread +Increase the score of the current (sub-)thread +(@code{gnus-summary-raise-thread}). + +@item T # +@kindex T # (Summary) +@findex gnus-uu-mark-thread +Set the process mark on the current (sub-)thread +(@code{gnus-uu-mark-thread}). + +@item T M-# +@kindex T M-# (Summary) +@findex gnus-uu-unmark-thread +Remove the process mark from the current (sub-)thread +(@code{gnus-uu-unmark-thread}). + +@item T T +@kindex T T (Summary) +@findex gnus-summary-toggle-threads +Toggle threading (@code{gnus-summary-toggle-threads}). + +@item T s +@kindex T s (Summary) +@findex gnus-summary-show-thread +Expose the (sub-)thread hidden under the current article, if any +(@code{gnus-summary-show-thread}). + +@item T h +@kindex T h (Summary) +@findex gnus-summary-hide-thread +Hide the current (sub-)thread (@code{gnus-summary-hide-thread}). + +@item T S +@kindex T S (Summary) +@findex gnus-summary-show-all-threads +Expose all hidden threads (@code{gnus-summary-show-all-threads}). + +@item T H +@kindex T H (Summary) +@findex gnus-summary-hide-all-threads +Hide all threads (@code{gnus-summary-hide-all-threads}). + +@item T t +@kindex T t (Summary) +@findex gnus-summary-rethread-current +Re-thread the current article's thread +(@code{gnus-summary-rethread-current}). This works even when the +summary buffer is otherwise unthreaded. + +@item T ^ +@kindex T ^ (Summary) +@findex gnus-summary-reparent-thread +Make the current article the child of the marked (or previous) article +(@code{gnus-summary-reparent-thread}). + +@end table + +The following commands are thread movement commands. They all +understand the numeric prefix. + +@table @kbd + +@item T n +@kindex T n (Summary) +@findex gnus-summary-next-thread +Go to the next thread (@code{gnus-summary-next-thread}). + +@item T p +@kindex T p (Summary) +@findex gnus-summary-prev-thread +Go to the previous thread (@code{gnus-summary-prev-thread}). + +@item T d +@kindex T d (Summary) +@findex gnus-summary-down-thread +Descend the thread (@code{gnus-summary-down-thread}). + +@item T u +@kindex T u (Summary) +@findex gnus-summary-up-thread +Ascend the thread (@code{gnus-summary-up-thread}). + +@item T o +@kindex T o (Summary) +@findex gnus-summary-top-thread +Go to the top of the thread (@code{gnus-summary-top-thread}). +@end table + +@vindex gnus-thread-operation-ignore-subject +If you ignore subject while threading, you'll naturally end up with +threads that have several different subjects in them. If you then issue +a command like `T k' (@code{gnus-summary-kill-thread}) you might not +wish to kill the entire thread, but just those parts of the thread that +have the same subject as the current article. If you like this idea, +you can fiddle with @code{gnus-thread-operation-ignore-subject}. If it +is non-@code{nil} (which it is by default), subjects will be ignored +when doing thread commands. If this variable is @code{nil}, articles in +the same thread with different subjects will not be included in the +operation in question. If this variable is @code{fuzzy}, only articles +that have subjects fuzzily equal will be included (@pxref{Fuzzy +Matching}). + + +@node Sorting +@section Sorting + +@findex gnus-thread-sort-by-total-score +@findex gnus-thread-sort-by-date +@findex gnus-thread-sort-by-score +@findex gnus-thread-sort-by-subject +@findex gnus-thread-sort-by-author +@findex gnus-thread-sort-by-number +@vindex gnus-thread-sort-functions +If you are using a threaded summary display, you can sort the threads by +setting @code{gnus-thread-sort-functions}, which is a list of functions. +By default, sorting is done on article numbers. Ready-made sorting +predicate functions include @code{gnus-thread-sort-by-number}, +@code{gnus-thread-sort-by-author}, @code{gnus-thread-sort-by-subject}, +@code{gnus-thread-sort-by-date}, @code{gnus-thread-sort-by-score}, and +@code{gnus-thread-sort-by-total-score}. + +Each function takes two threads and returns non-@code{nil} if the first +thread should be sorted before the other. Note that sorting really is +normally done by looking only at the roots of each thread. If you use +more than one function, the primary sort key should be the last function +in the list. You should probably always include +@code{gnus-thread-sort-by-number} in the list of sorting +functions---preferably first. This will ensure that threads that are +equal with respect to the other sort criteria will be displayed in +ascending article order. + +If you would like to sort by score, then by subject, and finally by +number, you could do something like: + +@lisp +(setq gnus-thread-sort-functions + '(gnus-thread-sort-by-number + gnus-thread-sort-by-subject + gnus-thread-sort-by-total-score)) +@end lisp + +The threads that have highest score will be displayed first in the +summary buffer. When threads have the same score, they will be sorted +alphabetically. The threads that have the same score and the same +subject will be sorted by number, which is (normally) the sequence in +which the articles arrived. + +If you want to sort by score and then reverse arrival order, you could +say something like: + +@lisp +(setq gnus-thread-sort-functions + '((lambda (t1 t2) + (not (gnus-thread-sort-by-number t2 t1))) + gnus-thread-sort-by-score)) +@end lisp + +@vindex gnus-thread-score-function +The function in the @code{gnus-thread-score-function} variable (default +@code{+}) is used for calculating the total score of a thread. Useful +functions might be @code{max}, @code{min}, or squared means, or whatever +tickles your fancy. + +@findex gnus-article-sort-functions +@findex gnus-article-sort-by-date +@findex gnus-article-sort-by-score +@findex gnus-article-sort-by-subject +@findex gnus-article-sort-by-author +@findex gnus-article-sort-by-number +If you are using an unthreaded display for some strange reason or other, +you have to fiddle with the @code{gnus-article-sort-functions} variable. +It is very similar to the @code{gnus-thread-sort-functions}, except that +it uses slightly different functions for article comparison. Available +sorting predicate functions are @code{gnus-article-sort-by-number}, +@code{gnus-article-sort-by-author}, @code{gnus-article-sort-by-subject}, +@code{gnus-article-sort-by-date}, and @code{gnus-article-sort-by-score}. + +If you want to sort an unthreaded summary display by subject, you could +say something like: + +@lisp +(setq gnus-article-sort-functions + '(gnus-article-sort-by-number + gnus-article-sort-by-subject)) +@end lisp + + + +@node Asynchronous Fetching +@section Asynchronous Article Fetching +@cindex asynchronous article fetching +@cindex article pre-fetch +@cindex pre-fetch + +If you read your news from an @sc{nntp} server that's far away, the +network latencies may make reading articles a chore. You have to wait +for a while after pressing @kbd{n} to go to the next article before the +article appears. Why can't Gnus just go ahead and fetch the article +while you are reading the previous one? Why not, indeed. + +First, some caveats. There are some pitfalls to using asynchronous +article fetching, especially the way Gnus does it. + +Let's say you are reading article 1, which is short, and article 2 is +quite long, and you are not interested in reading that. Gnus does not +know this, so it goes ahead and fetches article 2. You decide to read +article 3, but since Gnus is in the process of fetching article 2, the +connection is blocked. + +To avoid these situations, Gnus will open two (count 'em two) +connections to the server. Some people may think this isn't a very nice +thing to do, but I don't see any real alternatives. Setting up that +extra connection takes some time, so Gnus startup will be slower. + +Gnus will fetch more articles than you will read. This will mean that +the link between your machine and the @sc{nntp} server will become more +loaded than if you didn't use article pre-fetch. The server itself will +also become more loaded---both with the extra article requests, and the +extra connection. + +Ok, so now you know that you shouldn't really use this thing... unless +you really want to. + +@vindex gnus-asynchronous +Here's how: Set @code{gnus-asynchronous} to @code{t}. The rest should +happen automatically. + +@vindex gnus-use-article-prefetch +You can control how many articles are to be pre-fetched by setting +@code{gnus-use-article-prefetch}. This is 30 by default, which means +that when you read an article in the group, the backend will pre-fetch +the next 30 articles. If this variable is @code{t}, the backend will +pre-fetch all the articles it can without bound. If it is +@code{nil}, no pre-fetching will be done. + +@vindex gnus-async-prefetch-article-p +@findex gnus-async-read-p +There are probably some articles that you don't want to pre-fetch---read +articles, for instance. The @code{gnus-async-prefetch-article-p} variable controls whether an article is to be pre-fetched. This function should +return non-@code{nil} when the article in question is to be +pre-fetched. The default is @code{gnus-async-read-p}, which returns +@code{nil} on read articles. The function is called with an article +data structure as the only parameter. + +If, for instance, you wish to pre-fetch only unread articles shorter than 100 lines, you could say something like: + +@lisp +(defun my-async-short-unread-p (data) + "Return non-nil for short, unread articles." + (and (gnus-data-unread-p data) + (< (mail-header-lines (gnus-data-header data)) + 100))) + +(setq gnus-async-prefetch-article-p 'my-async-short-unread-p) +@end lisp + +These functions will be called many, many times, so they should +preferably be short and sweet to avoid slowing down Gnus too much. +It's probably a good idea to byte-compile things like this. + +@vindex gnus-prefetched-article-deletion-strategy +Articles have to be removed from the asynch buffer sooner or later. The +@code{gnus-prefetched-article-deletion-strategy} says when to remove +articles. This is a list that may contain the following elements: + +@table @code +@item read +Remove articles when they are read. + +@item exit +Remove articles when exiting the group. +@end table + +The default value is @code{(read exit)}. + +@vindex gnus-use-header-prefetch +If @code{gnus-use-header-prefetch} is non-@code{nil}, prefetch articles +from the next group. + + +@node Article Caching +@section Article Caching +@cindex article caching +@cindex caching + +If you have an @emph{extremely} slow @sc{nntp} connection, you may +consider turning article caching on. Each article will then be stored +locally under your home directory. As you may surmise, this could +potentially use @emph{huge} amounts of disk space, as well as eat up all +your inodes so fast it will make your head swim. In vodka. + +Used carefully, though, it could be just an easier way to save articles. + +@vindex gnus-use-long-file-name +@vindex gnus-cache-directory +@vindex gnus-use-cache +To turn caching on, set @code{gnus-use-cache} to @code{t}. By default, +all articles ticked or marked as dormant will then be copied +over to your local cache (@code{gnus-cache-directory}). Whether this +cache is flat or hierarchal is controlled by the +@code{gnus-use-long-file-name} variable, as usual. + +When re-selecting a ticked or dormant article, it will be fetched from the +cache instead of from the server. As articles in your cache will never +expire, this might serve as a method of saving articles while still +keeping them where they belong. Just mark all articles you want to save +as dormant, and don't worry. + +When an article is marked as read, is it removed from the cache. + +@vindex gnus-cache-remove-articles +@vindex gnus-cache-enter-articles +The entering/removal of articles from the cache is controlled by the +@code{gnus-cache-enter-articles} and @code{gnus-cache-remove-articles} +variables. Both are lists of symbols. The first is @code{(ticked +dormant)} by default, meaning that ticked and dormant articles will be +put in the cache. The latter is @code{(read)} by default, meaning that +articles marked as read are removed from the cache. Possibly +symbols in these two lists are @code{ticked}, @code{dormant}, +@code{unread} and @code{read}. + +@findex gnus-jog-cache +So where does the massive article-fetching and storing come into the +picture? The @code{gnus-jog-cache} command will go through all +subscribed newsgroups, request all unread articles, score them, and +store them in the cache. You should only ever, ever ever ever, use this +command if 1) your connection to the @sc{nntp} server is really, really, +really slow and 2) you have a really, really, really huge disk. +Seriously. One way to cut down on the number of articles downloaded is +to score unwanted articles down and have them marked as read. They will +not then be downloaded by this command. + +@vindex gnus-uncacheable-groups +It is likely that you do not want caching on some groups. For instance, +if your @code{nnml} mail is located under your home directory, it makes no +sense to cache it somewhere else under your home directory. Unless you +feel that it's neat to use twice as much space. To limit the caching, +you could set the @code{gnus-uncacheable-groups} regexp to +@samp{^nnml}, for instance. This variable is @code{nil} by +default. + +@findex gnus-cache-generate-nov-databases +@findex gnus-cache-generate-active +@vindex gnus-cache-active-file +The cache stores information on what articles it contains in its active +file (@code{gnus-cache-active-file}). If this file (or any other parts +of the cache) becomes all messed up for some reason or other, Gnus +offers two functions that will try to set things right. @kbd{M-x +gnus-cache-generate-nov-databases} will (re)build all the @sc{nov} +files, and @kbd{gnus-cache-generate-active} will (re)generate the active +file. + + +@node Persistent Articles +@section Persistent Articles +@cindex persistent articles + +Closely related to article caching, we have @dfn{persistent articles}. +In fact, it's just a different way of looking at caching, and much more +useful in my opinion. + +Say you're reading a newsgroup, and you happen on to some valuable gem +that you want to keep and treasure forever. You'd normally just save it +(using one of the many saving commands) in some file. The problem with +that is that it's just, well, yucky. Ideally you'd prefer just having +the article remain in the group where you found it forever; untouched by +the expiry going on at the news server. + +This is what a @dfn{persistent article} is---an article that just won't +be deleted. It's implemented using the normal cache functions, but +you use two explicit commands for managing persistent articles: + +@table @kbd + +@item * +@kindex * (Summary) +@findex gnus-cache-enter-article +Make the current article persistent (@code{gnus-cache-enter-article}). + +@item M-* +@kindex M-* (Summary) +@findex gnus-cache-remove-article +Remove the current article from the persistent articles +(@code{gnus-cache-remove-article}). This will normally delete the +article. +@end table + +Both these commands understand the process/prefix convention. + +To avoid having all ticked articles (and stuff) entered into the cache, +you should set @code{gnus-use-cache} to @code{passive} if you're just +interested in persistent articles: + +@lisp +(setq gnus-use-cache 'passive) +@end lisp + + +@node Article Backlog +@section Article Backlog +@cindex backlog +@cindex article backlog + +If you have a slow connection, but the idea of using caching seems +unappealing to you (and it is, really), you can help the situation some +by switching on the @dfn{backlog}. This is where Gnus will buffer +already read articles so that it doesn't have to re-fetch articles +you've already read. This only helps if you are in the habit of +re-selecting articles you've recently read, of course. If you never do +that, turning the backlog on will slow Gnus down a little bit, and +increase memory usage some. + +@vindex gnus-keep-backlog +If you set @code{gnus-keep-backlog} to a number @var{n}, Gnus will store +at most @var{n} old articles in a buffer for later re-fetching. If this +variable is non-@code{nil} and is not a number, Gnus will store +@emph{all} read articles, which means that your Emacs will grow without +bound before exploding and taking your machine down with you. I put +that in there just to keep y'all on your toes. + +This variable is @code{nil} by default. + + +@node Saving Articles +@section Saving Articles +@cindex saving articles + +Gnus can save articles in a number of ways. Below is the documentation +for saving articles in a fairly straight-forward fashion (i.e., little +processing of the article is done before it is saved). For a different +approach (uudecoding, unsharing) you should use @code{gnus-uu} +(@pxref{Decoding Articles}). + +@vindex gnus-save-all-headers +If @code{gnus-save-all-headers} is non-@code{nil}, Gnus will not delete +unwanted headers before saving the article. + +@vindex gnus-saved-headers +If the preceding variable is @code{nil}, all headers that match the +@code{gnus-saved-headers} regexp will be kept, while the rest will be +deleted before saving. + +@table @kbd + +@item O o +@itemx o +@kindex O o (Summary) +@kindex o (Summary) +@findex gnus-summary-save-article +@c @icon{gnus-summary-save-article} +Save the current article using the default article saver +(@code{gnus-summary-save-article}). + +@item O m +@kindex O m (Summary) +@findex gnus-summary-save-article-mail +Save the current article in mail format +(@code{gnus-summary-save-article-mail}). + +@item O r +@kindex O r (Summary) +@findex gnus-summary-save-article-rmail +Save the current article in rmail format +(@code{gnus-summary-save-article-rmail}). + +@item O f +@kindex O f (Summary) +@findex gnus-summary-save-article-file +@c @icon{gnus-summary-save-article-file} +Save the current article in plain file format +(@code{gnus-summary-save-article-file}). + +@item O F +@kindex O F (Summary) +@findex gnus-summary-write-article-file +Write the current article in plain file format, overwriting any previous +file contents (@code{gnus-summary-write-article-file}). + +@item O b +@kindex O b (Summary) +@findex gnus-summary-save-article-body-file +Save the current article body in plain file format +(@code{gnus-summary-save-article-body-file}). + +@item O h +@kindex O h (Summary) +@findex gnus-summary-save-article-folder +Save the current article in mh folder format +(@code{gnus-summary-save-article-folder}). + +@item O v +@kindex O v (Summary) +@findex gnus-summary-save-article-vm +Save the current article in a VM folder +(@code{gnus-summary-save-article-vm}). + +@item O p +@kindex O p (Summary) +@findex gnus-summary-pipe-output +Save the current article in a pipe. Uhm, like, what I mean is---Pipe +the current article to a process (@code{gnus-summary-pipe-output}). +@end table + +@vindex gnus-prompt-before-saving +All these commands use the process/prefix convention +(@pxref{Process/Prefix}). If you save bunches of articles using these +functions, you might get tired of being prompted for files to save each +and every article in. The prompting action is controlled by +the @code{gnus-prompt-before-saving} variable, which is @code{always} by +default, giving you that excessive prompting action you know and +loathe. If you set this variable to @code{t} instead, you'll be prompted +just once for each series of articles you save. If you like to really +have Gnus do all your thinking for you, you can even set this variable +to @code{nil}, which means that you will never be prompted for files to +save articles in. Gnus will simply save all the articles in the default +files. + + +@vindex gnus-default-article-saver +You can customize the @code{gnus-default-article-saver} variable to make +Gnus do what you want it to. You can use any of the four ready-made +functions below, or you can create your own. + +@table @code + +@item gnus-summary-save-in-rmail +@findex gnus-summary-save-in-rmail +@vindex gnus-rmail-save-name +@findex gnus-plain-save-name +This is the default format, @dfn{babyl}. Uses the function in the +@code{gnus-rmail-save-name} variable to get a file name to save the +article in. The default is @code{gnus-plain-save-name}. + +@item gnus-summary-save-in-mail +@findex gnus-summary-save-in-mail +@vindex gnus-mail-save-name +Save in a Unix mail (mbox) file. Uses the function in the +@code{gnus-mail-save-name} variable to get a file name to save the +article in. The default is @code{gnus-plain-save-name}. + +@item gnus-summary-save-in-file +@findex gnus-summary-save-in-file +@vindex gnus-file-save-name +@findex gnus-numeric-save-name +Append the article straight to an ordinary file. Uses the function in +the @code{gnus-file-save-name} variable to get a file name to save the +article in. The default is @code{gnus-numeric-save-name}. + +@item gnus-summary-save-body-in-file +@findex gnus-summary-save-body-in-file +Append the article body to an ordinary file. Uses the function in the +@code{gnus-file-save-name} variable to get a file name to save the +article in. The default is @code{gnus-numeric-save-name}. + +@item gnus-summary-save-in-folder +@findex gnus-summary-save-in-folder +@findex gnus-folder-save-name +@findex gnus-Folder-save-name +@vindex gnus-folder-save-name +@cindex rcvstore +@cindex MH folders +Save the article to an MH folder using @code{rcvstore} from the MH +library. Uses the function in the @code{gnus-folder-save-name} variable +to get a file name to save the article in. The default is +@code{gnus-folder-save-name}, but you can also use +@code{gnus-Folder-save-name}, which creates capitalized names. + +@item gnus-summary-save-in-vm +@findex gnus-summary-save-in-vm +Save the article in a VM folder. You have to have the VM mail +reader to use this setting. +@end table + +@vindex gnus-article-save-directory +All of these functions, except for the last one, will save the article +in the @code{gnus-article-save-directory}, which is initialized from the +@code{SAVEDIR} environment variable. This is @file{~/News/} by +default. + +As you can see above, the functions use different functions to find a +suitable name of a file to save the article in. Below is a list of +available functions that generate names: + +@table @code + +@item gnus-Numeric-save-name +@findex gnus-Numeric-save-name +File names like @file{~/News/Alt.andrea-dworkin/45}. + +@item gnus-numeric-save-name +@findex gnus-numeric-save-name +File names like @file{~/News/alt.andrea-dworkin/45}. + +@item gnus-Plain-save-name +@findex gnus-Plain-save-name +File names like @file{~/News/Alt.andrea-dworkin}. + +@item gnus-plain-save-name +@findex gnus-plain-save-name +File names like @file{~/News/alt.andrea-dworkin}. +@end table + +@vindex gnus-split-methods +You can have Gnus suggest where to save articles by plonking a regexp into +the @code{gnus-split-methods} alist. For instance, if you would like to +save articles related to Gnus in the file @file{gnus-stuff}, and articles +related to VM in @code{vm-stuff}, you could set this variable to something +like: + +@lisp +(("^Subject:.*gnus\\|^Newsgroups:.*gnus" "gnus-stuff") + ("^Subject:.*vm\\|^Xref:.*vm" "vm-stuff") + (my-choosing-function "../other-dir/my-stuff") + ((equal gnus-newsgroup-name "mail.misc") "mail-stuff")) +@end lisp + +We see that this is a list where each element is a list that has two +elements---the @dfn{match} and the @dfn{file}. The match can either be +a string (in which case it is used as a regexp to match on the article +head); it can be a symbol (which will be called as a function with the +group name as a parameter); or it can be a list (which will be +@code{eval}ed). If any of these actions have a non-@code{nil} result, +the @dfn{file} will be used as a default prompt. In addition, the +result of the operation itself will be used if the function or form +called returns a string or a list of strings. + +You basically end up with a list of file names that might be used when +saving the current article. (All ``matches'' will be used.) You will +then be prompted for what you really want to use as a name, with file +name completion over the results from applying this variable. + +This variable is @code{((gnus-article-archive-name))} by default, which +means that Gnus will look at the articles it saves for an +@code{Archive-name} line and use that as a suggestion for the file +name. + +Here's an example function to clean up file names somewhat. If you have +lots of mail groups called things like +@samp{nnml:mail.whatever}, you may want to chop off the beginning of +these group names before creating the file name to save to. The +following will do just that: + +@lisp +(defun my-save-name (group) + (when (string-match "^nnml:mail." group) + (substring group (match-end 0)))) + +(setq gnus-split-methods + '((gnus-article-archive-name) + (my-save-name))) +@end lisp + + +@vindex gnus-use-long-file-name +Finally, you have the @code{gnus-use-long-file-name} variable. If it is +@code{nil}, all the preceding functions will replace all periods +(@samp{.}) in the group names with slashes (@samp{/})---which means that +the functions will generate hierarchies of directories instead of having +all the files in the toplevel directory +(@file{~/News/alt/andrea-dworkin} instead of +@file{~/News/alt.andrea-dworkin}.) This variable is @code{t} by default +on most systems. However, for historical reasons, this is @code{nil} on +Xenix and usg-unix-v machines by default. + +This function also affects kill and score file names. If this variable +is a list, and the list contains the element @code{not-score}, long file +names will not be used for score files, if it contains the element +@code{not-save}, long file names will not be used for saving, and if it +contains the element @code{not-kill}, long file names will not be used +for kill files. + +If you'd like to save articles in a hierarchy that looks something like +a spool, you could + +@lisp +(setq gnus-use-long-file-name '(not-save)) ; to get a hierarchy +(setq gnus-default-article-saver 'gnus-summary-save-in-file) ; no encoding +@end lisp + +Then just save with @kbd{o}. You'd then read this hierarchy with +ephemeral @code{nneething} groups---@kbd{G D} in the group buffer, and +the toplevel directory as the argument (@file{~/News/}). Then just walk +around to the groups/directories with @code{nneething}. + + +@node Decoding Articles +@section Decoding Articles +@cindex decoding articles + +Sometime users post articles (or series of articles) that have been +encoded in some way or other. Gnus can decode them for you. + +@menu +* Uuencoded Articles:: Uudecode articles. +* Shell Archives:: Unshar articles. +* PostScript Files:: Split PostScript. +* Other Files:: Plain save and binhex. +* Decoding Variables:: Variables for a happy decoding. +* Viewing Files:: You want to look at the result of the decoding? +@end menu + +@cindex series +@cindex article series +All these functions use the process/prefix convention +(@pxref{Process/Prefix}) for finding out what articles to work on, with +the extension that a ``single article'' means ``a single series''. Gnus +can find out by itself what articles belong to a series, decode all the +articles and unpack/view/save the resulting file(s). + +Gnus guesses what articles are in the series according to the following +simplish rule: The subjects must be (nearly) identical, except for the +last two numbers of the line. (Spaces are largely ignored, however.) + +For example: If you choose a subject called @samp{cat.gif (2/3)}, Gnus +will find all the articles that match the regexp @samp{^cat.gif +([0-9]+/[0-9]+).*$}. + +Subjects that are non-standard, like @samp{cat.gif (2/3) Part 6 of a +series}, will not be properly recognized by any of the automatic viewing +commands, and you have to mark the articles manually with @kbd{#}. + + +@node Uuencoded Articles +@subsection Uuencoded Articles +@cindex uudecode +@cindex uuencoded articles + +@table @kbd + +@item X u +@kindex X u (Summary) +@findex gnus-uu-decode-uu +@c @icon{gnus-uu-decode-uu} +Uudecodes the current series (@code{gnus-uu-decode-uu}). + +@item X U +@kindex X U (Summary) +@findex gnus-uu-decode-uu-and-save +Uudecodes and saves the current series +(@code{gnus-uu-decode-uu-and-save}). + +@item X v u +@kindex X v u (Summary) +@findex gnus-uu-decode-uu-view +Uudecodes and views the current series (@code{gnus-uu-decode-uu-view}). + +@item X v U +@kindex X v U (Summary) +@findex gnus-uu-decode-uu-and-save-view +Uudecodes, views and saves the current series +(@code{gnus-uu-decode-uu-and-save-view}). + +@end table + +Remember that these all react to the presence of articles marked with +the process mark. If, for instance, you'd like to decode and save an +entire newsgroup, you'd typically do @kbd{M P a} +(@code{gnus-uu-mark-all}) and then @kbd{X U} +(@code{gnus-uu-decode-uu-and-save}). + +All this is very much different from how @code{gnus-uu} worked with +@sc{gnus 4.1}, where you had explicit keystrokes for everything under +the sun. This version of @code{gnus-uu} generally assumes that you mark +articles in some way (@pxref{Setting Process Marks}) and then press +@kbd{X u}. + +@vindex gnus-uu-notify-files +Note: When trying to decode articles that have names matching +@code{gnus-uu-notify-files}, which is hard-coded to +@samp{[Cc][Ii][Nn][Dd][Yy][0-9]+.\\(gif\\|jpg\\)}, @code{gnus-uu} will +automatically post an article on @samp{comp.unix.wizards} saying that +you have just viewed the file in question. This feature can't be turned +off. + + +@node Shell Archives +@subsection Shell Archives +@cindex unshar +@cindex shell archives +@cindex shared articles + +Shell archives (``shar files'') used to be a popular way to distribute +sources, but it isn't used all that much today. In any case, we have +some commands to deal with these: + +@table @kbd + +@item X s +@kindex X s (Summary) +@findex gnus-uu-decode-unshar +Unshars the current series (@code{gnus-uu-decode-unshar}). + +@item X S +@kindex X S (Summary) +@findex gnus-uu-decode-unshar-and-save +Unshars and saves the current series (@code{gnus-uu-decode-unshar-and-save}). + +@item X v s +@kindex X v s (Summary) +@findex gnus-uu-decode-unshar-view +Unshars and views the current series (@code{gnus-uu-decode-unshar-view}). + +@item X v S +@kindex X v S (Summary) +@findex gnus-uu-decode-unshar-and-save-view +Unshars, views and saves the current series +(@code{gnus-uu-decode-unshar-and-save-view}). +@end table + + +@node PostScript Files +@subsection PostScript Files +@cindex PostScript + +@table @kbd + +@item X p +@kindex X p (Summary) +@findex gnus-uu-decode-postscript +Unpack the current PostScript series (@code{gnus-uu-decode-postscript}). + +@item X P +@kindex X P (Summary) +@findex gnus-uu-decode-postscript-and-save +Unpack and save the current PostScript series +(@code{gnus-uu-decode-postscript-and-save}). + +@item X v p +@kindex X v p (Summary) +@findex gnus-uu-decode-postscript-view +View the current PostScript series +(@code{gnus-uu-decode-postscript-view}). + +@item X v P +@kindex X v P (Summary) +@findex gnus-uu-decode-postscript-and-save-view +View and save the current PostScript series +(@code{gnus-uu-decode-postscript-and-save-view}). +@end table + + +@node Other Files +@subsection Other Files + +@table @kbd +@item X o +@kindex X o (Summary) +@findex gnus-uu-decode-save +Save the current series +(@code{gnus-uu-decode-save}). + +@item X b +@kindex X b (Summary) +@findex gnus-uu-decode-binhex +Unbinhex the current series (@code{gnus-uu-decode-binhex}). This +doesn't really work yet. +@end table + + +@node Decoding Variables +@subsection Decoding Variables + +Adjective, not verb. + +@menu +* Rule Variables:: Variables that say how a file is to be viewed. +* Other Decode Variables:: Other decode variables. +* Uuencoding and Posting:: Variables for customizing uuencoding. +@end menu + + +@node Rule Variables +@subsubsection Rule Variables +@cindex rule variables + +Gnus uses @dfn{rule variables} to decide how to view a file. All these +variables are of the form + +@lisp + (list '(regexp1 command2) + '(regexp2 command2) + ...) +@end lisp + +@table @code + +@item gnus-uu-user-view-rules +@vindex gnus-uu-user-view-rules +@cindex sox +This variable is consulted first when viewing files. If you wish to use, +for instance, @code{sox} to convert an @samp{.au} sound file, you could +say something like: +@lisp +(setq gnus-uu-user-view-rules + (list '(\"\\\\.au$\" \"sox %s -t .aiff > /dev/audio\"))) +@end lisp + +@item gnus-uu-user-view-rules-end +@vindex gnus-uu-user-view-rules-end +This variable is consulted if Gnus couldn't make any matches from the +user and default view rules. + +@item gnus-uu-user-archive-rules +@vindex gnus-uu-user-archive-rules +This variable can be used to say what commands should be used to unpack +archives. +@end table + + +@node Other Decode Variables +@subsubsection Other Decode Variables + +@table @code +@vindex gnus-uu-grabbed-file-functions + +@item gnus-uu-grabbed-file-functions +All functions in this list will be called right after each file has been +successfully decoded---so that you can move or view files right away, +and don't have to wait for all files to be decoded before you can do +anything. Ready-made functions you can put in this list are: + +@table @code + +@item gnus-uu-grab-view +@findex gnus-uu-grab-view +View the file. + +@item gnus-uu-grab-move +@findex gnus-uu-grab-move +Move the file (if you're using a saving function.) +@end table + +@item gnus-uu-be-dangerous +@vindex gnus-uu-be-dangerous +Specifies what to do if unusual situations arise during decoding. If +@code{nil}, be as conservative as possible. If @code{t}, ignore things +that didn't work, and overwrite existing files. Otherwise, ask each +time. + +@item gnus-uu-ignore-files-by-name +@vindex gnus-uu-ignore-files-by-name +Files with name matching this regular expression won't be viewed. + +@item gnus-uu-ignore-files-by-type +@vindex gnus-uu-ignore-files-by-type +Files with a @sc{mime} type matching this variable won't be viewed. +Note that Gnus tries to guess what type the file is based on the name. +@code{gnus-uu} is not a @sc{mime} package (yet), so this is slightly +kludgey. + +@item gnus-uu-tmp-dir +@vindex gnus-uu-tmp-dir +Where @code{gnus-uu} does its work. + +@item gnus-uu-do-not-unpack-archives +@vindex gnus-uu-do-not-unpack-archives +Non-@code{nil} means that @code{gnus-uu} won't peek inside archives +looking for files to display. + +@item gnus-uu-view-and-save +@vindex gnus-uu-view-and-save +Non-@code{nil} means that the user will always be asked to save a file +after viewing it. + +@item gnus-uu-ignore-default-view-rules +@vindex gnus-uu-ignore-default-view-rules +Non-@code{nil} means that @code{gnus-uu} will ignore the default viewing +rules. + +@item gnus-uu-ignore-default-archive-rules +@vindex gnus-uu-ignore-default-archive-rules +Non-@code{nil} means that @code{gnus-uu} will ignore the default archive +unpacking commands. + +@item gnus-uu-kill-carriage-return +@vindex gnus-uu-kill-carriage-return +Non-@code{nil} means that @code{gnus-uu} will strip all carriage returns +from articles. + +@item gnus-uu-unmark-articles-not-decoded +@vindex gnus-uu-unmark-articles-not-decoded +Non-@code{nil} means that @code{gnus-uu} will mark unsuccessfully +decoded articles as unread. + +@item gnus-uu-correct-stripped-uucode +@vindex gnus-uu-correct-stripped-uucode +Non-@code{nil} means that @code{gnus-uu} will @emph{try} to fix +uuencoded files that have had trailing spaces deleted. + +@item gnus-uu-view-with-metamail +@vindex gnus-uu-view-with-metamail +@cindex metamail +Non-@code{nil} means that @code{gnus-uu} will ignore the viewing +commands defined by the rule variables and just fudge a @sc{mime} +content type based on the file name. The result will be fed to +@code{metamail} for viewing. + +@item gnus-uu-save-in-digest +@vindex gnus-uu-save-in-digest +Non-@code{nil} means that @code{gnus-uu}, when asked to save without +decoding, will save in digests. If this variable is @code{nil}, +@code{gnus-uu} will just save everything in a file without any +embellishments. The digesting almost conforms to RFC1153---no easy way +to specify any meaningful volume and issue numbers were found, so I +simply dropped them. + +@end table + + +@node Uuencoding and Posting +@subsubsection Uuencoding and Posting + +@table @code + +@item gnus-uu-post-include-before-composing +@vindex gnus-uu-post-include-before-composing +Non-@code{nil} means that @code{gnus-uu} will ask for a file to encode +before you compose the article. If this variable is @code{t}, you can +either include an encoded file with @kbd{C-c C-i} or have one included +for you when you post the article. + +@item gnus-uu-post-length +@vindex gnus-uu-post-length +Maximum length of an article. The encoded file will be split into how +many articles it takes to post the entire file. + +@item gnus-uu-post-threaded +@vindex gnus-uu-post-threaded +Non-@code{nil} means that @code{gnus-uu} will post the encoded file in a +thread. This may not be smart, as no other decoder I have seen is able +to follow threads when collecting uuencoded articles. (Well, I have +seen one package that does that---@code{gnus-uu}, but somehow, I don't +think that counts...) Default is @code{nil}. + +@item gnus-uu-post-separate-description +@vindex gnus-uu-post-separate-description +Non-@code{nil} means that the description will be posted in a separate +article. The first article will typically be numbered (0/x). If this +variable is @code{nil}, the description the user enters will be included +at the beginning of the first article, which will be numbered (1/x). +Default is @code{t}. + +@end table + + +@node Viewing Files +@subsection Viewing Files +@cindex viewing files +@cindex pseudo-articles + +After decoding, if the file is some sort of archive, Gnus will attempt +to unpack the archive and see if any of the files in the archive can be +viewed. For instance, if you have a gzipped tar file @file{pics.tar.gz} +containing the files @file{pic1.jpg} and @file{pic2.gif}, Gnus will +uncompress and de-tar the main file, and then view the two pictures. +This unpacking process is recursive, so if the archive contains archives +of archives, it'll all be unpacked. + +Finally, Gnus will normally insert a @dfn{pseudo-article} for each +extracted file into the summary buffer. If you go to these +``articles'', you will be prompted for a command to run (usually Gnus +will make a suggestion), and then the command will be run. + +@vindex gnus-view-pseudo-asynchronously +If @code{gnus-view-pseudo-asynchronously} is @code{nil}, Emacs will wait +until the viewing is done before proceeding. + +@vindex gnus-view-pseudos +If @code{gnus-view-pseudos} is @code{automatic}, Gnus will not insert +the pseudo-articles into the summary buffer, but view them +immediately. If this variable is @code{not-confirm}, the user won't even +be asked for a confirmation before viewing is done. + +@vindex gnus-view-pseudos-separately +If @code{gnus-view-pseudos-separately} is non-@code{nil}, one +pseudo-article will be created for each file to be viewed. If +@code{nil}, all files that use the same viewing command will be given as +a list of parameters to that command. + +@vindex gnus-insert-pseudo-articles +If @code{gnus-insert-pseudo-articles} is non-@code{nil}, insert +pseudo-articles when decoding. It is @code{t} by default. + +So; there you are, reading your @emph{pseudo-articles} in your +@emph{virtual newsgroup} from the @emph{virtual server}; and you think: +Why isn't anything real anymore? How did we get here? + + +@node Article Treatment +@section Article Treatment + +Reading through this huge manual, you may have quite forgotten that the +object of newsreaders is to actually, like, read what people have +written. Reading articles. Unfortunately, people are quite bad at +writing, so there are tons of functions and variables to make reading +these articles easier. + +@menu +* Article Highlighting:: You want to make the article look like fruit salad. +* Article Fontisizing:: Making emphasized text look niced. +* Article Hiding:: You also want to make certain info go away. +* Article Washing:: Lots of way-neat functions to make life better. +* Article Buttons:: Click on URLs, Message-IDs, addresses and the like. +* Article Date:: Grumble, UT! +* Article Signature:: What is a signature? +@end menu + + +@node Article Highlighting +@subsection Article Highlighting +@cindex highlight + +Not only do you want your article buffer to look like fruit salad, but +you want it to look like technicolor fruit salad. + +@table @kbd + +@item W H a +@kindex W H a (Summary) +@findex gnus-article-highlight +Highlight the current article (@code{gnus-article-highlight}). + +@item W H h +@kindex W H h (Summary) +@findex gnus-article-highlight-headers +@vindex gnus-header-face-alist +Highlight the headers (@code{gnus-article-highlight-headers}). The +highlighting will be done according to the @code{gnus-header-face-alist} +variable, which is a list where each element has the form @var{(regexp +name content)}. @var{regexp} is a regular expression for matching the +header, @var{name} is the face used for highlighting the header name and +@var{content} is the face for highlighting the header value. The first +match made will be used. Note that @var{regexp} shouldn't have @samp{^} +prepended---Gnus will add one. + +@item W H c +@kindex W H c (Summary) +@findex gnus-article-highlight-citation +Highlight cited text (@code{gnus-article-highlight-citation}). + +Some variables to customize the citation highlights: + +@table @code +@vindex gnus-cite-parse-max-size + +@item gnus-cite-parse-max-size +If the article size if bigger than this variable (which is 25000 by +default), no citation highlighting will be performed. + +@item gnus-cite-prefix-regexp +@vindex gnus-cite-prefix-regexp +Regexp matching the longest possible citation prefix on a line. + +@item gnus-cite-max-prefix +@vindex gnus-cite-max-prefix +Maximum possible length for a citation prefix (default 20). + +@item gnus-cite-face-list +@vindex gnus-cite-face-list +List of faces used for highlighting citations. When there are citations +from multiple articles in the same message, Gnus will try to give each +citation from each article its own face. This should make it easier to +see who wrote what. + +@item gnus-supercite-regexp +@vindex gnus-supercite-regexp +Regexp matching normal Supercite attribution lines. + +@item gnus-supercite-secondary-regexp +@vindex gnus-supercite-secondary-regexp +Regexp matching mangled Supercite attribution lines. + +@item gnus-cite-minimum-match-count +@vindex gnus-cite-minimum-match-count +Minimum number of identical prefixes we have to see before we believe +that it's a citation. + +@item gnus-cite-attribution-prefix +@vindex gnus-cite-attribution-prefix +Regexp matching the beginning of an attribution line. + +@item gnus-cite-attribution-suffix +@vindex gnus-cite-attribution-suffix +Regexp matching the end of an attribution line. + +@item gnus-cite-attribution-face +@vindex gnus-cite-attribution-face +Face used for attribution lines. It is merged with the face for the +cited text belonging to the attribution. + +@end table + + +@item W H s +@kindex W H s (Summary) +@vindex gnus-signature-separator +@vindex gnus-signature-face +@findex gnus-article-highlight-signature +Highlight the signature (@code{gnus-article-highlight-signature}). +Everything after @code{gnus-signature-separator} (@pxref{Article +Signature}) in an article will be considered a signature and will be +highlighted with @code{gnus-signature-face}, which is @code{italic} by +default. + +@end table + + +@node Article Fontisizing +@subsection Article Fontisizing +@cindex emphasis +@cindex article emphasis + +@findex gnus-article-emphasize +@kindex W e (Summary) +People commonly add emphasis to words in news articles by writing things +like @samp{_this_} or @samp{*this*}. Gnus can make this look nicer by +running the article through the @kbd{W e} +(@code{gnus-article-emphasize}) command. + +@vindex gnus-article-emphasis +How the emphasis is computed is controlled by the +@code{gnus-article-emphasis} variable. This is an alist where the first +element is a regular expression to be matched. The second is a number +that says what regular expression grouping is used to find the entire +emphasized word. The third is a number that says what regexp grouping +should be displayed and highlighted. (The text between these two +groupings will be hidden.) The fourth is the face used for +highlighting. + +@lisp +(setq gnus-article-emphasis + '(("_\\(\\w+\\)_" 0 1 gnus-emphasis-underline) + ("\\*\\(\\w+\\)\\*" 0 1 gnus-emphasis-bold))) +@end lisp + +@vindex gnus-emphasis-underline +@vindex gnus-emphasis-bold +@vindex gnus-emphasis-italic +@vindex gnus-emphasis-underline-bold +@vindex gnus-emphasis-underline-italic +@vindex gnus-emphasis-bold-italic +@vindex gnus-emphasis-underline-bold-italic +By default, there are seven rules, and they use the following faces: +@code{gnus-emphasis-bold}, @code{gnus-emphasis-italic}, +@code{gnus-emphasis-underline}, @code{gnus-emphasis-bold-italic}, +@code{gnus-emphasis-underline-italic}, +@code{gnus-emphasis-underline-bold}, and +@code{gnus-emphasis-underline-bold-italic}. + +If you want to change these faces, you can either use @kbd{M-x +customize}, or you can use @code{copy-face}. For instance, if you want +to make @code{gnus-emphasis-italic} use a red face instead, you could +say something like: + +@lisp +(copy-face 'red 'gnus-emphasis-italic) +@end lisp + + +@node Article Hiding +@subsection Article Hiding +@cindex article hiding + +Or rather, hiding certain things in each article. There usually is much +too much cruft in most articles. + +@table @kbd + +@item W W a +@kindex W W a (Summary) +@findex gnus-article-hide +Do maximum hiding on the summary buffer (@kbd{gnus-article-hide}). + +@item W W h +@kindex W W h (Summary) +@findex gnus-article-hide-headers +Hide headers (@code{gnus-article-hide-headers}). @xref{Hiding +Headers}. + +@item W W b +@kindex W W b (Summary) +@findex gnus-article-hide-boring-headers +Hide headers that aren't particularly interesting +(@code{gnus-article-hide-boring-headers}). @xref{Hiding Headers}. + +@item W W s +@kindex W W s (Summary) +@findex gnus-article-hide-signature +Hide signature (@code{gnus-article-hide-signature}). @xref{Article +Signature}. + +@item W W p +@kindex W W p (Summary) +@findex gnus-article-hide-pgp +@vindex gnus-article-hide-pgp-hook +Hide @sc{pgp} signatures (@code{gnus-article-hide-pgp}). The +@code{gnus-article-hide-pgp-hook} hook will be run after a @sc{pgp} +signature has been hidden. + +@item W W P +@kindex W W P (Summary) +@findex gnus-article-hide-pem +Hide @sc{pem} (privacy enhanced messages) cruft +(@code{gnus-article-hide-pem}). + +@item W W c +@kindex W W c (Summary) +@findex gnus-article-hide-citation +Hide citation (@code{gnus-article-hide-citation}). Some variables for +customizing the hiding: + +@table @code + +@item gnus-cite-hide-percentage +@vindex gnus-cite-hide-percentage +If the cited text is of a bigger percentage than this variable (default +50), hide the cited text. + +@item gnus-cite-hide-absolute +@vindex gnus-cite-hide-absolute +The cited text must have at least this length (default 10) before it +is hidden. + +@item gnus-cited-text-button-line-format +@vindex gnus-cited-text-button-line-format +Gnus adds buttons to show where the cited text has been hidden, and to +allow toggle hiding the text. The format of the variable is specified +by this format-like variable (@pxref{Formatting Variables}). These +specs are valid: + +@table @samp +@item b +Start point of the hidden text. +@item e +End point of the hidden text. +@item l +Length of the hidden text. +@end table + +@item gnus-cited-lines-visible +@vindex gnus-cited-lines-visible +The number of lines at the beginning of the cited text to leave shown. + +@end table + +@item W W C +@kindex W W C (Summary) +@findex gnus-article-hide-citation-in-followups +Hide cited text in articles that aren't roots +(@code{gnus-article-hide-citation-in-followups}). This isn't very +useful as an interactive command, but might be a handy function to stick +in @code{gnus-article-display-hook} (@pxref{Customizing Articles}). + +@end table + +All these ``hiding'' commands are toggles, but if you give a negative +prefix to these commands, they will show what they have previously +hidden. If you give a positive prefix, they will always hide. + +Also @pxref{Article Highlighting} for further variables for +citation customization. + + +@node Article Washing +@subsection Article Washing +@cindex washing +@cindex article washing + +We call this ``article washing'' for a really good reason. Namely, the +@kbd{A} key was taken, so we had to use the @kbd{W} key instead. + +@dfn{Washing} is defined by us as ``changing something from something to +something else'', but normally results in something looking better. +Cleaner, perhaps. + +@table @kbd + +@item W l +@kindex W l (Summary) +@findex gnus-summary-stop-page-breaking +Remove page breaks from the current article +(@code{gnus-summary-stop-page-breaking}). + +@item W r +@kindex W r (Summary) +@findex gnus-summary-caesar-message +@c @icon{gnus-summary-caesar-message} +Do a Caesar rotate (rot13) on the article buffer +(@code{gnus-summary-caesar-message}). +Unreadable articles that tell you to read them with Caesar rotate or rot13. +(Typically offensive jokes and such.) + +It's commonly called ``rot13'' because each letter is rotated 13 +positions in the alphabet, e. g. @samp{B} (letter #2) -> @samp{O} (letter +#15). It is sometimes referred to as ``Caesar rotate'' because Caesar +is rumoured to have employed this form of, uh, somewhat weak encryption. + +@item W t +@kindex W t (Summary) +@findex gnus-summary-toggle-header +Toggle whether to display all headers in the article buffer +(@code{gnus-summary-toggle-header}). + +@item W v +@kindex W v (Summary) +@findex gnus-summary-verbose-header +Toggle whether to display all headers in the article buffer permanently +(@code{gnus-summary-verbose-header}). + +@item W m +@kindex W m (Summary) +@findex gnus-summary-toggle-mime +Toggle whether to run the article through @sc{mime} before displaying +(@code{gnus-summary-toggle-mime}). + +@item W o +@kindex W o (Summary) +@findex gnus-article-treat-overstrike +Treat overstrike (@code{gnus-article-treat-overstrike}). + +@item W w +@kindex W w (Summary) +@findex gnus-article-fill-cited-article +Do word wrap (@code{gnus-article-fill-cited-article}). If you use this +function in @code{gnus-article-display-hook}, it should be run fairly +late and certainly after any highlighting. + +You can give the command a numerical prefix to specify the width to use +when filling. + +@item W c +@kindex W c (Summary) +@findex gnus-article-remove-cr +Remove CR (i. e., @samp{^M}s on the end of the lines) +(@code{gnus-article-remove-cr}). + +@item W q +@kindex W q (Summary) +@findex gnus-article-de-quoted-unreadable +Treat quoted-printable (@code{gnus-article-de-quoted-unreadable}). +Quoted-Printable is one common @sc{mime} encoding employed when sending +non-ASCII (i. e., 8-bit) articles. It typically makes strings like +@samp{déjà vu} look like @samp{d=E9j=E0 vu}, which doesn't look very +readable to me. + +@item W f +@kindex W f (Summary) +@cindex x-face +@findex gnus-article-display-x-face +@findex gnus-article-x-face-command +@vindex gnus-article-x-face-command +@vindex gnus-article-x-face-too-ugly +@iftex +@iflatex +\gnusxface{tmp/xface-karlheg.ps} +\gnusxface{tmp/xface-kyle.ps} +\gnusxface{tmp/xface-smb.ps} +@end iflatex +@end iftex +Look for and display any X-Face headers +(@code{gnus-article-display-x-face}). The command executed by this +function is given by the @code{gnus-article-x-face-command} variable. +If this variable is a string, this string will be executed in a +sub-shell. If it is a function, this function will be called with the +face as the argument. If the @code{gnus-article-x-face-too-ugly} (which +is a regexp) matches the @code{From} header, the face will not be shown. +The default action under Emacs is to fork off an @code{xv} to view the +face; under XEmacs the default action is to display the face before the +@code{From} header. (It's nicer if XEmacs has been compiled with X-Face +support---that will make display somewhat faster. If there's no native +X-Face support, Gnus will try to convert the @code{X-Face} header using +external programs from the @code{pbmplus} package and friends.) If you +want to have this function in the display hook, it should probably come +last. + +@item W b +@kindex W b (Summary) +@findex gnus-article-add-buttons +Add clickable buttons to the article (@code{gnus-article-add-buttons}). +@xref{Article Buttons} + +@item W B +@kindex W B (Summary) +@findex gnus-article-add-buttons-to-head +Add clickable buttons to the article headers +(@code{gnus-article-add-buttons-to-head}). + +@item W E l +@kindex W E l (Summary) +@findex gnus-article-strip-leading-blank-lines +Remove all blank lines from the beginning of the article +(@code{gnus-article-strip-leading-blank-lines}). + +@item W E m +@kindex W E m (Summary) +@findex gnus-article-strip-multiple-blank-lines +Replace all blank lines with empty lines and then all multiple empty +lines with a single empty line. +(@code{gnus-article-strip-multiple-blank-lines}). + +@item W E t +@kindex W E t (Summary) +@findex gnus-article-remove-trailing-blank-lines +Remove all blank lines at the end of the article +(@code{gnus-article-remove-trailing-blank-lines}). + +@item W E a +@kindex W E a (Summary) +@findex gnus-article-strip-blank-lines +Do all the three commands above +(@code{gnus-article-strip-blank-lines}). + +@item W E s +@kindex W E s (Summary) +@findex gnus-article-strip-leading-space +Remove all white space from the beginning of all lines of the article +body (@code{gnus-article-strip-leading-space}). + +@end table + + +@node Article Buttons +@subsection Article Buttons +@cindex buttons + +People often include references to other stuff in articles, and it would +be nice if Gnus could just fetch whatever it is that people talk about +with the minimum of fuzz when you hit @kbd{RET} or use the middle mouse +button on these references. + +Gnus adds @dfn{buttons} to certain standard references by default: +Well-formed URLs, mail addresses and Message-IDs. This is controlled by +two variables, one that handles article bodies and one that handles +article heads: + +@table @code + +@item gnus-button-alist +@vindex gnus-button-alist +This is an alist where each entry has this form: + +@lisp +(REGEXP BUTTON-PAR USE-P FUNCTION DATA-PAR) +@end lisp + +@table @var + +@item regexp +All text that match this regular expression will be considered an +external reference. Here's a typical regexp that matches embedded URLs: +@samp{]*\\)>}. + +@item button-par +Gnus has to know which parts of the matches is to be highlighted. This +is a number that says what sub-expression of the regexp is to be +highlighted. If you want it all highlighted, you use 0 here. + +@item use-p +This form will be @code{eval}ed, and if the result is non-@code{nil}, +this is considered a match. This is useful if you want extra sifting to +avoid false matches. + +@item function +This function will be called when you click on this button. + +@item data-par +As with @var{button-par}, this is a sub-expression number, but this one +says which part of the match is to be sent as data to @var{function}. + +@end table + +So the full entry for buttonizing URLs is then + +@lisp +("]*\\)>" 0 t gnus-button-url 1) +@end lisp + +@item gnus-header-button-alist +@vindex gnus-header-button-alist +This is just like the other alist, except that it is applied to the +article head only, and that each entry has an additional element that is +used to say what headers to apply the buttonize coding to: + +@lisp +(HEADER REGEXP BUTTON-PAR USE-P FUNCTION DATA-PAR) +@end lisp + +@var{HEADER} is a regular expression. + +@item gnus-button-url-regexp +@vindex gnus-button-url-regexp +A regular expression that matches embedded URLs. It is used in the +default values of the variables above. + +@item gnus-article-button-face +@vindex gnus-article-button-face +Face used on buttons. + +@item gnus-article-mouse-face +@vindex gnus-article-mouse-face +Face used when the mouse cursor is over a button. + +@end table + + +@node Article Date +@subsection Article Date + +The date is most likely generated in some obscure timezone you've never +heard of, so it's quite nice to be able to find out what the time was +when the article was sent. + +@table @kbd + +@item W T u +@kindex W T u (Summary) +@findex gnus-article-date-ut +Display the date in UT (aka. GMT, aka ZULU) +(@code{gnus-article-date-ut}). + +@item W T l +@kindex W T l (Summary) +@findex gnus-article-date-local +Display the date in the local timezone (@code{gnus-article-date-local}). + +@item W T s +@kindex W T s (Summary) +@vindex gnus-article-time-format +@findex gnus-article-date-user +@findex format-time-string +Display the date using a user-defined format +(@code{gnus-article-date-user}). The format is specified by the +@code{gnus-article-time-format} variable, and is a string that's passed +to @code{format-time-string}. See the documentation of that variable +for a list of possible format specs. + +@item W T e +@kindex W T e (Summary) +@findex gnus-article-date-lapsed +Say how much time has elapsed between the article was posted and now +(@code{gnus-article-date-lapsed}). + +@item W T o +@kindex W T o (Summary) +@findex gnus-article-date-original +Display the original date (@code{gnus-article-date-original}). This can +be useful if you normally use some other conversion function and are +worried that it might be doing something totally wrong. Say, claiming +that the article was posted in 1854. Although something like that is +@emph{totally} impossible. Don't you trust me? *titter* + +@end table + + +@node Article Signature +@subsection Article Signature +@cindex signatures +@cindex article signature + +@vindex gnus-signature-separator +Each article is divided into two parts---the head and the body. The +body can be divided into a signature part and a text part. The variable +that says what is to be considered a signature is +@code{gnus-signature-separator}. This is normally the standard +@samp{^-- $} as mandated by son-of-RFC 1036. However, many people use +non-standard signature separators, so this variable can also be a list +of regular expressions to be tested, one by one. (Searches are done +from the end of the body towards the beginning.) One likely value is: + +@lisp +(setq gnus-signature-separator + '("^-- $" ; The standard + "^-- *$" ; A common mangling + "^-------*$" ; Many people just use a looong + ; line of dashes. Shame! + "^ *--------*$" ; Double-shame! + "^________*$" ; Underscores are also popular + "^========*$")) ; Pervert! +@end lisp + +The more permissive you are, the more likely it is that you'll get false +positives. + +@vindex gnus-signature-limit +@code{gnus-signature-limit} provides a limit to what is considered a +signature. + +@enumerate +@item +If it is an integer, no signature may be longer (in characters) than +that integer. +@item +If it is a floating point number, no signature may be longer (in lines) +than that number. +@item +If it is a function, the function will be called without any parameters, +and if it returns @code{nil}, there is no signature in the buffer. +@item +If it is a string, it will be used as a regexp. If it matches, the text +in question is not a signature. +@end enumerate + +This variable can also be a list where the elements may be of the types +listed above. Here's an example: + +@lisp +(setq gnus-signature-limit + '(200.0 "^---*Forwarded article")) +@end lisp + +This means that if there are more than 200 lines after the signature +separator, or the text after the signature separator is matched by +the regular expression @samp{^---*Forwarded article}, then it isn't a +signature after all. + + +@node Article Commands +@section Article Commands + +@table @kbd + +@item A P +@cindex PostScript +@cindex printing +@kindex A P (Summary) +@vindex gnus-ps-print-hook +@findex gnus-summary-print-article +Generate and print a PostScript image of the article buffer +(@code{gnus-summary-print-article}). @code{gnus-ps-print-hook} will be +run just before printing the buffer. + +@end table + + +@node Summary Sorting +@section Summary Sorting +@cindex summary sorting + +You can have the summary buffer sorted in various ways, even though I +can't really see why you'd want that. + +@table @kbd + +@item C-c C-s C-n +@kindex C-c C-s C-n (Summary) +@findex gnus-summary-sort-by-number +Sort by article number (@code{gnus-summary-sort-by-number}). + +@item C-c C-s C-a +@kindex C-c C-s C-a (Summary) +@findex gnus-summary-sort-by-author +Sort by author (@code{gnus-summary-sort-by-author}). + +@item C-c C-s C-s +@kindex C-c C-s C-s (Summary) +@findex gnus-summary-sort-by-subject +Sort by subject (@code{gnus-summary-sort-by-subject}). + +@item C-c C-s C-d +@kindex C-c C-s C-d (Summary) +@findex gnus-summary-sort-by-date +Sort by date (@code{gnus-summary-sort-by-date}). + +@item C-c C-s C-l +@kindex C-c C-s C-l (Summary) +@findex gnus-summary-sort-by-lines +Sort by lines (@code{gnus-summary-sort-by-lines}). + +@item C-c C-s C-i +@kindex C-c C-s C-i (Summary) +@findex gnus-summary-sort-by-score +Sort by score (@code{gnus-summary-sort-by-score}). +@end table + +These functions will work both when you use threading and when you don't +use threading. In the latter case, all summary lines will be sorted, +line by line. In the former case, sorting will be done on a +root-by-root basis, which might not be what you were looking for. To +toggle whether to use threading, type @kbd{T T} (@pxref{Thread +Commands}). + + +@node Finding the Parent +@section Finding the Parent +@cindex parent articles +@cindex referring articles + +@table @kbd +@item ^ +@kindex ^ (Summary) +@findex gnus-summary-refer-parent-article +If you'd like to read the parent of the current article, and it is not +displayed in the summary buffer, you might still be able to. That is, +if the current group is fetched by @sc{nntp}, the parent hasn't expired +and the @code{References} in the current article are not mangled, you +can just press @kbd{^} or @kbd{A r} +(@code{gnus-summary-refer-parent-article}). If everything goes well, +you'll get the parent. If the parent is already displayed in the +summary buffer, point will just move to this article. + +If given a positive numerical prefix, fetch that many articles back into +the ancestry. If given a negative numerical prefix, fetch just that +ancestor. So if you say @kbd{3 ^}, Gnus will fetch the parent, the +grandparent and the grandgrandparent of the current article. If you say +@kbd{-3 ^}, Gnus will only fetch the grandgrandparent of the current +article. + +@item A R (Summary) +@findex gnus-summary-refer-references +@kindex A R (Summary) +Fetch all articles mentioned in the @code{References} header of the +article (@code{gnus-summary-refer-references}). + +@item A T (Summary) +@findex gnus-summary-refer-thread +@kindex A T (Summary) +Display the full thread where the current article appears +(@code{gnus-summary-refer-thread}). This command has to fetch all the +headers in the current group to work, so it usually takes a while. If +you do it often, you may consider setting @code{gnus-fetch-old-headers} +to @code{invisible} (@pxref{Filling In Threads}). This won't have any +visible effects normally, but it'll make this command work a whole lot +faster. Of course, it'll make group entry somewhat slow. + +@vindex gnus-refer-thread-limit +The @code{gnus-refer-thread-limit} variable says how many old (i. e., +articles before the first displayed in the current group) headers to +fetch when doing this command. The default is 200. If @code{t}, all +the available headers will be fetched. This variable can be overridden +by giving the @kbd{A T} command a numerical prefix. + +@item M-^ (Summary) +@findex gnus-summary-refer-article +@kindex M-^ (Summary) +@cindex Message-ID +@cindex fetching by Message-ID +You can also ask the @sc{nntp} server for an arbitrary article, no +matter what group it belongs to. @kbd{M-^} +(@code{gnus-summary-refer-article}) will ask you for a +@code{Message-ID}, which is one of those long, hard-to-read thingies +that look something like @samp{<38o6up$6f2@@hymir.ifi.uio.no>}. You +have to get it all exactly right. No fuzzy searches, I'm afraid. +@end table + +The current select method will be used when fetching by +@code{Message-ID} from non-news select method, but you can override this +by giving this command a prefix. + +@vindex gnus-refer-article-method +If the group you are reading is located on a backend that does not +support fetching by @code{Message-ID} very well (like @code{nnspool}), +you can set @code{gnus-refer-article-method} to an @sc{nntp} method. It +would, perhaps, be best if the @sc{nntp} server you consult is the one +updating the spool you are reading from, but that's not really +necessary. + +Most of the mail backends support fetching by @code{Message-ID}, but do +not do a particularly excellent job at it. That is, @code{nnmbox} and +@code{nnbabyl} are able to locate articles from any groups, while +@code{nnml} and @code{nnfolder} are only able to locate articles that +have been posted to the current group. (Anything else would be too time +consuming.) @code{nnmh} does not support this at all. + + +@node Alternative Approaches +@section Alternative Approaches + +Different people like to read news using different methods. This being +Gnus, we offer a small selection of minor modes for the summary buffers. + +@menu +* Pick and Read:: First mark articles and then read them. +* Binary Groups:: Auto-decode all articles. +@end menu + + +@node Pick and Read +@subsection Pick and Read +@cindex pick and read + +Some newsreaders (like @code{nn} and, uhm, @code{Netnews} on VM/CMS) use +a two-phased reading interface. The user first marks in a summary +buffer the articles she wants to read. Then she starts reading the +articles with just an article buffer displayed. + +@findex gnus-pick-mode +@kindex M-x gnus-pick-mode +Gnus provides a summary buffer minor mode that allows +this---@code{gnus-pick-mode}. This basically means that a few process +mark commands become one-keystroke commands to allow easy marking, and +it provides one additional command for switching to the summary buffer. + +Here are the available keystrokes when using pick mode: + +@table @kbd +@item . +@kindex . (Pick) +@findex gnus-summary-mark-as-processable +Pick the article on the current line +(@code{gnus-summary-mark-as-processable}). If given a numerical prefix, +go to that article and pick it. (The line number is normally displayed +at the beginning of the summary pick lines.) + +@item SPACE +@kindex SPACE (Pick) +@findex gnus-pick-next-page +Scroll the summary buffer up one page (@code{gnus-pick-next-page}). If +at the end of the buffer, start reading the picked articles. + +@item u +@kindex u (Pick) +@findex gnus-summary-unmark-as-processable +Unpick the article (@code{gnus-summary-unmark-as-processable}). + +@item U +@kindex U (Pick) +@findex gnus-summary-unmark-all-processable +Unpick all articles (@code{gnus-summary-unmark-all-processable}). + +@item t +@kindex t (Pick) +@findex gnus-uu-mark-thread +Pick the thread (@code{gnus-uu-mark-thread}). + +@item T +@kindex T (Pick) +@findex gnus-uu-unmark-thread +Unpick the thread (@code{gnus-uu-unmark-thread}). + +@item r +@kindex r (Pick) +@findex gnus-uu-mark-region +Pick the region (@code{gnus-uu-mark-region}). + +@item R +@kindex R (Pick) +@findex gnus-uu-unmark-region +Unpick the region (@code{gnus-uu-unmark-region}). + +@item e +@kindex e (Pick) +@findex gnus-uu-mark-by-regexp +Pick articles that match a regexp (@code{gnus-uu-mark-by-regexp}). + +@item E +@kindex E (Pick) +@findex gnus-uu-unmark-by-regexp +Unpick articles that match a regexp (@code{gnus-uu-unmark-by-regexp}). + +@item b +@kindex b (Pick) +@findex gnus-uu-mark-buffer +Pick the buffer (@code{gnus-uu-mark-buffer}). + +@item B +@kindex B (Pick) +@findex gnus-uu-unmark-buffer +Unpick the buffer (@code{gnus-uu-unmark-buffer}). + +@item RET +@kindex RET (Pick) +@findex gnus-pick-start-reading +@vindex gnus-pick-display-summary +Start reading the picked articles (@code{gnus-pick-start-reading}). If +given a prefix, mark all unpicked articles as read first. If +@code{gnus-pick-display-summary} is non-@code{nil}, the summary buffer +will still be visible when you are reading. + +@end table + +If this sounds like a good idea to you, you could say: + +@lisp +(add-hook 'gnus-summary-mode-hook 'gnus-pick-mode) +@end lisp + +@vindex gnus-pick-mode-hook +@code{gnus-pick-mode-hook} is run in pick minor mode buffers. + +@vindex gnus-mark-unpicked-articles-as-read +If @code{gnus-mark-unpicked-articles-as-read} is non-@code{nil}, mark +all unpicked articles as read. The default is @code{nil}. + +@vindex gnus-summary-pick-line-format +The summary line format in pick mode is slightly different from the +standard format. At the beginning of each line the line number is +displayed. The pick mode line format is controlled by the +@code{gnus-summary-pick-line-format} variable (@pxref{Formatting +Variables}). It accepts the same format specs that +@code{gnus-summary-line-format} does (@pxref{Summary Buffer Lines}). + + +@node Binary Groups +@subsection Binary Groups +@cindex binary groups + +@findex gnus-binary-mode +@kindex M-x gnus-binary-mode +If you spend much time in binary groups, you may grow tired of hitting +@kbd{X u}, @kbd{n}, @kbd{RET} all the time. @kbd{M-x gnus-binary-mode} +is a minor mode for summary buffers that makes all ordinary Gnus article +selection functions uudecode series of articles and display the result +instead of just displaying the articles the normal way. + +@kindex g (Binary) +@findex gnus-binary-show-article +The only way, in fact, to see the actual articles is the @kbd{g} +command, when you have turned on this mode +(@code{gnus-binary-show-article}). + +@vindex gnus-binary-mode-hook +@code{gnus-binary-mode-hook} is called in binary minor mode buffers. + + +@node Tree Display +@section Tree Display +@cindex trees + +@vindex gnus-use-trees +If you don't like the normal Gnus summary display, you might try setting +@code{gnus-use-trees} to @code{t}. This will create (by default) an +additional @dfn{tree buffer}. You can execute all summary mode commands +in the tree buffer. + +There are a few variables to customize the tree display, of course: + +@table @code +@item gnus-tree-mode-hook +@vindex gnus-tree-mode-hook +A hook called in all tree mode buffers. + +@item gnus-tree-mode-line-format +@vindex gnus-tree-mode-line-format +A format string for the mode bar in the tree mode buffers. The default +is @samp{Gnus: %%b [%A] %Z}. For a list of valid specs, @pxref{Summary +Buffer Mode Line}. + +@item gnus-selected-tree-face +@vindex gnus-selected-tree-face +Face used for highlighting the selected article in the tree buffer. The +default is @code{modeline}. + +@item gnus-tree-line-format +@vindex gnus-tree-line-format +A format string for the tree nodes. The name is a bit of a misnomer, +though---it doesn't define a line, but just the node. The default value +is @samp{%(%[%3,3n%]%)}, which displays the first three characters of +the name of the poster. It is vital that all nodes are of the same +length, so you @emph{must} use @samp{%4,4n}-like specifiers. + +Valid specs are: + +@table @samp +@item n +The name of the poster. +@item f +The @code{From} header. +@item N +The number of the article. +@item [ +The opening bracket. +@item ] +The closing bracket. +@item s +The subject. +@end table + +@xref{Formatting Variables}. + +Variables related to the display are: + +@table @code +@item gnus-tree-brackets +@vindex gnus-tree-brackets +This is used for differentiating between ``real'' articles and +``sparse'' articles. The format is @var{((real-open . real-close) +(sparse-open . sparse-close) (dummy-open . dummy-close))}, and the +default is @code{((?[ . ?]) (?( . ?)) (?@{ . ?@}))}. + +@item gnus-tree-parent-child-edges +@vindex gnus-tree-parent-child-edges +This is a list that contains the characters used for connecting parent +nodes to their children. The default is @code{(?- ?\\ ?|)}. + +@end table + +@item gnus-tree-minimize-window +@vindex gnus-tree-minimize-window +If this variable is non-@code{nil}, Gnus will try to keep the tree +buffer as small as possible to allow more room for the other Gnus +windows. If this variable is a number, the tree buffer will never be +higher than that number. The default is @code{t}. Note that if you +have several windows displayed side-by-side in a frame and the tree +buffer is one of these, minimizing the tree window will also resize all +other windows displayed next to it. + +@item gnus-generate-tree-function +@vindex gnus-generate-tree-function +@findex gnus-generate-horizontal-tree +@findex gnus-generate-vertical-tree +The function that actually generates the thread tree. Two predefined +functions are available: @code{gnus-generate-horizontal-tree} and +@code{gnus-generate-vertical-tree} (which is the default). + +@end table + +Here's an example from a horizontal tree buffer: + +@example +@{***@}-(***)-[odd]-[Gun] + | \[Jan] + | \[odd]-[Eri] + | \(***)-[Eri] + | \[odd]-[Paa] + \[Bjo] + \[Gun] + \[Gun]-[Jor] +@end example + +Here's the same thread displayed in a vertical tree buffer: + +@example +@{***@} + |--------------------------\-----\-----\ +(***) [Bjo] [Gun] [Gun] + |--\-----\-----\ | +[odd] [Jan] [odd] (***) [Jor] + | | |--\ +[Gun] [Eri] [Eri] [odd] + | + [Paa] +@end example + +If you're using horizontal trees, it might be nice to display the trees +side-by-side with the summary buffer. You could add something like the +following to your @file{.gnus.el} file: + +@lisp +(setq gnus-use-trees t + gnus-generate-tree-function 'gnus-generate-horizontal-tree + gnus-tree-minimize-window nil) +(gnus-add-configuration + '(article + (vertical 1.0 + (horizontal 0.25 + (summary 0.75 point) + (tree 1.0)) + (article 1.0)))) +@end lisp + +@xref{Windows Configuration}. + + +@node Mail Group Commands +@section Mail Group Commands +@cindex mail group commands + +Some commands only make sense in mail groups. If these commands are +invalid in the current group, they will raise a hell and let you know. + +All these commands (except the expiry and edit commands) use the +process/prefix convention (@pxref{Process/Prefix}). + +@table @kbd + +@item B e +@kindex B e (Summary) +@findex gnus-summary-expire-articles +Expire all expirable articles in the group +(@code{gnus-summary-expire-articles}). + +@item B M-C-e +@kindex B M-C-e (Summary) +@findex gnus-summary-expire-articles-now +Delete all the expirable articles in the group +(@code{gnus-summary-expire-articles-now}). This means that @strong{all} +articles eligible for expiry in the current group will +disappear forever into that big @file{/dev/null} in the sky. + +@item B DEL +@kindex B DEL (Summary) +@findex gnus-summary-delete-article +@c @icon{gnus-summary-mail-delete} +Delete the mail article. This is ``delete'' as in ``delete it from your +disk forever and ever, never to return again.'' Use with caution. +(@code{gnus-summary-delete-article}). + +@item B m +@kindex B m (Summary) +@cindex move mail +@findex gnus-summary-move-article +Move the article from one mail group to another +(@code{gnus-summary-move-article}). + +@item B c +@kindex B c (Summary) +@cindex copy mail +@findex gnus-summary-copy-article +@c @icon{gnus-summary-mail-copy} +Copy the article from one group (mail group or not) to a mail group +(@code{gnus-summary-copy-article}). + +@item B C +@kindex B C (Summary) +@cindex crosspost mail +@findex gnus-summary-crosspost-article +Crosspost the current article to some other group +(@code{gnus-summary-crosspost-article}). This will create a new copy of +the article in the other group, and the Xref headers of the article will +be properly updated. + +@item B i +@kindex B i (Summary) +@findex gnus-summary-import-article +Import an arbitrary file into the current mail newsgroup +(@code{gnus-summary-import-article}). You will be prompted for a file +name, a @code{From} header and a @code{Subject} header. + +@item B r +@kindex B r (Summary) +@findex gnus-summary-respool-article +Respool the mail article (@code{gnus-summary-move-article}). +@code{gnus-summary-respool-default-method} will be used as the default +select method when respooling. This variable is @code{nil} by default, +which means that the current group select method will be used instead. + +@item B w +@itemx e +@kindex B w (Summary) +@kindex e (Summary) +@findex gnus-summary-edit-article +@kindex C-c C-c (Article) +Edit the current article (@code{gnus-summary-edit-article}). To finish +editing and make the changes permanent, type @kbd{C-c C-c} +(@kbd{gnus-summary-edit-article-done}). If you give a prefix to the +@kbd{C-c C-c} command, Gnus won't re-highlight the article. + +@item B q +@kindex B q (Summary) +@findex gnus-summary-respool-query +If you want to re-spool an article, you might be curious as to what group +the article will end up in before you do the re-spooling. This command +will tell you (@code{gnus-summary-respool-query}). + +@item B p +@kindex B p (Summary) +@findex gnus-summary-article-posted-p +Some people have a tendency to send you "courtesy" copies when they +follow up to articles you have posted. These usually have a +@code{Newsgroups} header in them, but not always. This command +(@code{gnus-summary-article-posted-p}) will try to fetch the current +article from your news server (or rather, from +@code{gnus-refer-article-method} or @code{gnus-select-method}) and will +report back whether it found the article or not. Even if it says that +it didn't find the article, it may have been posted anyway---mail +propagation is much faster than news propagation, and the news copy may +just not have arrived yet. + +@end table + +@vindex gnus-move-split-methods +@cindex moving articles +If you move (or copy) articles regularly, you might wish to have Gnus +suggest where to put the articles. @code{gnus-move-split-methods} is a +variable that uses the same syntax as @code{gnus-split-methods} +(@pxref{Saving Articles}). You may customize that variable to create +suggestions you find reasonable. + +@lisp +(setq gnus-move-split-methods + '(("^From:.*Lars Magne" "nnml:junk") + ("^Subject:.*gnus" "nnfolder:important") + (".*" "nnml:misc"))) +@end lisp + + +@node Various Summary Stuff +@section Various Summary Stuff + +@menu +* Summary Group Information:: Information oriented commands. +* Searching for Articles:: Multiple article commands. +* Summary Generation Commands:: (Re)generating the summary buffer. +* Really Various Summary Commands:: Those pesky non-conformant commands. +@end menu + +@table @code +@vindex gnus-summary-mode-hook +@item gnus-summary-mode-hook +This hook is called when creating a summary mode buffer. + +@vindex gnus-summary-generate-hook +@item gnus-summary-generate-hook +This is called as the last thing before doing the threading and the +generation of the summary buffer. It's quite convenient for customizing +the threading variables based on what data the newsgroup has. This hook +is called from the summary buffer after most summary buffer variables +have been set. + +@vindex gnus-summary-prepare-hook +@item gnus-summary-prepare-hook +It is called after the summary buffer has been generated. You might use +it to, for instance, highlight lines or modify the look of the buffer in +some other ungodly manner. I don't care. + +@vindex gnus-summary-ignore-duplicates +@item gnus-summary-ignore-duplicates +When Gnus discovers two articles that have the same @code{Message-ID}, +it has to do something drastic. No articles are allowed to have the +same @code{Message-ID}, but this may happen when reading mail from some +sources. Gnus allows you to customize what happens with this variable. +If it is @code{nil} (which is the default), Gnus will rename the +@code{Message-ID} (for display purposes only) and display the article as +any other article. If this variable is @code{t}, it won't display the +article---it'll be as if it never existed. + +@end table + + +@node Summary Group Information +@subsection Summary Group Information + +@table @kbd + +@item H f +@kindex H f (Summary) +@findex gnus-summary-fetch-faq +@vindex gnus-group-faq-directory +Try to fetch the FAQ (list of frequently asked questions) for the +current group (@code{gnus-summary-fetch-faq}). Gnus will try to get the +FAQ from @code{gnus-group-faq-directory}, which is usually a directory +on a remote machine. This variable can also be a list of directories. +In that case, giving a prefix to this command will allow you to choose +between the various sites. @code{ange-ftp} or @code{efs} will probably +be used for fetching the file. + +@item H d +@kindex H d (Summary) +@findex gnus-summary-describe-group +Give a brief description of the current group +(@code{gnus-summary-describe-group}). If given a prefix, force +rereading the description from the server. + +@item H h +@kindex H h (Summary) +@findex gnus-summary-describe-briefly +Give an extremely brief description of the most important summary +keystrokes (@code{gnus-summary-describe-briefly}). + +@item H i +@kindex H i (Summary) +@findex gnus-info-find-node +Go to the Gnus info node (@code{gnus-info-find-node}). +@end table + + +@node Searching for Articles +@subsection Searching for Articles + +@table @kbd + +@item M-s +@kindex M-s (Summary) +@findex gnus-summary-search-article-forward +Search through all subsequent articles for a regexp +(@code{gnus-summary-search-article-forward}). + +@item M-r +@kindex M-r (Summary) +@findex gnus-summary-search-article-backward +Search through all previous articles for a regexp +(@code{gnus-summary-search-article-backward}). + +@item & +@kindex & (Summary) +@findex gnus-summary-execute-command +This command will prompt you for a header field, a regular expression to +match on this field, and a command to be executed if the match is made +(@code{gnus-summary-execute-command}). If given a prefix, search +backward instead. + +@item M-& +@kindex M-& (Summary) +@findex gnus-summary-universal-argument +Perform any operation on all articles that have been marked with +the process mark (@code{gnus-summary-universal-argument}). +@end table + +@node Summary Generation Commands +@subsection Summary Generation Commands + +@table @kbd + +@item Y g +@kindex Y g (Summary) +@findex gnus-summary-prepare +Regenerate the current summary buffer (@code{gnus-summary-prepare}). + +@item Y c +@kindex Y c (Summary) +@findex gnus-summary-insert-cached-articles +Pull all cached articles (for the current group) into the summary buffer +(@code{gnus-summary-insert-cached-articles}). + +@end table + + +@node Really Various Summary Commands +@subsection Really Various Summary Commands + +@table @kbd + +@item C-d +@kindex C-d (Summary) +@findex gnus-summary-enter-digest-group +If the current article is a collection of other articles (for instance, +a digest), you might use this command to enter a group based on the that +article (@code{gnus-summary-enter-digest-group}). Gnus will try to +guess what article type is currently displayed unless you give a prefix +to this command, which forces a ``digest'' interpretation. Basically, +whenever you see a message that is a collection of other messages of +some format, you @kbd{C-d} and read these messages in a more convenient +fashion. + +@item M-C-d +@kindex M-C-d (Summary) +@findex gnus-summary-read-document +This command is very similar to the one above, but lets you gather +several documents into one biiig group +(@code{gnus-summary-read-document}). It does this by opening several +@code{nndoc} groups for each document, and then opening an +@code{nnvirtual} group on top of these @code{nndoc} groups. This +command understands the process/prefix convention +(@pxref{Process/Prefix}). + +@item C-t +@kindex C-t (Summary) +@findex gnus-summary-toggle-truncation +Toggle truncation of summary lines +(@code{gnus-summary-toggle-truncation}). This will probably confuse the +line centering function in the summary buffer, so it's not a good idea +to have truncation switched off while reading articles. + +@item = +@kindex = (Summary) +@findex gnus-summary-expand-window +Expand the summary buffer window (@code{gnus-summary-expand-window}). +If given a prefix, force an @code{article} window configuration. + +@end table + + +@node Exiting the Summary Buffer +@section Exiting the Summary Buffer +@cindex summary exit +@cindex exiting groups + +Exiting from the summary buffer will normally update all info on the +group and return you to the group buffer. + +@table @kbd + +@item Z Z +@itemx q +@kindex Z Z (Summary) +@kindex q (Summary) +@findex gnus-summary-exit +@vindex gnus-summary-exit-hook +@vindex gnus-summary-prepare-exit-hook +@c @icon{gnus-summary-exit} +Exit the current group and update all information on the group +(@code{gnus-summary-exit}). @code{gnus-summary-prepare-exit-hook} is +called before doing much of the exiting, which calls +@code{gnus-summary-expire-articles} by default. +@code{gnus-summary-exit-hook} is called after finishing the exit +process. @code{gnus-group-no-more-groups-hook} is run when returning to +group mode having no more (unread) groups. + +@item Z E +@itemx Q +@kindex Z E (Summary) +@kindex Q (Summary) +@findex gnus-summary-exit-no-update +Exit the current group without updating any information on the group +(@code{gnus-summary-exit-no-update}). + +@item Z c +@itemx c +@kindex Z c (Summary) +@kindex c (Summary) +@findex gnus-summary-catchup-and-exit +@c @icon{gnus-summary-catchup-and-exit} +Mark all unticked articles in the group as read and then exit +(@code{gnus-summary-catchup-and-exit}). + +@item Z C +@kindex Z C (Summary) +@findex gnus-summary-catchup-all-and-exit +Mark all articles, even the ticked ones, as read and then exit +(@code{gnus-summary-catchup-all-and-exit}). + +@item Z n +@kindex Z n (Summary) +@findex gnus-summary-catchup-and-goto-next-group +Mark all articles as read and go to the next group +(@code{gnus-summary-catchup-and-goto-next-group}). + +@item Z R +@kindex Z R (Summary) +@findex gnus-summary-reselect-current-group +Exit this group, and then enter it again +(@code{gnus-summary-reselect-current-group}). If given a prefix, select +all articles, both read and unread. + +@item Z G +@itemx M-g +@kindex Z G (Summary) +@kindex M-g (Summary) +@findex gnus-summary-rescan-group +@c @icon{gnus-summary-mail-get} +Exit the group, check for new articles in the group, and select the +group (@code{gnus-summary-rescan-group}). If given a prefix, select all +articles, both read and unread. + +@item Z N +@kindex Z N (Summary) +@findex gnus-summary-next-group +Exit the group and go to the next group +(@code{gnus-summary-next-group}). + +@item Z P +@kindex Z P (Summary) +@findex gnus-summary-prev-group +Exit the group and go to the previous group +(@code{gnus-summary-prev-group}). + +@item Z s +@kindex Z s (Summary) +@findex gnus-summary-save-newsrc +Save the current number of read/marked articles in the dribble buffer +and then save the dribble buffer (@code{gnus-summary-save-newsrc}). If +given a prefix, also save the @file{.newsrc} file(s). Using this +command will make exit without updating (the @kbd{Q} command) worthless. +@end table + +@vindex gnus-exit-group-hook +@code{gnus-exit-group-hook} is called when you exit the current +group. + +@findex gnus-summary-wake-up-the-dead +@findex gnus-dead-summary-mode +@vindex gnus-kill-summary-on-exit +If you're in the habit of exiting groups, and then changing your mind +about it, you might set @code{gnus-kill-summary-on-exit} to @code{nil}. +If you do that, Gnus won't kill the summary buffer when you exit it. +(Quelle surprise!) Instead it will change the name of the buffer to +something like @samp{*Dead Summary ... *} and install a minor mode +called @code{gnus-dead-summary-mode}. Now, if you switch back to this +buffer, you'll find that all keys are mapped to a function called +@code{gnus-summary-wake-up-the-dead}. So tapping any keys in a dead +summary buffer will result in a live, normal summary buffer. + +There will never be more than one dead summary buffer at any one time. + +@vindex gnus-use-cross-reference +The data on the current group will be updated (which articles you have +read, which articles you have replied to, etc.) when you exit the +summary buffer. If the @code{gnus-use-cross-reference} variable is +@code{t} (which is the default), articles that are cross-referenced to +this group and are marked as read, will also be marked as read in the +other subscribed groups they were cross-posted to. If this variable is +neither @code{nil} nor @code{t}, the article will be marked as read in +both subscribed and unsubscribed groups (@pxref{Crosspost Handling}). + + +@node Crosspost Handling +@section Crosspost Handling + +@cindex velveeta +@cindex spamming +Marking cross-posted articles as read ensures that you'll never have to +read the same article more than once. Unless, of course, somebody has +posted it to several groups separately. Posting the same article to +several groups (not cross-posting) is called @dfn{spamming}, and you are +by law required to send nasty-grams to anyone who perpetrates such a +heinous crime. You may want to try NoCeM handling to filter out spam +(@pxref{NoCeM}). + +Remember: Cross-posting is kinda ok, but posting the same article +separately to several groups is not. Massive cross-posting (aka. +@dfn{velveeta}) is to be avoided at all costs, and you can even use the +@code{gnus-summary-mail-crosspost-complaint} command to complain about +excessive crossposting (@pxref{Summary Mail Commands}). + +@cindex cross-posting +@cindex Xref +@cindex @sc{nov} +One thing that may cause Gnus to not do the cross-posting thing +correctly is if you use an @sc{nntp} server that supports @sc{xover} +(which is very nice, because it speeds things up considerably) which +does not include the @code{Xref} header in its @sc{nov} lines. This is +Evil, but all too common, alas, alack. Gnus tries to Do The Right Thing +even with @sc{xover} by registering the @code{Xref} lines of all +articles you actually read, but if you kill the articles, or just mark +them as read without reading them, Gnus will not get a chance to snoop +the @code{Xref} lines out of these articles, and will be unable to use +the cross reference mechanism. + +@cindex LIST overview.fmt +@cindex overview.fmt +To check whether your @sc{nntp} server includes the @code{Xref} header +in its overview files, try @samp{telnet your.nntp.server nntp}, +@samp{MODE READER} on @code{inn} servers, and then say @samp{LIST +overview.fmt}. This may not work, but if it does, and the last line you +get does not read @samp{Xref:full}, then you should shout and whine at +your news admin until she includes the @code{Xref} header in the +overview files. + +@vindex gnus-nov-is-evil +If you want Gnus to get the @code{Xref}s right all the time, you have to +set @code{gnus-nov-is-evil} to @code{t}, which slows things down +considerably. + +C'est la vie. + +For an alternative approach, @pxref{Duplicate Suppression}. + + +@node Duplicate Suppression +@section Duplicate Suppression + +By default, Gnus tries to make sure that you don't have to read the same +article more than once by utilizing the crossposting mechanism +(@pxref{Crosspost Handling}). However, that simple and efficient +approach may not work satisfactory for some users for various +reasons. + +@enumerate +@item +The @sc{nntp} server may fail to generate the @code{Xref} header. This +is evil and not very common. + +@item +The @sc{nntp} server may fail to include the @code{Xref} header in the +@file{.overview} data bases. This is evil and all too common, alas. + +@item +You may be reading the same group (or several related groups) from +different @sc{nntp} servers. + +@item +You may be getting mail that duplicates articles posted to groups. +@end enumerate + +I'm sure there are other situations where @code{Xref} handling fails as +well, but these four are the most common situations. + +If, and only if, @code{Xref} handling fails for you, then you may +consider switching on @dfn{duplicate suppression}. If you do so, Gnus +will remember the @code{Message-ID}s of all articles you have read or +otherwise marked as read, and then, as if by magic, mark them as read +all subsequent times you see them---in @emph{all} groups. Using this +mechanism is quite likely to be somewhat inefficient, but not overly +so. It's certainly preferable to reading the same articles more than +once. + +Duplicate suppression is not a very subtle instrument. It's more like a +sledge hammer than anything else. It works in a very simple +fashion---if you have marked an article as read, it adds this Message-ID +to a cache. The next time it sees this Message-ID, it will mark the +article as read with the @samp{M} mark. It doesn't care what group it +saw the article in. + +@table @code +@item gnus-suppress-duplicates +@vindex gnus-suppress-duplicates +If non-@code{nil}, suppress duplicates. + +@item gnus-save-duplicate-list +@vindex gnus-save-duplicate-list +If non-@code{nil}, save the list of duplicates to a file. This will +make startup and shutdown take longer, so the default is @code{nil}. +However, this means that only duplicate articles read in a single Gnus +session are suppressed. + +@item gnus-duplicate-list-length +@vindex gnus-duplicate-list-length +This variable says how many @code{Message-ID}s to keep in the duplicate +suppression list. The default is 10000. + +@item gnus-duplicate-file +@vindex gnus-duplicate-file +The name of the file to store the duplicate suppression list in. The +default is @file{~/News/suppression}. +@end table + +If you have a tendency to stop and start Gnus often, setting +@code{gnus-save-duplicate-list} to @code{t} is probably a good idea. If +you leave Gnus running for weeks on end, you may have it @code{nil}. On +the other hand, saving the list makes startup and shutdown much slower, +so that means that if you stop and start Gnus often, you should set +@code{gnus-save-duplicate-list} to @code{nil}. Uhm. I'll leave this up +to you to figure out, I think. + + +@node The Article Buffer +@chapter The Article Buffer +@cindex article buffer + +The articles are displayed in the article buffer, of which there is only +one. All the summary buffers share the same article buffer unless you +tell Gnus otherwise. + +@menu +* Hiding Headers:: Deciding what headers should be displayed. +* Using MIME:: Pushing articles through @sc{mime} before reading them. +* Customizing Articles:: Tailoring the look of the articles. +* Article Keymap:: Keystrokes available in the article buffer. +* Misc Article:: Other stuff. +@end menu + + +@node Hiding Headers +@section Hiding Headers +@cindex hiding headers +@cindex deleting headers + +The top section of each article is the @dfn{head}. (The rest is the +@dfn{body}, but you may have guessed that already.) + +@vindex gnus-show-all-headers +There is a lot of useful information in the head: the name of the person +who wrote the article, the date it was written and the subject of the +article. That's well and nice, but there's also lots of information +most people do not want to see---what systems the article has passed +through before reaching you, the @code{Message-ID}, the +@code{References}, etc. ad nauseum---and you'll probably want to get rid +of some of those lines. If you want to keep all those lines in the +article buffer, you can set @code{gnus-show-all-headers} to @code{t}. + +Gnus provides you with two variables for sifting headers: + +@table @code + +@item gnus-visible-headers +@vindex gnus-visible-headers +If this variable is non-@code{nil}, it should be a regular expression +that says what headers you wish to keep in the article buffer. All +headers that do not match this variable will be hidden. + +For instance, if you only want to see the name of the person who wrote +the article and the subject, you'd say: + +@lisp +(setq gnus-visible-headers "^From:\\|^Subject:") +@end lisp + +This variable can also be a list of regexps to match headers to +remain visible. + +@item gnus-ignored-headers +@vindex gnus-ignored-headers +This variable is the reverse of @code{gnus-visible-headers}. If this +variable is set (and @code{gnus-visible-headers} is @code{nil}), it +should be a regular expression that matches all lines that you want to +hide. All lines that do not match this variable will remain visible. + +For instance, if you just want to get rid of the @code{References} line +and the @code{Xref} line, you might say: + +@lisp +(setq gnus-ignored-headers "^References:\\|^Xref:") +@end lisp + +This variable can also be a list of regexps to match headers to +be removed. + +Note that if @code{gnus-visible-headers} is non-@code{nil}, this +variable will have no effect. + +@end table + +@vindex gnus-sorted-header-list +Gnus can also sort the headers for you. (It does this by default.) You +can control the sorting by setting the @code{gnus-sorted-header-list} +variable. It is a list of regular expressions that says in what order +the headers are to be displayed. + +For instance, if you want the name of the author of the article first, +and then the subject, you might say something like: + +@lisp +(setq gnus-sorted-header-list '("^From:" "^Subject:")) +@end lisp + +Any headers that are to remain visible, but are not listed in this +variable, will be displayed in random order after all the headers listed in this variable. + +@findex gnus-article-hide-boring-headers +@vindex gnus-article-display-hook +@vindex gnus-boring-article-headers +You can hide further boring headers by entering +@code{gnus-article-hide-boring-headers} into +@code{gnus-article-display-hook}. What this function does depends on +the @code{gnus-boring-article-headers} variable. It's a list, but this +list doesn't actually contain header names. Instead is lists various +@dfn{boring conditions} that Gnus can check and remove from sight. + +These conditions are: +@table @code +@item empty +Remove all empty headers. +@item newsgroups +Remove the @code{Newsgroups} header if it only contains the current group +name. +@item followup-to +Remove the @code{Followup-To} header if it is identical to the +@code{Newsgroups} header. +@item reply-to +Remove the @code{Reply-To} header if it lists the same address as the +@code{From} header. +@item date +Remove the @code{Date} header if the article is less than three days +old. +@item long-to +Remove the @code{To} header if it is very long. +@end table + +To include the four first elements, you could say something like; + +@lisp +(setq gnus-boring-article-headers + '(empty newsgroups followup-to reply-to)) +@end lisp + +This is also the default value for this variable. + + +@node Using MIME +@section Using @sc{mime} +@cindex @sc{mime} + +Mime is a standard for waving your hands through the air, aimlessly, +while people stand around yawning. + +@sc{mime}, however, is a standard for encoding your articles, aimlessly, +while all newsreaders die of fear. + +@sc{mime} may specify what character set the article uses, the encoding +of the characters, and it also makes it possible to embed pictures and +other naughty stuff in innocent-looking articles. + +@vindex gnus-show-mime +@vindex gnus-show-mime-method +@vindex gnus-strict-mime +@findex metamail-buffer +Gnus handles @sc{mime} by pushing the articles through +@code{gnus-show-mime-method}, which is @code{metamail-buffer} by +default. Set @code{gnus-show-mime} to @code{t} if you want to use +@sc{mime} all the time. However, if @code{gnus-strict-mime} is +non-@code{nil}, the @sc{mime} method will only be used if there are +@sc{mime} headers in the article. If you have @code{gnus-show-mime} +set, then you'll see some unfortunate display glitches in the article +buffer. These can't be avoided. + +It might be best to just use the toggling functions from the summary +buffer to avoid getting nasty surprises. (For instance, you enter the +group @samp{alt.sing-a-long} and, before you know it, @sc{mime} has +decoded the sound file in the article and some horrible sing-a-long song +comes screaming out your speakers, and you can't find the volume +button, because there isn't one, and people are starting to look at you, +and you try to stop the program, but you can't, and you can't find the +program to control the volume, and everybody else in the room suddenly +decides to look at you disdainfully, and you'll feel rather stupid.) + +Any similarity to real events and people is purely coincidental. Ahem. + + +@node Customizing Articles +@section Customizing Articles +@cindex article customization + +@vindex gnus-article-display-hook +The @code{gnus-article-display-hook} is called after the article has +been inserted into the article buffer. It is meant to handle all +treatment of the article before it is displayed. + +@findex gnus-article-maybe-highlight +By default this hook just contains @code{gnus-article-hide-headers}, +@code{gnus-article-treat-overstrike}, and +@code{gnus-article-maybe-highlight}, but there are thousands, nay +millions, of functions you can put in this hook. For an overview of +functions @pxref{Article Highlighting}, @pxref{Article Hiding}, +@pxref{Article Washing}, @pxref{Article Buttons} and @pxref{Article +Date}. Note that the order of functions in this hook might affect +things, so you may have to fiddle a bit to get the desired results. + +You can, of course, write your own functions. The functions are called +from the article buffer, and you can do anything you like, pretty much. +There is no information that you have to keep in the buffer---you can +change everything. However, you shouldn't delete any headers. Instead +make them invisible if you want to make them go away. + + +@node Article Keymap +@section Article Keymap + +Most of the keystrokes in the summary buffer can also be used in the +article buffer. They should behave as if you typed them in the summary +buffer, which means that you don't actually have to have a summary +buffer displayed while reading. You can do it all from the article +buffer. + +A few additional keystrokes are available: + +@table @kbd + +@item SPACE +@kindex SPACE (Article) +@findex gnus-article-next-page +Scroll forwards one page (@code{gnus-article-next-page}). + +@item DEL +@kindex DEL (Article) +@findex gnus-article-prev-page +Scroll backwards one page (@code{gnus-article-prev-page}). + +@item C-c ^ +@kindex C-c ^ (Article) +@findex gnus-article-refer-article +If point is in the neighborhood of a @code{Message-ID} and you press +@kbd{r}, Gnus will try to get that article from the server +(@code{gnus-article-refer-article}). + +@item C-c C-m +@kindex C-c C-m (Article) +@findex gnus-article-mail +Send a reply to the address near point (@code{gnus-article-mail}). If +given a prefix, include the mail. + +@item s +@kindex s (Article) +@findex gnus-article-show-summary +Reconfigure the buffers so that the summary buffer becomes visible +(@code{gnus-article-show-summary}). + +@item ? +@kindex ? (Article) +@findex gnus-article-describe-briefly +Give a very brief description of the available keystrokes +(@code{gnus-article-describe-briefly}). + +@item TAB +@kindex TAB (Article) +@findex gnus-article-next-button +Go to the next button, if any (@code{gnus-article-next-button}). This +only makes sense if you have buttonizing turned on. + +@item M-TAB +@kindex M-TAB (Article) +@findex gnus-article-prev-button +Go to the previous button, if any (@code{gnus-article-prev-button}). + +@end table + + +@node Misc Article +@section Misc Article + +@table @code + +@item gnus-single-article-buffer +@vindex gnus-single-article-buffer +If non-@code{nil}, use the same article buffer for all the groups. +(This is the default.) If @code{nil}, each group will have its own +article buffer. + +@vindex gnus-article-prepare-hook +@item gnus-article-prepare-hook +This hook is called right after the article has been inserted into the +article buffer. It is mainly intended for functions that do something +depending on the contents; it should probably not be used for changing +the contents of the article buffer. + +@vindex gnus-article-display-hook +@item gnus-article-display-hook +This hook is called as the last thing when displaying an article, and is +intended for modifying the contents of the buffer, doing highlights, +hiding headers, and the like. + +@item gnus-article-mode-hook +@vindex gnus-article-mode-hook +Hook called in article mode buffers. + +@item gnus-article-mode-syntax-table +@vindex gnus-article-mode-syntax-table +Syntax table used in article buffers. It is initialized from +@code{text-mode-syntax-table}. + +@vindex gnus-article-mode-line-format +@item gnus-article-mode-line-format +This variable is a format string along the same lines as +@code{gnus-summary-mode-line-format}. It accepts the same +format specifications as that variable, with one extension: + +@table @samp +@item w +The @dfn{wash status} of the article. This is a short string with one +character for each possible article wash operation that may have been +performed. +@end table + +@vindex gnus-break-pages + +@item gnus-break-pages +Controls whether @dfn{page breaking} is to take place. If this variable +is non-@code{nil}, the articles will be divided into pages whenever a +page delimiter appears in the article. If this variable is @code{nil}, +paging will not be done. + +@item gnus-page-delimiter +@vindex gnus-page-delimiter +This is the delimiter mentioned above. By default, it is @samp{^L} +(formfeed). +@end table + + +@node Composing Messages +@chapter Composing Messages +@cindex reply +@cindex followup +@cindex post + +@kindex C-c C-c (Post) +All commands for posting and mailing will put you in a message buffer +where you can edit the article all you like, before you send the article +by pressing @kbd{C-c C-c}. @xref{Top, , Top, message, The Message +Manual}. If you are in a foreign news group, and you wish to post the +article using the foreign server, you can give a prefix to @kbd{C-c C-c} +to make Gnus try to post using the foreign server. + +@menu +* Mail:: Mailing and replying. +* Post:: Posting and following up. +* Posting Server:: What server should you post via? +* Mail and Post:: Mailing and posting at the same time. +* Archived Messages:: Where Gnus stores the messages you've sent. +* Drafts:: Postponing messages and rejected messages. +* Rejected Articles:: What happens if the server doesn't like your article? +@end menu + +Also see @pxref{Canceling and Superseding} for information on how to +remove articles you shouldn't have posted. + + +@node Mail +@section Mail + +Variables for customizing outgoing mail: + +@table @code +@item gnus-uu-digest-headers +@vindex gnus-uu-digest-headers +List of regexps to match headers included in digested messages. The +headers will be included in the sequence they are matched. + +@item gnus-add-to-list +@vindex gnus-add-to-list +If non-@code{nil}, add a @code{to-list} group parameter to mail groups +that have none when you do a @kbd{a}. + +@end table + + +@node Post +@section Post + +Variables for composing news articles: + +@table @code +@item gnus-sent-message-ids-file +@vindex gnus-sent-message-ids-file +Gnus will keep a @code{Message-ID} history file of all the mails it has +sent. If it discovers that it has already sent a mail, it will ask the +user whether to re-send the mail. (This is primarily useful when +dealing with @sc{soup} packets and the like where one is apt to send the +same packet multiple times.) This variable says what the name of this +history file is. It is @file{~/News/Sent-Message-IDs} by default. Set +this variable to @code{nil} if you don't want Gnus to keep a history +file. + +@item gnus-sent-message-ids-length +@vindex gnus-sent-message-ids-length +This variable says how many @code{Message-ID}s to keep in the history +file. It is 1000 by default. + +@end table + + +@node Posting Server +@section Posting Server + +When you press those magical @kbd{C-c C-c} keys to ship off your latest +(extremely intelligent, of course) article, where does it go? + +Thank you for asking. I hate you. + +@vindex gnus-post-method + +It can be quite complicated. Normally, Gnus will use the same native +server. However. If your native server doesn't allow posting, just +reading, you probably want to use some other server to post your +(extremely intelligent and fabulously interesting) articles. You can +then set the @code{gnus-post-method} to some other method: + +@lisp +(setq gnus-post-method '(nnspool "")) +@end lisp + +Now, if you've done this, and then this server rejects your article, or +this server is down, what do you do then? To override this variable you +can use a non-zero prefix to the @kbd{C-c C-c} command to force using +the ``current'' server for posting. + +If you give a zero prefix (i.e., @kbd{C-u 0 C-c C-c}) to that command, +Gnus will prompt you for what method to use for posting. + +You can also set @code{gnus-post-method} to a list of select methods. +If that's the case, Gnus will always prompt you for what method to use +for posting. + + +@node Mail and Post +@section Mail and Post + +Here's a list of variables relevant to both mailing and +posting: + +@table @code +@item gnus-mailing-list-groups +@findex gnus-mailing-list-groups +@cindex mailing lists + +If your news server offers groups that are really mailing lists +gatewayed to the @sc{nntp} server, you can read those groups without +problems, but you can't post/followup to them without some difficulty. +One solution is to add a @code{to-address} to the group parameters +(@pxref{Group Parameters}). An easier thing to do is set the +@code{gnus-mailing-list-groups} to a regexp that matches the groups that +really are mailing lists. Then, at least, followups to the mailing +lists will work most of the time. Posting to these groups (@kbd{a}) is +still a pain, though. + +@end table + +You may want to do spell-checking on messages that you send out. Or, if +you don't want to spell-check by hand, you could add automatic +spell-checking via the @code{ispell} package: + +@cindex ispell +@findex ispell-message +@lisp +(add-hook 'message-send-hook 'ispell-message) +@end lisp + + +@node Archived Messages +@section Archived Messages +@cindex archived messages +@cindex sent messages + +Gnus provides a few different methods for storing the mail and news you +send. The default method is to use the @dfn{archive virtual server} to +store the messages. If you want to disable this completely, the +@code{gnus-message-archive-group} variable should be @code{nil}, which +is the default. + +@vindex gnus-message-archive-method +@code{gnus-message-archive-method} says what virtual server Gnus is to +use to store sent messages. The default is: + +@lisp +(nnfolder "archive" + (nnfolder-directory "~/Mail/archive/")) +@end lisp + +You can, however, use any mail select method (@code{nnml}, +@code{nnmbox}, etc.). @code{nnfolder} is a quite likeable select method +for doing this sort of thing, though. If you don't like the default +directory chosen, you could say something like: + +@lisp +(setq gnus-message-archive-method + '(nnfolder "archive" + (nnfolder-inhibit-expiry t) + (nnfolder-active-file "~/News/sent-mail/active") + (nnfolder-directory "~/News/sent-mail/"))) +@end lisp + +@vindex gnus-message-archive-group +@cindex Gcc +Gnus will insert @code{Gcc} headers in all outgoing messages that point +to one or more group(s) on that server. Which group to use is +determined by the @code{gnus-message-archive-group} variable. + +This variable can be used to do the following: + +@itemize @bullet +@item a string +Messages will be saved in that group. +@item a list of strings +Messages will be saved in all those groups. +@item an alist of regexps, functions and forms +When a key ``matches'', the result is used. +@item @code{nil} +No message archiving will take place. This is the default. +@end itemize + +Let's illustrate: + +Just saving to a single group called @samp{MisK}: +@lisp +(setq gnus-message-archive-group "MisK") +@end lisp + +Saving to two groups, @samp{MisK} and @samp{safe}: +@lisp +(setq gnus-message-archive-group '("MisK" "safe")) +@end lisp + +Save to different groups based on what group you are in: +@lisp +(setq gnus-message-archive-group + '(("^alt" "sent-to-alt") + ("mail" "sent-to-mail") + (".*" "sent-to-misc"))) +@end lisp + +More complex stuff: +@lisp +(setq gnus-message-archive-group + '((if (message-news-p) + "misc-news" + "misc-mail"))) +@end lisp + +How about storing all news messages in one file, but storing all mail +messages in one file per month: + +@lisp +(setq gnus-message-archive-group + '((if (message-news-p) + "misc-news" + (concat "mail." (format-time-string + "%Y-%m" (current-time)))))) +@end lisp + +(XEmacs 19.13 doesn't have @code{format-time-string}, so you'll have to +use a different value for @code{gnus-message-archive-group} there.) + +Now, when you send a message off, it will be stored in the appropriate +group. (If you want to disable storing for just one particular message, +you can just remove the @code{Gcc} header that has been inserted.) The +archive group will appear in the group buffer the next time you start +Gnus, or the next time you press @kbd{F} in the group buffer. You can +enter it and read the articles in it just like you'd read any other +group. If the group gets really big and annoying, you can simply rename +if (using @kbd{G r} in the group buffer) to something +nice---@samp{misc-mail-september-1995}, or whatever. New messages will +continue to be stored in the old (now empty) group. + +That's the default method of archiving sent messages. Gnus offers a +different way for the people who don't like the default method. In that +case you should set @code{gnus-message-archive-group} to @code{nil}; +this will disable archiving. + +@table @code +@item gnus-outgoing-message-group +@vindex gnus-outgoing-message-group +All outgoing messages will be put in this group. If you want to store +all your outgoing mail and articles in the group @samp{nnml:archive}, +you set this variable to that value. This variable can also be a list of +group names. + +If you want to have greater control over what group to put each +message in, you can set this variable to a function that checks the +current newsgroup name and then returns a suitable group name (or list +of names). + +This variable can be used instead of @code{gnus-message-archive-group}, +but the latter is the preferred method. +@end table + + +@c @node Posting Styles +@c @section Posting Styles +@c @cindex posting styles +@c @cindex styles +@c +@c All them variables, they make my head swim. +@c +@c So what if you want a different @code{Organization} and signature based +@c on what groups you post to? And you post both from your home machine +@c and your work machine, and you want different @code{From} lines, and so +@c on? +@c +@c @vindex gnus-posting-styles +@c One way to do stuff like that is to write clever hooks that change the +@c variables you need to have changed. That's a bit boring, so somebody +@c came up with the bright idea of letting the user specify these things in +@c a handy alist. Here's an example of a @code{gnus-posting-styles} +@c variable: +@c +@c @lisp +@c ((".*" +@c (signature . "Peace and happiness") +@c (organization . "What me?")) +@c ("^comp" +@c (signature . "Death to everybody")) +@c ("comp.emacs.i-love-it" +@c (organization . "Emacs is it"))) +@c @end lisp +@c +@c As you might surmise from this example, this alist consists of several +@c @dfn{styles}. Each style will be applicable if the first element +@c ``matches'', in some form or other. The entire alist will be iterated +@c over, from the beginning towards the end, and each match will be +@c applied, which means that attributes in later styles that match override +@c the same attributes in earlier matching styles. So +@c @samp{comp.programming.literate} will have the @samp{Death to everybody} +@c signature and the @samp{What me?} @code{Organization} header. +@c +@c The first element in each style is called the @code{match}. If it's a +@c string, then Gnus will try to regexp match it against the group name. +@c If it's a function symbol, that function will be called with no +@c arguments. If it's a variable symbol, then the variable will be +@c referenced. If it's a list, then that list will be @code{eval}ed. In +@c any case, if this returns a non-@code{nil} value, then the style is said +@c to @dfn{match}. +@c +@c Each style may contain a arbitrary amount of @dfn{attributes}. Each +@c attribute consists of a @var{(name . value)} pair. The attribute name +@c can be one of @code{signature}, @code{organization} or @code{from}. The +@c attribute name can also be a string. In that case, this will be used as +@c a header name, and the value will be inserted in the headers of the +@c article. +@c +@c The attribute value can be a string (used verbatim), a function (the +@c return value will be used), a variable (its value will be used) or a +@c list (it will be @code{eval}ed and the return value will be used). +@c +@c So here's a new example: +@c +@c @lisp +@c (setq gnus-posting-styles +@c '((".*" +@c (signature . "~/.signature") +@c (from . "user@@foo (user)") +@c ("X-Home-Page" . (getenv "WWW_HOME")) +@c (organization . "People's Front Against MWM")) +@c ("^rec.humor" +@c (signature . my-funny-signature-randomizer)) +@c ((equal (system-name) "gnarly") +@c (signature . my-quote-randomizer)) +@c (posting-from-work-p +@c (signature . "~/.work-signature") +@c (from . "user@@bar.foo (user)") +@c (organization . "Important Work, Inc")) +@c ("^nn.+:" +@c (signature . "~/.mail-signature")))) +@c @end lisp + +@node Drafts +@section Drafts +@cindex drafts + +If you are writing a message (mail or news) and suddenly remember that +you have a steak in the oven (or some pesto in the food processor, you +craaazy vegetarians), you'll probably wish there was a method to save +the message you are writing so that you can continue editing it some +other day, and send it when you feel its finished. + +Well, don't worry about it. Whenever you start composing a message of +some sort using the Gnus mail and post commands, the buffer you get will +automatically associate to an article in a special @dfn{draft} group. +If you save the buffer the normal way (@kbd{C-x C-s}, for instance), the +article will be saved there. (Auto-save files also go to the draft +group.) + +@cindex nndraft +@vindex nndraft-directory +The draft group is a special group (which is implemented as an +@code{nndraft} group, if you absolutely have to know) called +@samp{nndraft:drafts}. The variable @code{nndraft-directory} says where +@code{nndraft} is to store its files. What makes this group special is +that you can't tick any articles in it or mark any articles as +read---all articles in the group are permanently unread. + +If the group doesn't exist, it will be created and you'll be subscribed +to it. The only way to make it disappear from the Group buffer is to +unsubscribe it. + +@c @findex gnus-dissociate-buffer-from-draft +@c @kindex C-c M-d (Mail) +@c @kindex C-c M-d (Post) +@c @findex gnus-associate-buffer-with-draft +@c @kindex C-c C-d (Mail) +@c @kindex C-c C-d (Post) +@c If you're writing some super-secret message that you later want to +@c encode with PGP before sending, you may wish to turn the auto-saving +@c (and association with the draft group) off. You never know who might be +@c interested in reading all your extremely valuable and terribly horrible +@c and interesting secrets. The @kbd{C-c M-d} +@c (@code{gnus-dissociate-buffer-from-draft}) command does that for you. +@c If you change your mind and want to turn the auto-saving back on again, +@c @kbd{C-c C-d} (@code{gnus-associate-buffer-with-draft} does that. +@c +@c @vindex gnus-use-draft +@c To leave association with the draft group off by default, set +@c @code{gnus-use-draft} to @code{nil}. It is @code{t} by default. + +@findex gnus-draft-edit-message +@kindex D e (Draft) +When you want to continue editing the article, you simply enter the +draft group and push @kbd{D e} (@code{gnus-draft-edit-message}) to do +that. You will be placed in a buffer where you left off. + +Rejected articles will also be put in this draft group (@pxref{Rejected +Articles}). + +@findex gnus-draft-send-all-messages +@findex gnus-draft-send-message +If you have lots of rejected messages you want to post (or mail) without +doing further editing, you can use the @kbd{D s} command +(@code{gnus-draft-send-message}). This command understands the +process/prefix convention (@pxref{Process/Prefix}). The @kbd{D S} +command (@code{gnus-draft-send-all-messages}) will ship off all messages +in the buffer. + +If you have some messages that you wish not to send, you can use the +@kbd{D t} (@code{gnus-draft-toggle-sending}) command to mark the message +as unsendable. This is a toggling command. + + +@node Rejected Articles +@section Rejected Articles +@cindex rejected articles + +Sometimes a news server will reject an article. Perhaps the server +doesn't like your face. Perhaps it just feels miserable. Perhaps +@emph{there be demons}. Perhaps you have included too much cited text. +Perhaps the disk is full. Perhaps the server is down. + +These situations are, of course, totally beyond the control of Gnus. +(Gnus, of course, loves the way you look, always feels great, has angels +fluttering around inside of it, doesn't care about how much cited text +you include, never runs full and never goes down.) So Gnus saves these +articles until some later time when the server feels better. + +The rejected articles will automatically be put in a special draft group +(@pxref{Drafts}). When the server comes back up again, you'd then +typically enter that group and send all the articles off. + + +@node Select Methods +@chapter Select Methods +@cindex foreign groups +@cindex select methods + +A @dfn{foreign group} is a group not read by the usual (or +default) means. It could be, for instance, a group from a different +@sc{nntp} server, it could be a virtual group, or it could be your own +personal mail group. + +A foreign group (or any group, really) is specified by a @dfn{name} and +a @dfn{select method}. To take the latter first, a select method is a +list where the first element says what backend to use (e.g. @code{nntp}, +@code{nnspool}, @code{nnml}) and the second element is the @dfn{server +name}. There may be additional elements in the select method, where the +value may have special meaning for the backend in question. + +One could say that a select method defines a @dfn{virtual server}---so +we do just that (@pxref{The Server Buffer}). + +The @dfn{name} of the group is the name the backend will recognize the +group as. + +For instance, the group @samp{soc.motss} on the @sc{nntp} server +@samp{some.where.edu} will have the name @samp{soc.motss} and select +method @code{(nntp "some.where.edu")}. Gnus will call this group +@samp{nntp+some.where.edu:soc.motss}, even though the @code{nntp} +backend just knows this group as @samp{soc.motss}. + +The different methods all have their peculiarities, of course. + +@menu +* The Server Buffer:: Making and editing virtual servers. +* Getting News:: Reading USENET news with Gnus. +* Getting Mail:: Reading your personal mail with Gnus. +* Other Sources:: Reading directories, files, SOUP packets. +* Combined Groups:: Combining groups into one group. +* Gnus Unplugged:: Reading news and mail offline. +@end menu + + +@node The Server Buffer +@section The Server Buffer + +Traditionally, a @dfn{server} is a machine or a piece of software that +one connects to, and then requests information from. Gnus does not +connect directly to any real servers, but does all transactions through +one backend or other. But that's just putting one layer more between +the actual media and Gnus, so we might just as well say that each +backend represents a virtual server. + +For instance, the @code{nntp} backend may be used to connect to several +different actual @sc{nntp} servers, or, perhaps, to many different ports +on the same actual @sc{nntp} server. You tell Gnus which backend to +use, and what parameters to set by specifying a @dfn{select method}. + +These select method specifications can sometimes become quite +complicated---say, for instance, that you want to read from the +@sc{nntp} server @samp{news.funet.fi} on port number 13, which +hangs if queried for @sc{nov} headers and has a buggy select. Ahem. +Anyways, if you had to specify that for each group that used this +server, that would be too much work, so Gnus offers a way of naming +select methods, which is what you do in the server buffer. + +To enter the server buffer, use the @kbd{^} +(@code{gnus-group-enter-server-mode}) command in the group buffer. + +@menu +* Server Buffer Format:: You can customize the look of this buffer. +* Server Commands:: Commands to manipulate servers. +* Example Methods:: Examples server specifications. +* Creating a Virtual Server:: An example session. +* Server Variables:: Which variables to set. +* Servers and Methods:: You can use server names as select methods. +* Unavailable Servers:: Some servers you try to contact may be down. +@end menu + +@vindex gnus-server-mode-hook +@code{gnus-server-mode-hook} is run when creating the server buffer. + + +@node Server Buffer Format +@subsection Server Buffer Format +@cindex server buffer format + +@vindex gnus-server-line-format +You can change the look of the server buffer lines by changing the +@code{gnus-server-line-format} variable. This is a @code{format}-like +variable, with some simple extensions: + +@table @samp + +@item h +How the news is fetched---the backend name. + +@item n +The name of this server. + +@item w +Where the news is to be fetched from---the address. + +@item s +The opened/closed/denied status of the server. +@end table + +@vindex gnus-server-mode-line-format +The mode line can also be customized by using the +@code{gnus-server-mode-line-format} variable. The following specs are +understood: + +@table @samp +@item S +Server name. + +@item M +Server method. +@end table + +Also @pxref{Formatting Variables}. + + +@node Server Commands +@subsection Server Commands +@cindex server commands + +@table @kbd + +@item a +@kindex a (Server) +@findex gnus-server-add-server +Add a new server (@code{gnus-server-add-server}). + +@item e +@kindex e (Server) +@findex gnus-server-edit-server +Edit a server (@code{gnus-server-edit-server}). + +@item SPACE +@kindex SPACE (Server) +@findex gnus-server-read-server +Browse the current server (@code{gnus-server-read-server}). + +@item q +@kindex q (Server) +@findex gnus-server-exit +Return to the group buffer (@code{gnus-server-exit}). + +@item k +@kindex k (Server) +@findex gnus-server-kill-server +Kill the current server (@code{gnus-server-kill-server}). + +@item y +@kindex y (Server) +@findex gnus-server-yank-server +Yank the previously killed server (@code{gnus-server-yank-server}). + +@item c +@kindex c (Server) +@findex gnus-server-copy-server +Copy the current server (@code{gnus-server-copy-server}). + +@item l +@kindex l (Server) +@findex gnus-server-list-servers +List all servers (@code{gnus-server-list-servers}). + +@item s +@kindex s (Server) +@findex gnus-server-scan-server +Request that the server scan its sources for new articles +(@code{gnus-server-scan-server}). This is mainly sensible with mail +servers. + +@item g +@kindex g (Server) +@findex gnus-server-regenerate-server +Request that the server regenerate all its data structures +(@code{gnus-server-regenerate-server}). This can be useful if you have +a mail backend that has gotten out of synch. + +@end table + + +@node Example Methods +@subsection Example Methods + +Most select methods are pretty simple and self-explanatory: + +@lisp +(nntp "news.funet.fi") +@end lisp + +Reading directly from the spool is even simpler: + +@lisp +(nnspool "") +@end lisp + +As you can see, the first element in a select method is the name of the +backend, and the second is the @dfn{address}, or @dfn{name}, if you +will. + +After these two elements, there may be an arbitrary number of +@var{(variable form)} pairs. + +To go back to the first example---imagine that you want to read from +port 15 on that machine. This is what the select method should +look like then: + +@lisp +(nntp "news.funet.fi" (nntp-port-number 15)) +@end lisp + +You should read the documentation to each backend to find out what +variables are relevant, but here's an @code{nnmh} example: + +@code{nnmh} is a mail backend that reads a spool-like structure. Say +you have two structures that you wish to access: One is your private +mail spool, and the other is a public one. Here's the possible spec for +your private mail: + +@lisp +(nnmh "private" (nnmh-directory "~/private/mail/")) +@end lisp + +(This server is then called @samp{private}, but you may have guessed +that.) + +Here's the method for a public spool: + +@lisp +(nnmh "public" + (nnmh-directory "/usr/information/spool/") + (nnmh-get-new-mail nil)) +@end lisp + +If you are behind a firewall and only have access to the @sc{nntp} +server from the firewall machine, you can instruct Gnus to @code{rlogin} +on the firewall machine and telnet from there to the @sc{nntp} server. +Doing this can be rather fiddly, but your virtual server definition +should probably look something like this: + +@lisp +(nntp "firewall" + (nntp-address "the.firewall.machine") + (nntp-open-connection-function nntp-open-rlogin) + (nntp-end-of-line "\n") + (nntp-rlogin-parameters + ("telnet" "the.real.nntp.host" "nntp"))) +@end lisp + + + +@node Creating a Virtual Server +@subsection Creating a Virtual Server + +If you're saving lots of articles in the cache by using persistent +articles, you may want to create a virtual server to read the cache. + +First you need to add a new server. The @kbd{a} command does that. It +would probably be best to use @code{nnspool} to read the cache. You +could also use @code{nnml} or @code{nnmh}, though. + +Type @kbd{a nnspool RET cache RET}. + +You should now have a brand new @code{nnspool} virtual server called +@samp{cache}. You now need to edit it to have the right definitions. +Type @kbd{e} to edit the server. You'll be entered into a buffer that +will contain the following: + +@lisp +(nnspool "cache") +@end lisp + +Change that to: + +@lisp +(nnspool "cache" + (nnspool-spool-directory "~/News/cache/") + (nnspool-nov-directory "~/News/cache/") + (nnspool-active-file "~/News/cache/active")) +@end lisp + +Type @kbd{C-c C-c} to return to the server buffer. If you now press +@kbd{RET} over this virtual server, you should be entered into a browse +buffer, and you should be able to enter any of the groups displayed. + + +@node Server Variables +@subsection Server Variables + +One sticky point when defining variables (both on backends and in Emacs +in general) is that some variables are typically initialized from other +variables when the definition of the variables is being loaded. If you +change the "base" variable after the variables have been loaded, you +won't change the "derived" variables. + +This typically affects directory and file variables. For instance, +@code{nnml-directory} is @file{~/Mail/} by default, and all @code{nnml} +directory variables are initialized from that variable, so +@code{nnml-active-file} will be @file{~/Mail/active}. If you define a +new virtual @code{nnml} server, it will @emph{not} suffice to set just +@code{nnml-directory}---you have to explicitly set all the file +variables to be what you want them to be. For a complete list of +variables for each backend, see each backend's section later in this +manual, but here's an example @code{nnml} definition: + +@lisp +(nnml "public" + (nnml-directory "~/my-mail/") + (nnml-active-file "~/my-mail/active") + (nnml-newsgroups-file "~/my-mail/newsgroups")) +@end lisp + + +@node Servers and Methods +@subsection Servers and Methods + +Wherever you would normally use a select method +(e.g. @code{gnus-secondary-select-method}, in the group select method, +when browsing a foreign server) you can use a virtual server name +instead. This could potentially save lots of typing. And it's nice all +over. + + +@node Unavailable Servers +@subsection Unavailable Servers + +If a server seems to be unreachable, Gnus will mark that server as +@code{denied}. That means that any subsequent attempt to make contact +with that server will just be ignored. ``It can't be opened,'' Gnus +will tell you, without making the least effort to see whether that is +actually the case or not. + +That might seem quite naughty, but it does make sense most of the time. +Let's say you have 10 groups subscribed to on server +@samp{nephelococcygia.com}. This server is located somewhere quite far +away from you and the machine is quite slow, so it takes 1 minute just +to find out that it refuses connection to you today. If Gnus were to +attempt to do that 10 times, you'd be quite annoyed, so Gnus won't +attempt to do that. Once it has gotten a single ``connection refused'', +it will regard that server as ``down''. + +So, what happens if the machine was only feeling unwell temporarily? +How do you test to see whether the machine has come up again? + +You jump to the server buffer (@pxref{The Server Buffer}) and poke it +with the following commands: + +@table @kbd + +@item O +@kindex O (Server) +@findex gnus-server-open-server +Try to establish connection to the server on the current line +(@code{gnus-server-open-server}). + +@item C +@kindex C (Server) +@findex gnus-server-close-server +Close the connection (if any) to the server +(@code{gnus-server-close-server}). + +@item D +@kindex D (Server) +@findex gnus-server-deny-server +Mark the current server as unreachable +(@code{gnus-server-deny-server}). + +@item M-o +@kindex M-o (Server) +@findex gnus-server-open-all-servers +Open the connections to all servers in the buffer +(@code{gnus-server-open-all-servers}). + +@item M-c +@kindex M-c (Server) +@findex gnus-server-close-all-servers +Close the connections to all servers in the buffer +(@code{gnus-server-close-all-servers}). + +@item R +@kindex R (Server) +@findex gnus-server-remove-denials +Remove all marks to whether Gnus was denied connection from any servers +(@code{gnus-server-remove-denials}). + +@end table + + +@node Getting News +@section Getting News +@cindex reading news +@cindex news backends + +A newsreader is normally used for reading news. Gnus currently provides +only two methods of getting news---it can read from an @sc{nntp} server, +or it can read from a local spool. + +@menu +* NNTP:: Reading news from an @sc{nntp} server. +* News Spool:: Reading news from the local spool. +@end menu + + +@node NNTP +@subsection @sc{nntp} +@cindex nntp + +Subscribing to a foreign group from an @sc{nntp} server is rather easy. +You just specify @code{nntp} as method and the address of the @sc{nntp} +server as the, uhm, address. + +If the @sc{nntp} server is located at a non-standard port, setting the +third element of the select method to this port number should allow you +to connect to the right port. You'll have to edit the group info for +that (@pxref{Foreign Groups}). + +The name of the foreign group can be the same as a native group. In +fact, you can subscribe to the same group from as many different servers +you feel like. There will be no name collisions. + +The following variables can be used to create a virtual @code{nntp} +server: + +@table @code + +@item nntp-server-opened-hook +@vindex nntp-server-opened-hook +@cindex @sc{mode reader} +@cindex authinfo +@cindex authentification +@cindex nntp authentification +@findex nntp-send-authinfo +@findex nntp-send-mode-reader +is run after a connection has been made. It can be used to send +commands to the @sc{nntp} server after it has been contacted. By +default it sends the command @code{MODE READER} to the server with the +@code{nntp-send-mode-reader} function. This function should always be +present in this hook. + +@item nntp-authinfo-function +@vindex nntp-authinfo-function +This function will be used to send @samp{AUTHINFO} to the @sc{nntp} +server. Available functions include: + +@table @code +@item nntp-send-authinfo +@findex nntp-send-authinfo +This function will use your current login name as the user name and will +prompt you for the password. This is the default. + +@item nntp-send-nosy-authinfo +@findex nntp-send-nosy-authinfo +This function will prompt you for both user name and password. + +@item nntp-send-authinfo-from-file +@findex nntp-send-authinfo-from-file +This function will use your current login name as the user name and will +read the @sc{nntp} password from @file{~/.nntp-authinfo}. +@end table + +@item nntp-server-action-alist +@vindex nntp-server-action-alist +This is a list of regexps to match on server types and actions to be +taken when matches are made. For instance, if you want Gnus to beep +every time you connect to innd, you could say something like: + +@lisp +(setq nntp-server-action-alist + '(("innd" (ding)))) +@end lisp + +You probably don't want to do that, though. + +The default value is + +@lisp +'(("nntpd 1\\.5\\.11t" + (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))) +@end lisp + +This ensures that Gnus doesn't send the @code{MODE READER} command to +nntpd 1.5.11t, since that command chokes that server, I've been told. + +@item nntp-maximum-request +@vindex nntp-maximum-request +If the @sc{nntp} server doesn't support @sc{nov} headers, this backend +will collect headers by sending a series of @code{head} commands. To +speed things up, the backend sends lots of these commands without +waiting for reply, and then reads all the replies. This is controlled +by the @code{nntp-maximum-request} variable, and is 400 by default. If +your network is buggy, you should set this to 1. + +@item nntp-connection-timeout +@vindex nntp-connection-timeout +If you have lots of foreign @code{nntp} groups that you connect to +regularly, you're sure to have problems with @sc{nntp} servers not +responding properly, or being too loaded to reply within reasonable +time. This is can lead to awkward problems, which can be helped +somewhat by setting @code{nntp-connection-timeout}. This is an integer +that says how many seconds the @code{nntp} backend should wait for a +connection before giving up. If it is @code{nil}, which is the default, +no timeouts are done. + +@item nntp-command-timeout +@vindex nntp-command-timeout +@cindex PPP connections +@cindex dynamic IP addresses +If you're running Gnus on a machine that has a dynamically assigned +address, Gnus may become confused. If the address of your machine +changes after connecting to the @sc{nntp} server, Gnus will simply sit +waiting forever for replies from the server. To help with this +unfortunate problem, you can set this command to a number. Gnus will +then, if it sits waiting for a reply from the server longer than that +number of seconds, shut down the connection, start a new one, and resend +the command. This should hopefully be transparent to the user. A +likely number is 30 seconds. + +@item nntp-retry-on-break +@vindex nntp-retry-on-break +If this variable is non-@code{nil}, you can also @kbd{C-g} if Gnus +hangs. This will have much the same effect as the command timeout +described above. + +@item nntp-server-hook +@vindex nntp-server-hook +This hook is run as the last step when connecting to an @sc{nntp} +server. + +@findex nntp-open-rlogin +@findex nntp-open-telnet +@findex nntp-open-network-stream +@item nntp-open-connection-function +@vindex nntp-open-connection-function +This function is used to connect to the remote system. Three pre-made +functions are @code{nntp-open-network-stream}, which is the default, and +simply connects to some port or other on the remote system. The other +two are @code{nntp-open-rlogin}, which does an @samp{rlogin} on the +remote system, and then does a @samp{telnet} to the @sc{nntp} server +available there, and @code{nntp-open-telnet}, which does a @samp{telnet} +to the remote system and then another @samp{telnet} to get to the +@sc{nntp} server. + +@code{nntp-open-rlogin}-related variables: + +@table @code + +@item nntp-rlogin-program +@vindex nntp-rlogin-program +Program used to log in on remote machines. The default is @samp{rsh}, +but @samp{ssh} is a popular alternative. + +@item nntp-rlogin-parameters +@vindex nntp-rlogin-parameters +This list will be used as the parameter list given to @code{rsh}. + +@item nntp-rlogin-user-name +@vindex nntp-rlogin-user-name +User name on the remote system. + +@end table + +@code{nntp-open-telnet}-related variables: + +@table @code +@item nntp-telnet-command +@vindex nntp-telnet-command +Command used to start @code{telnet}. + +@item nntp-telnet-switches +@vindex nntp-telnet-switches +List of strings to be used as the switches to the @code{telnet} command. + +@item nntp-telnet-user-name +@vindex nntp-telnet-user-name +User name for log in on the remote system. + +@item nntp-telnet-passwd +@vindex nntp-telnet-passwd +Password to use when logging in. + +@item nntp-telnet-parameters +@vindex nntp-telnet-parameters +A list of strings executed as a command after logging in +via @code{telnet}. + +@end table + +@item nntp-end-of-line +@vindex nntp-end-of-line +String to use as end-of-line marker when talking to the @sc{nntp} +server. This is @samp{\r\n} by default, but should be @samp{\n} when +using @code{rlogin} to talk to the server. + +@item nntp-rlogin-user-name +@vindex nntp-rlogin-user-name +User name on the remote system when using the @code{rlogin} connect +function. + +@item nntp-address +@vindex nntp-address +The address of the remote system running the @sc{nntp} server. + +@item nntp-port-number +@vindex nntp-port-number +Port number to connect to when using the @code{nntp-open-network-stream} +connect function. + +@item nntp-buggy-select +@vindex nntp-buggy-select +Set this to non-@code{nil} if your select routine is buggy. + +@item nntp-nov-is-evil +@vindex nntp-nov-is-evil +If the @sc{nntp} server does not support @sc{nov}, you could set this +variable to @code{t}, but @code{nntp} usually checks automatically whether @sc{nov} +can be used. + +@item nntp-xover-commands +@vindex nntp-xover-commands +@cindex nov +@cindex XOVER +List of strings used as commands to fetch @sc{nov} lines from a +server. The default value of this variable is @code{("XOVER" +"XOVERVIEW")}. + +@item nntp-nov-gap +@vindex nntp-nov-gap +@code{nntp} normally sends just one big request for @sc{nov} lines to +the server. The server responds with one huge list of lines. However, +if you have read articles 2-5000 in the group, and only want to read +article 1 and 5001, that means that @code{nntp} will fetch 4999 @sc{nov} +lines that you will not need. This variable says how +big a gap between two consecutive articles is allowed to be before the +@code{XOVER} request is split into several request. Note that if your +network is fast, setting this variable to a really small number means +that fetching will probably be slower. If this variable is @code{nil}, +@code{nntp} will never split requests. The default is 5. + +@item nntp-prepare-server-hook +@vindex nntp-prepare-server-hook +A hook run before attempting to connect to an @sc{nntp} server. + +@item nntp-warn-about-losing-connection +@vindex nntp-warn-about-losing-connection +If this variable is non-@code{nil}, some noise will be made when a +server closes connection. + +@end table + + +@node News Spool +@subsection News Spool +@cindex nnspool +@cindex news spool + +Subscribing to a foreign group from the local spool is extremely easy, +and might be useful, for instance, to speed up reading groups that +contain very big articles---@samp{alt.binaries.pictures.furniture}, for +instance. + +Anyways, you just specify @code{nnspool} as the method and @samp{} (or +anything else) as the address. + +If you have access to a local spool, you should probably use that as the +native select method (@pxref{Finding the News}). It is normally faster +than using an @code{nntp} select method, but might not be. It depends. +You just have to try to find out what's best at your site. + +@table @code + +@item nnspool-inews-program +@vindex nnspool-inews-program +Program used to post an article. + +@item nnspool-inews-switches +@vindex nnspool-inews-switches +Parameters given to the inews program when posting an article. + +@item nnspool-spool-directory +@vindex nnspool-spool-directory +Where @code{nnspool} looks for the articles. This is normally +@file{/usr/spool/news/}. + +@item nnspool-nov-directory +@vindex nnspool-nov-directory +Where @code{nnspool} will look for @sc{nov} files. This is normally +@file{/usr/spool/news/over.view/}. + +@item nnspool-lib-dir +@vindex nnspool-lib-dir +Where the news lib dir is (@file{/usr/lib/news/} by default). + +@item nnspool-active-file +@vindex nnspool-active-file +The path to the active file. + +@item nnspool-newsgroups-file +@vindex nnspool-newsgroups-file +The path to the group descriptions file. + +@item nnspool-history-file +@vindex nnspool-history-file +The path to the news history file. + +@item nnspool-active-times-file +@vindex nnspool-active-times-file +The path to the active date file. + +@item nnspool-nov-is-evil +@vindex nnspool-nov-is-evil +If non-@code{nil}, @code{nnspool} won't try to use any @sc{nov} files +that it finds. + +@item nnspool-sift-nov-with-sed +@vindex nnspool-sift-nov-with-sed +@cindex sed +If non-@code{nil}, which is the default, use @code{sed} to get the +relevant portion from the overview file. If nil, @code{nnspool} will +load the entire file into a buffer and process it there. + +@end table + + +@node Getting Mail +@section Getting Mail +@cindex reading mail +@cindex mail + +Reading mail with a newsreader---isn't that just plain WeIrD? But of +course. + +@menu +* Getting Started Reading Mail:: A simple cookbook example. +* Splitting Mail:: How to create mail groups. +* Mail Backend Variables:: Variables for customizing mail handling. +* Fancy Mail Splitting:: Gnus can do hairy splitting of incoming mail. +* Mail and Procmail:: Reading mail groups that procmail create. +* Incorporating Old Mail:: What about the old mail you have? +* Expiring Mail:: Getting rid of unwanted mail. +* Washing Mail:: Removing gruft from the mail you get. +* Duplicates:: Dealing with duplicated mail. +* Not Reading Mail:: Using mail backends for reading other files. +* Choosing a Mail Backend:: Gnus can read a variety of mail formats. +@end menu + + +@node Getting Started Reading Mail +@subsection Getting Started Reading Mail + +It's quite easy to use Gnus to read your new mail. You just plonk the +mail backend of your choice into @code{gnus-secondary-select-methods}, +and things will happen automatically. + +For instance, if you want to use @code{nnml} (which is a "one file per +mail" backend), you could put the following in your @file{.gnus} file: + +@lisp +(setq gnus-secondary-select-methods + '((nnml "private"))) +@end lisp + +Now, the next time you start Gnus, this backend will be queried for new +articles, and it will move all the messages in your spool file to its +directory, which is @code{~/Mail/} by default. The new group that will +be created (@samp{mail.misc}) will be subscribed, and you can read it +like any other group. + +You will probably want to split the mail into several groups, though: + +@lisp +(setq nnmail-split-methods + '(("junk" "^From:.*Lars Ingebrigtsen") + ("crazy" "^Subject:.*die\\|^Organization:.*flabby") + ("other" ""))) +@end lisp + +This will result in three new @code{nnml} mail groups being created: +@samp{nnml:junk}, @samp{nnml:crazy}, and @samp{nnml:other}. All the +mail that doesn't fit into the first two groups will be placed in the +last group. + +This should be sufficient for reading mail with Gnus. You might want to +give the other sections in this part of the manual a perusal, though. +Especially @pxref{Choosing a Mail Backend} and @pxref{Expiring Mail}. + + +@node Splitting Mail +@subsection Splitting Mail +@cindex splitting mail +@cindex mail splitting + +@vindex nnmail-split-methods +The @code{nnmail-split-methods} variable says how the incoming mail is +to be split into groups. + +@lisp +(setq nnmail-split-methods + '(("mail.junk" "^From:.*Lars Ingebrigtsen") + ("mail.crazy" "^Subject:.*die\\|^Organization:.*flabby") + ("mail.other" ""))) +@end lisp + +This variable is a list of lists, where the first element of each of +these lists is the name of the mail group (they do not have to be called +something beginning with @samp{mail}, by the way), and the second +element is a regular expression used on the header of each mail to +determine if it belongs in this mail group. + +If the first element is the special symbol @code{junk}, then messages +that match the regexp will disappear into the aether. Use with +extreme caution. + +The second element can also be a function. In that case, it will be +called narrowed to the headers with the first element of the rule as the +argument. It should return a non-@code{nil} value if it thinks that the +mail belongs in that group. + +The last of these groups should always be a general one, and the regular +expression should @emph{always} be @samp{} so that it matches any mails +that haven't been matched by any of the other regexps. (These rules are +processed from the beginning of the alist toward the end. The first +rule to make a match will "win", unless you have crossposting enabled. +In that case, all matching rules will "win".) + +If you like to tinker with this yourself, you can set this variable to a +function of your choice. This function will be called without any +arguments in a buffer narrowed to the headers of an incoming mail +message. The function should return a list of group names that it +thinks should carry this mail message. + +Note that the mail backends are free to maul the poor, innocent, +incoming headers all they want to. They all add @code{Lines} headers; +some add @code{X-Gnus-Group} headers; most rename the Unix mbox +@code{From} line to something else. + +@vindex nnmail-crosspost +The mail backends all support cross-posting. If several regexps match, +the mail will be ``cross-posted'' to all those groups. +@code{nnmail-crosspost} says whether to use this mechanism or not. Note +that no articles are crossposted to the general (@samp{}) group. + +@vindex nnmail-crosspost-link-function +@cindex crosspost +@cindex links +@code{nnmh} and @code{nnml} makes crossposts by creating hard links to +the crossposted articles. However, not all file systems support hard +links. If that's the case for you, set +@code{nnmail-crosspost-link-function} to @code{copy-file}. (This +variable is @code{add-name-to-file} by default.) + +@kindex M-x nnmail-split-history +@kindex nnmail-split-history +If you wish to see where the previous mail split put the messages, you +can use the @kbd{M-x nnmail-split-history} command. + +Gnus gives you all the opportunity you could possibly want for shooting +yourself in the foot. Let's say you create a group that will contain +all the mail you get from your boss. And then you accidentally +unsubscribe from the group. Gnus will still put all the mail from your +boss in the unsubscribed group, and so, when your boss mails you ``Have +that report ready by Monday or you're fired!'', you'll never see it and, +come Tuesday, you'll still believe that you're gainfully employed while +you really should be out collecting empty bottles to save up for next +month's rent money. + + +@node Mail Backend Variables +@subsection Mail Backend Variables + +These variables are (for the most part) pertinent to all the various +mail backends. + +@table @code +@vindex nnmail-read-incoming-hook +@item nnmail-read-incoming-hook +The mail backends all call this hook after reading new mail. You can +use this hook to notify any mail watch programs, if you want to. + +@vindex nnmail-spool-file +@item nnmail-spool-file +@cindex POP mail +@cindex MAILHOST +@cindex movemail +@vindex nnmail-pop-password +@vindex nnmail-pop-password-required +The backends will look for new mail in this file. If this variable is +@code{nil}, the mail backends will never attempt to fetch mail by +themselves. If you are using a POP mail server and your name is +@samp{larsi}, you should set this variable to @samp{po:larsi}. If +your name is not @samp{larsi}, you should probably modify that +slightly, but you may have guessed that already, you smart & handsome +devil! You can also set this variable to @code{pop}, and Gnus will try +to figure out the POP mail string by itself. In any case, Gnus will +call @code{movemail} which will contact the POP server named in the +@code{MAILHOST} environment variable. If the POP server needs a +password, you can either set @code{nnmail-pop-password-required} to +@code{t} and be prompted for the password, or set +@code{nnmail-pop-password} to the password itself. + +@code{nnmail-spool-file} can also be a list of mailboxes. + +Your Emacs has to have been configured with @samp{--with-pop} before +compilation. This is the default, but some installations have it +switched off. + +When you use a mail backend, Gnus will slurp all your mail from your +inbox and plonk it down in your home directory. Gnus doesn't move any +mail if you're not using a mail backend---you have to do a lot of magic +invocations first. At the time when you have finished drawing the +pentagram, lightened the candles, and sacrificed the goat, you really +shouldn't be too surprised when Gnus moves your mail. + +@vindex nnmail-use-procmail +@vindex nnmail-procmail-suffix +@item nnmail-use-procmail +If non-@code{nil}, the mail backends will look in +@code{nnmail-procmail-directory} for incoming mail. All the files in +that directory that have names ending in @code{nnmail-procmail-suffix} +will be considered incoming mailboxes, and will be searched for new +mail. + +@vindex nnmail-crash-box +@item nnmail-crash-box +When a mail backend reads a spool file, mail is first moved to this +file, which is @file{~/.gnus-crash-box} by default. If this file +already exists, it will always be read (and incorporated) before any +other spool files. + +@vindex nnmail-prepare-incoming-hook +@item nnmail-prepare-incoming-hook +This is run in a buffer that holds all the new incoming mail, and can be +used for, well, anything, really. + +@vindex nnmail-split-hook +@item nnmail-split-hook +@findex article-decode-rfc1522 +@findex RFC1522 decoding +Hook run in the buffer where the mail headers of each message is kept +just before the splitting based on these headers is done. The hook is +free to modify the buffer contents in any way it sees fit---the buffer +is discarded after the splitting has been done, and no changes performed +in the buffer will show up in any files. @code{gnus-article-decode-rfc1522} +is one likely function to add to this hook. + +@vindex nnmail-pre-get-new-mail-hook +@vindex nnmail-post-get-new-mail-hook +@item nnmail-pre-get-new-mail-hook +@itemx nnmail-post-get-new-mail-hook +These are two useful hooks executed when treating new incoming +mail---@code{nnmail-pre-get-new-mail-hook} (is called just before +starting to handle the new mail) and +@code{nnmail-post-get-new-mail-hook} (is called when the mail handling +is done). Here's and example of using these two hooks to change the +default file modes the new mail files get: + +@lisp +(add-hook 'gnus-pre-get-new-mail-hook + (lambda () (set-default-file-modes 511))) + +(add-hook 'gnus-post-get-new-mail-hook + (lambda () (set-default-file-modes 551))) +@end lisp + +@item nnmail-tmp-directory +@vindex nnmail-tmp-directory +This variable says where to move incoming mail to -- while processing +it. This is usually done in the same directory that the mail backend +inhabits (e.g., @file{~/Mail/}), but if this variable is non-@code{nil}, +it will be used instead. + +@item nnmail-movemail-program +@vindex nnmail-movemail-program +This program is executed to move mail from the user's inbox to her home +directory. The default is @samp{movemail}. + +This can also be a function. In that case, the function will be called +with two parameters -- the name of the inbox, and the file to be moved +to. + +@item nnmail-delete-incoming +@vindex nnmail-delete-incoming +@cindex incoming mail files +@cindex deleting incoming files +If non-@code{nil}, the mail backends will delete the temporary incoming +file after splitting mail into the proper groups. This is @code{t} by +default. + +@c This is @code{nil} by +@c default for reasons of security. + +@c Since Red Gnus is an alpha release, it is to be expected to lose mail. +(No Gnus release since (ding) Gnus 0.10 (or something like that) have +lost mail, I think, but that's not the point. (Except certain versions +of Red Gnus.)) By not deleting the Incoming* files, one can be sure not +to lose mail -- if Gnus totally whacks out, one can always recover what +was lost. + +You may delete the @file{Incoming*} files at will. + +@item nnmail-use-long-file-names +@vindex nnmail-use-long-file-names +If non-@code{nil}, the mail backends will use long file and directory +names. Groups like @samp{mail.misc} will end up in directories +(assuming use of @code{nnml} backend) or files (assuming use of +@code{nnfolder} backend) like @file{mail.misc}. If it is @code{nil}, +the same group will end up in @file{mail/misc}. + +@item nnmail-delete-file-function +@vindex nnmail-delete-file-function +@findex delete-file +Function called to delete files. It is @code{delete-file} by default. + +@item nnmail-cache-accepted-message-ids +@vindex nnmail-cache-accepted-message-ids +If non-@code{nil}, put the @code{Message-ID}s of articles imported into +the backend (via @code{Gcc}, for instance) into the mail duplication +discovery cache. The default is @code{nil}. + +@end table + + +@node Fancy Mail Splitting +@subsection Fancy Mail Splitting +@cindex mail splitting +@cindex fancy mail splitting + +@vindex nnmail-split-fancy +@findex nnmail-split-fancy +If the rather simple, standard method for specifying how to split mail +doesn't allow you to do what you want, you can set +@code{nnmail-split-methods} to @code{nnmail-split-fancy}. Then you can +play with the @code{nnmail-split-fancy} variable. + +Let's look at an example value of this variable first: + +@lisp +;; Messages from the mailer daemon are not crossposted to any of +;; the ordinary groups. Warnings are put in a separate group +;; from real errors. +(| ("from" mail (| ("subject" "warn.*" "mail.warning") + "mail.misc")) + ;; Non-error messages are crossposted to all relevant + ;; groups, but we don't crosspost between the group for the + ;; (ding) list and the group for other (ding) related mail. + (& (| (any "ding@@ifi\\.uio\\.no" "ding.list") + ("subject" "ding" "ding.misc")) + ;; Other mailing lists... + (any "procmail@@informatik\\.rwth-aachen\\.de" "procmail.list") + (any "SmartList@@informatik\\.rwth-aachen\\.de" "SmartList.list") + ;; People... + (any "larsi@@ifi\\.uio\\.no" "people.Lars_Magne_Ingebrigtsen")) + ;; Unmatched mail goes to the catch all group. + "misc.misc") +@end lisp + +This variable has the format of a @dfn{split}. A split is a (possibly) +recursive structure where each split may contain other splits. Here are +the five possible split syntaxes: + +@enumerate + +@item +@samp{group}: If the split is a string, that will be taken as a group name. + +@item +@var{(FIELD VALUE SPLIT)}: If the split is a list, the first element of +which is a string, then store the message as specified by SPLIT, if +header FIELD (a regexp) contains VALUE (also a regexp). + +@item +@var{(| SPLIT...)}: If the split is a list, and the first element is +@code{|} (vertical bar), then process each SPLIT until one of them +matches. A SPLIT is said to match if it will cause the mail message to +be stored in one or more groups. + +@item +@var{(& SPLIT...)}: If the split is a list, and the first element is +@code{&}, then process all SPLITs in the list. + +@item +@code{junk}: If the split is the symbol @code{junk}, then don't save +this message anywhere. + +@item +@var{(: function arg1 arg2 ...)}: If the split is a list, and the first +element is @code{:}, then the second element will be called as a +function with @var{args} given as arguments. The function should return +a SPLIT. + +@end enumerate + +In these splits, @var{FIELD} must match a complete field name. +@var{VALUE} must match a complete word according to the fundamental mode +syntax table. You can use @code{.*} in the regexps to match partial +field names or words. In other words, all @var{VALUE}'s are wrapped in +@samp{\<} and @samp{\>} pairs. + +@vindex nnmail-split-abbrev-alist +@var{FIELD} and @var{VALUE} can also be lisp symbols, in that case they +are expanded as specified by the variable +@code{nnmail-split-abbrev-alist}. This is an alist of cons cells, where +the @code{car} of a cell contains the key, and the @code{cdr} contains the associated +value. + +@vindex nnmail-split-fancy-syntax-table +@code{nnmail-split-fancy-syntax-table} is the syntax table in effect +when all this splitting is performed. + +If you want to have Gnus create groups dynamically based on some +information in the headers (i.e., do @code{replace-match}-like +substitions in the group names), you can say things like: + +@example +(any "debian-\(\\w*\\)@@lists.debian.org" "mail.debian.\\1") +@end example + +@node Mail and Procmail +@subsection Mail and Procmail +@cindex procmail + +@cindex slocal +@cindex elm +Many people use @code{procmail} (or some other mail filter program or +external delivery agent---@code{slocal}, @code{elm}, etc) to split +incoming mail into groups. If you do that, you should set +@code{nnmail-spool-file} to @code{procmail} to ensure that the mail +backends never ever try to fetch mail by themselves. + +This also means that you probably don't want to set +@code{nnmail-split-methods} either, which has some, perhaps, unexpected +side effects. + +When a mail backend is queried for what groups it carries, it replies +with the contents of that variable, along with any groups it has figured +out that it carries by other means. None of the backends, except +@code{nnmh}, actually go out to the disk and check what groups actually +exist. (It's not trivial to distinguish between what the user thinks is +a basis for a newsgroup and what is just a plain old file or directory.) + +This means that you have to tell Gnus (and the backends) by hand what +groups exist. + +Let's take the @code{nnmh} backend as an example: + +The folders are located in @code{nnmh-directory}, say, @file{~/Mail/}. +There are three folders, @file{foo}, @file{bar} and @file{mail.baz}. + +Go to the group buffer and type @kbd{G m}. When prompted, answer +@samp{foo} for the name and @samp{nnmh} for the method. Repeat +twice for the two other groups, @samp{bar} and @samp{mail.baz}. Be sure +to include all your mail groups. + +That's it. You are now set to read your mail. An active file for this +method will be created automatically. + +@vindex nnmail-procmail-suffix +@vindex nnmail-procmail-directory +If you use @code{nnfolder} or any other backend that store more than a +single article in each file, you should never have procmail add mails to +the file that Gnus sees. Instead, procmail should put all incoming mail +in @code{nnmail-procmail-directory}. To arrive at the file name to put +the incoming mail in, append @code{nnmail-procmail-suffix} to the group +name. The mail backends will read the mail from these files. + +@vindex nnmail-resplit-incoming +When Gnus reads a file called @file{mail.misc.spool}, this mail will be +put in the @code{mail.misc}, as one would expect. However, if you want +Gnus to split the mail the normal way, you could set +@code{nnmail-resplit-incoming} to @code{t}. + +@vindex nnmail-keep-last-article +If you use @code{procmail} to split things directly into an @code{nnmh} +directory (which you shouldn't do), you should set +@code{nnmail-keep-last-article} to non-@code{nil} to prevent Gnus from +ever expiring the final article (i.e., the article with the highest +article number) in a mail newsgroup. This is quite, quite important. + +Here's an example setup: The incoming spools are located in +@file{~/incoming/} and have @samp{""} as suffixes (i.e., the incoming +spool files have the same names as the equivalent groups). The +@code{nnfolder} backend is to be used as the mail interface, and the +@code{nnfolder} directory is @file{~/fMail/}. + +@lisp +(setq nnfolder-directory "~/fMail/") +(setq nnmail-spool-file 'procmail) +(setq nnmail-procmail-directory "~/incoming/") +(setq gnus-secondary-select-methods '((nnfolder ""))) +(setq nnmail-procmail-suffix "") +@end lisp + + +@node Incorporating Old Mail +@subsection Incorporating Old Mail + +Most people have lots of old mail stored in various file formats. If +you have set up Gnus to read mail using one of the spiffy Gnus mail +backends, you'll probably wish to have that old mail incorporated into +your mail groups. + +Doing so can be quite easy. + +To take an example: You're reading mail using @code{nnml} +(@pxref{Mail Spool}), and have set @code{nnmail-split-methods} to a +satisfactory value (@pxref{Splitting Mail}). You have an old Unix mbox +file filled with important, but old, mail. You want to move it into +your @code{nnml} groups. + +Here's how: + +@enumerate +@item +Go to the group buffer. + +@item +Type `G f' and give the path to the mbox file when prompted to create an +@code{nndoc} group from the mbox file (@pxref{Foreign Groups}). + +@item +Type `SPACE' to enter the newly created group. + +@item +Type `M P b' to process-mark all articles in this group's buffer +(@pxref{Setting Process Marks}). + +@item +Type `B r' to respool all the process-marked articles, and answer +@samp{nnml} when prompted (@pxref{Mail Group Commands}). +@end enumerate + +All the mail messages in the mbox file will now also be spread out over +all your @code{nnml} groups. Try entering them and check whether things +have gone without a glitch. If things look ok, you may consider +deleting the mbox file, but I wouldn't do that unless I was absolutely +sure that all the mail has ended up where it should be. + +Respooling is also a handy thing to do if you're switching from one mail +backend to another. Just respool all the mail in the old mail groups +using the new mail backend. + + +@node Expiring Mail +@subsection Expiring Mail +@cindex article expiry + +Traditional mail readers have a tendency to remove mail articles when +you mark them as read, in some way. Gnus takes a fundamentally +different approach to mail reading. + +Gnus basically considers mail just to be news that has been received in +a rather peculiar manner. It does not think that it has the power to +actually change the mail, or delete any mail messages. If you enter a +mail group, and mark articles as ``read'', or kill them in some other +fashion, the mail articles will still exist on the system. I repeat: +Gnus will not delete your old, read mail. Unless you ask it to, of +course. + +To make Gnus get rid of your unwanted mail, you have to mark the +articles as @dfn{expirable}. This does not mean that the articles will +disappear right away, however. In general, a mail article will be +deleted from your system if, 1) it is marked as expirable, AND 2) it is +more than one week old. If you do not mark an article as expirable, it +will remain on your system until hell freezes over. This bears +repeating one more time, with some spurious capitalizations: IF you do +NOT mark articles as EXPIRABLE, Gnus will NEVER delete those ARTICLES. + +@vindex gnus-auto-expirable-newsgroups +You do not have to mark articles as expirable by hand. Groups that +match the regular expression @code{gnus-auto-expirable-newsgroups} will +have all articles that you read marked as expirable automatically. All +articles marked as expirable have an @samp{E} in the first +column in the summary buffer. + +By default, if you have auto expiry switched on, Gnus will mark all the +articles you read as expirable, no matter if they were read or unread +before. To avoid having articles marked as read marked as expirable +automatically, you can put something like the following in your +@file{.gnus} file: + +@vindex gnus-mark-article-hook +@lisp +(remove-hook 'gnus-mark-article-hook + 'gnus-summary-mark-read-and-unread-as-read) +(add-hook 'gnus-mark-article-hook 'gnus-summary-mark-unread-as-read) +@end lisp + +Note that making a group auto-expirable doesn't mean that all read +articles are expired---only the articles marked as expirable +will be expired. Also note that using the @kbd{d} command won't make +groups expirable---only semi-automatic marking of articles as read will +mark the articles as expirable in auto-expirable groups. + +Let's say you subscribe to a couple of mailing lists, and you want the +articles you have read to disappear after a while: + +@lisp +(setq gnus-auto-expirable-newsgroups + "mail.nonsense-list\\|mail.nice-list") +@end lisp + +Another way to have auto-expiry happen is to have the element +@code{auto-expire} in the group parameters of the group. + +If you use adaptive scoring (@pxref{Adaptive Scoring}) and +auto-expiring, you'll have problems. Auto-expiring and adaptive scoring +don't really mix very well. + +@vindex nnmail-expiry-wait +The @code{nnmail-expiry-wait} variable supplies the default time an +expirable article has to live. Gnus starts counting days from when the +message @emph{arrived}, not from when it was sent. The default is seven +days. + +Gnus also supplies a function that lets you fine-tune how long articles +are to live, based on what group they are in. Let's say you want to +have one month expiry period in the @samp{mail.private} group, a one day +expiry period in the @samp{mail.junk} group, and a six day expiry period +everywhere else: + +@vindex nnmail-expiry-wait-function +@lisp +(setq nnmail-expiry-wait-function + (lambda (group) + (cond ((string= group "mail.private") + 31) + ((string= group "mail.junk") + 1) + ((string= group "important") + 'never) + (t + 6)))) +@end lisp + +The group names this function is fed are ``unadorned'' group +names---no @samp{nnml:} prefixes and the like. + +The @code{nnmail-expiry-wait} variable and +@code{nnmail-expiry-wait-function} function can either be a number (not +necessarily an integer) or one of the symbols @code{immediate} or +@code{never}. + +You can also use the @code{expiry-wait} group parameter to selectively +change the expiry period (@pxref{Group Parameters}). + +@vindex nnmail-keep-last-article +If @code{nnmail-keep-last-article} is non-@code{nil}, Gnus will never +expire the final article in a mail newsgroup. This is to make life +easier for procmail users. + +@vindex gnus-total-expirable-newsgroups +By the way: That line up there, about Gnus never expiring non-expirable +articles, is a lie. If you put @code{total-expire} in the group +parameters, articles will not be marked as expirable, but all read +articles will be put through the expiry process. Use with extreme +caution. Even more dangerous is the +@code{gnus-total-expirable-newsgroups} variable. All groups that match +this regexp will have all read articles put through the expiry process, +which means that @emph{all} old mail articles in the groups in question +will be deleted after a while. Use with extreme caution, and don't come +crying to me when you discover that the regexp you used matched the +wrong group and all your important mail has disappeared. Be a +@emph{man}! Or a @emph{woman}! Whatever you feel more comfortable +with! So there! + +Most people make most of their mail groups total-expirable, though. + + +@node Washing Mail +@subsection Washing Mail +@cindex mail washing +@cindex list server brain damage +@cindex incoming mail treatment + +Mailers and list servers are notorious for doing all sorts of really, +really stupid things with mail. ``Hey, RFC822 doesn't explicitly +prohibit us from adding the string @code{wE aRe ElItE!!!!!1!!} to the +end of all lines passing through our server, so let's do that!!!!1!'' +Yes, but RFC822 wasn't designed to be read by morons. Things that were +considered to be self-evident were not discussed. So. Here we are. + +Case in point: The German version of Microsoft Exchange adds @samp{AW: +} to the subjects of replies instead of @samp{Re: }. I could pretend to +be shocked and dismayed by this, but I haven't got the energy. It is to +laugh. + +Gnus provides a plethora of functions for washing articles while +displaying them, but it might be nicer to do the filtering before +storing the mail to disc. For that purpose, we have three hooks and +various functions that can be put in these hooks. + +@table @code +@item nnmail-prepare-incoming-hook +@vindex nnmail-prepare-incoming-hook +This hook is called before doing anything with the mail and is meant for +grand, sweeping gestures. Functions to be used include: + +@table @code +@item nnheader-ms-strip-cr +@findex nnheader-ms-strip-cr +Remove trailing carriage returns from each line. This is default on +Emacs running on MS machines. + +@end table + +@item nnmail-prepare-incoming-header-hook +@vindex nnmail-prepare-incoming-header-hook +This hook is called narrowed to each header. It can be used when +cleaning up the headers. Functions that can be used include: + +@table @code +@item nnmail-remove-leading-whitespace +@findex nnmail-remove-leading-whitespace +Clear leading white space that ``helpful'' listservs have added to the +headers to make them look nice. Aaah. + +@item nnmail-remove-list-identifiers +@findex nnmail-remove-list-identifiers +Some list servers add an identifier---for example, @samp{(idm)}---to the +beginning of all @code{Subject} headers. I'm sure that's nice for +people who use stone age mail readers. This function will remove +strings that match the @code{nnmail-list-identifiers} regexp, which can +also be a list of regexp. + +For instance, if you want to remove the @samp{(idm)} and the +@samp{nagnagnag} identifiers: + +@lisp +(setq nnmail-list-identifiers + '("(idm)" "nagnagnag")) +@end lisp + +@item nnmail-remove-tabs +@findex nnmail-remove-tabs +Translate all @samp{TAB} characters into @samp{SPACE} characters. + +@end table + +@item nnmail-prepare-incoming-message-hook +@vindex nnmail-prepare-incoming-message-hook +This hook is called narrowed to each message. Functions to be used +include: + +@table @code +@item article-de-quoted-unreadable +@findex article-de-quoted-unreadable +Decode Quoted Readable encoding. + +@end table +@end table + + +@node Duplicates +@subsection Duplicates + +@vindex nnmail-treat-duplicates +@vindex nnmail-message-id-cache-length +@vindex nnmail-message-id-cache-file +@cindex duplicate mails +If you are a member of a couple of mailing lists, you will sometimes +receive two copies of the same mail. This can be quite annoying, so +@code{nnmail} checks for and treats any duplicates it might find. To do +this, it keeps a cache of old @code{Message-ID}s--- +@code{nnmail-message-id-cache-file}, which is @file{~/.nnmail-cache} by +default. The approximate maximum number of @code{Message-ID}s stored +there is controlled by the @code{nnmail-message-id-cache-length} +variable, which is 1000 by default. (So 1000 @code{Message-ID}s will be +stored.) If all this sounds scary to you, you can set +@code{nnmail-treat-duplicates} to @code{warn} (which is what it is by +default), and @code{nnmail} won't delete duplicate mails. Instead it +will insert a warning into the head of the mail saying that it thinks +that this is a duplicate of a different message. + +This variable can also be a function. If that's the case, the function +will be called from a buffer narrowed to the message in question with +the @code{Message-ID} as a parameter. The function must return either +@code{nil}, @code{warn}, or @code{delete}. + +You can turn this feature off completely by setting the variable to +@code{nil}. + +If you want all the duplicate mails to be put into a special +@dfn{duplicates} group, you could do that using the normal mail split +methods: + +@lisp +(setq nnmail-split-fancy + '(| ;; Messages duplicates go to a separate group. + ("gnus-warning" "duplication of message" "duplicate") + ;; Message from daemons, postmaster, and the like to another. + (any mail "mail.misc") + ;; Other rules. + [ ... ] )) +@end lisp + +Or something like: +@lisp +(setq nnmail-split-methods + '(("duplicates" "^Gnus-Warning:") + ;; Other rules. + [...])) +@end lisp + +Here's a neat feature: If you know that the recipient reads her mail +with Gnus, and that she has @code{nnmail-treat-duplicates} set to +@code{delete}, you can send her as many insults as you like, just by +using a @code{Message-ID} of a mail that you know that she's already +received. Think of all the fun! She'll never see any of it! Whee! + + +@node Not Reading Mail +@subsection Not Reading Mail + +If you start using any of the mail backends, they have the annoying +habit of assuming that you want to read mail with them. This might not +be unreasonable, but it might not be what you want. + +If you set @code{nnmail-spool-file} to @code{nil}, none of the backends +will ever attempt to read incoming mail, which should help. + +@vindex nnbabyl-get-new-mail +@vindex nnmbox-get-new-mail +@vindex nnml-get-new-mail +@vindex nnmh-get-new-mail +@vindex nnfolder-get-new-mail +This might be too much, if, for instance, you are reading mail quite +happily with @code{nnml} and just want to peek at some old @sc{rmail} +file you have stashed away with @code{nnbabyl}. All backends have +variables called backend-@code{get-new-mail}. If you want to disable +the @code{nnbabyl} mail reading, you edit the virtual server for the +group to have a setting where @code{nnbabyl-get-new-mail} to @code{nil}. + +All the mail backends will call @code{nn}*@code{-prepare-save-mail-hook} +narrowed to the article to be saved before saving it when reading +incoming mail. + + +@node Choosing a Mail Backend +@subsection Choosing a Mail Backend + +Gnus will read the mail spool when you activate a mail group. The mail +file is first copied to your home directory. What happens after that +depends on what format you want to store your mail in. + +@menu +* Unix Mail Box:: Using the (quite) standard Un*x mbox. +* Rmail Babyl:: Emacs programs use the rmail babyl format. +* Mail Spool:: Store your mail in a private spool? +* MH Spool:: An mhspool-like backend. +* Mail Folders:: Having one file for each group. +@end menu + + +@node Unix Mail Box +@subsubsection Unix Mail Box +@cindex nnmbox +@cindex unix mail box + +@vindex nnmbox-active-file +@vindex nnmbox-mbox-file +The @dfn{nnmbox} backend will use the standard Un*x mbox file to store +mail. @code{nnmbox} will add extra headers to each mail article to say +which group it belongs in. + +Virtual server settings: + +@table @code +@item nnmbox-mbox-file +@vindex nnmbox-mbox-file +The name of the mail box in the user's home directory. + +@item nnmbox-active-file +@vindex nnmbox-active-file +The name of the active file for the mail box. + +@item nnmbox-get-new-mail +@vindex nnmbox-get-new-mail +If non-@code{nil}, @code{nnmbox} will read incoming mail and split it +into groups. +@end table + + +@node Rmail Babyl +@subsubsection Rmail Babyl +@cindex nnbabyl +@cindex rmail mbox + +@vindex nnbabyl-active-file +@vindex nnbabyl-mbox-file +The @dfn{nnbabyl} backend will use a babyl mail box (aka. @dfn{rmail +mbox}) to store mail. @code{nnbabyl} will add extra headers to each mail +article to say which group it belongs in. + +Virtual server settings: + +@table @code +@item nnbabyl-mbox-file +@vindex nnbabyl-mbox-file +The name of the rmail mbox file. + +@item nnbabyl-active-file +@vindex nnbabyl-active-file +The name of the active file for the rmail box. + +@item nnbabyl-get-new-mail +@vindex nnbabyl-get-new-mail +If non-@code{nil}, @code{nnbabyl} will read incoming mail. +@end table + + +@node Mail Spool +@subsubsection Mail Spool +@cindex nnml +@cindex mail @sc{nov} spool + +The @dfn{nnml} spool mail format isn't compatible with any other known +format. It should be used with some caution. + +@vindex nnml-directory +If you use this backend, Gnus will split all incoming mail into files, +one file for each mail, and put the articles into the corresponding +directories under the directory specified by the @code{nnml-directory} +variable. The default value is @file{~/Mail/}. + +You do not have to create any directories beforehand; Gnus will take +care of all that. + +If you have a strict limit as to how many files you are allowed to store +in your account, you should not use this backend. As each mail gets its +own file, you might very well occupy thousands of inodes within a few +weeks. If this is no problem for you, and it isn't a problem for you +having your friendly systems administrator walking around, madly, +shouting ``Who is eating all my inodes?! Who? Who!?!'', then you should +know that this is probably the fastest format to use. You do not have +to trudge through a big mbox file just to read your new mail. + +@code{nnml} is probably the slowest backend when it comes to article +splitting. It has to create lots of files, and it also generates +@sc{nov} databases for the incoming mails. This makes it the fastest +backend when it comes to reading mail. + +Virtual server settings: + +@table @code +@item nnml-directory +@vindex nnml-directory +All @code{nnml} directories will be placed under this directory. + +@item nnml-active-file +@vindex nnml-active-file +The active file for the @code{nnml} server. + +@item nnml-newsgroups-file +@vindex nnml-newsgroups-file +The @code{nnml} group descriptions file. @xref{Newsgroups File +Format}. + +@item nnml-get-new-mail +@vindex nnml-get-new-mail +If non-@code{nil}, @code{nnml} will read incoming mail. + +@item nnml-nov-is-evil +@vindex nnml-nov-is-evil +If non-@code{nil}, this backend will ignore any @sc{nov} files. + +@item nnml-nov-file-name +@vindex nnml-nov-file-name +The name of the @sc{nov} files. The default is @file{.overview}. + +@item nnml-prepare-save-mail-hook +@vindex nnml-prepare-save-mail-hook +Hook run narrowed to an article before saving. + +@end table + +@findex nnml-generate-nov-databases +If your @code{nnml} groups and @sc{nov} files get totally out of whack, +you can do a complete update by typing @kbd{M-x +nnml-generate-nov-databases}. This command will trawl through the +entire @code{nnml} hierarchy, looking at each and every article, so it +might take a while to complete. A better interface to this +functionality can be found in the server buffer (@pxref{Server +Commands}). + + +@node MH Spool +@subsubsection MH Spool +@cindex nnmh +@cindex mh-e mail spool + +@code{nnmh} is just like @code{nnml}, except that is doesn't generate +@sc{nov} databases and it doesn't keep an active file. This makes +@code{nnmh} a @emph{much} slower backend than @code{nnml}, but it also +makes it easier to write procmail scripts for. + +Virtual server settings: + +@table @code +@item nnmh-directory +@vindex nnmh-directory +All @code{nnmh} directories will be located under this directory. + +@item nnmh-get-new-mail +@vindex nnmh-get-new-mail +If non-@code{nil}, @code{nnmh} will read incoming mail. + +@item nnmh-be-safe +@vindex nnmh-be-safe +If non-@code{nil}, @code{nnmh} will go to ridiculous lengths to make +sure that the articles in the folder are actually what Gnus thinks they +are. It will check date stamps and stat everything in sight, so +setting this to @code{t} will mean a serious slow-down. If you never +use anything but Gnus to read the @code{nnmh} articles, you do not have +to set this variable to @code{t}. +@end table + + +@node Mail Folders +@subsubsection Mail Folders +@cindex nnfolder +@cindex mbox folders +@cindex mail folders + +@code{nnfolder} is a backend for storing each mail group in a separate +file. Each file is in the standard Un*x mbox format. @code{nnfolder} +will add extra headers to keep track of article numbers and arrival +dates. + +Virtual server settings: + +@table @code +@item nnfolder-directory +@vindex nnfolder-directory +All the @code{nnfolder} mail boxes will be stored under this directory. + +@item nnfolder-active-file +@vindex nnfolder-active-file +The name of the active file. + +@item nnfolder-newsgroups-file +@vindex nnfolder-newsgroups-file +The name of the group descriptions file. @xref{Newsgroups File Format}. + +@item nnfolder-get-new-mail +@vindex nnfolder-get-new-mail +If non-@code{nil}, @code{nnfolder} will read incoming mail. +@end table + +@findex nnfolder-generate-active-file +@kindex M-x nnfolder-generate-active-file +If you have lots of @code{nnfolder}-like files you'd like to read with +@code{nnfolder}, you can use the @kbd{M-x nnfolder-generate-active-file} +command to make @code{nnfolder} aware of all likely files in +@code{nnfolder-directory}. + + +@node Other Sources +@section Other Sources + +Gnus can do more than just read news or mail. The methods described +below allow Gnus to view directories and files as if they were +newsgroups. + +@menu +* Directory Groups:: You can read a directory as if it was a newsgroup. +* Anything Groups:: Dired? Who needs dired? +* Document Groups:: Single files can be the basis of a group. +* SOUP:: Reading @sc{SOUP} packets ``offline''. +* Web Searches:: Creating groups from articles that match a string. +* Mail-To-News Gateways:: Posting articles via mail-to-news gateways. +@end menu + + +@node Directory Groups +@subsection Directory Groups +@cindex nndir +@cindex directory groups + +If you have a directory that has lots of articles in separate files in +it, you might treat it as a newsgroup. The files have to have numerical +names, of course. + +This might be an opportune moment to mention @code{ange-ftp} (and its +successor @code{efs}), that most wonderful of all wonderful Emacs +packages. When I wrote @code{nndir}, I didn't think much about it---a +backend to read directories. Big deal. + +@code{ange-ftp} changes that picture dramatically. For instance, if you +enter the @code{ange-ftp} file name +@file{/ftp.hpc.uh.edu:/pub/emacs/ding-list/} as the directory name, +@code{ange-ftp} or @code{efs} will actually allow you to read this +directory over at @samp{sina} as a newsgroup. Distributed news ahoy! + +@code{nndir} will use @sc{nov} files if they are present. + +@code{nndir} is a ``read-only'' backend---you can't delete or expire +articles with this method. You can use @code{nnmh} or @code{nnml} for +whatever you use @code{nndir} for, so you could switch to any of those +methods if you feel the need to have a non-read-only @code{nndir}. + + +@node Anything Groups +@subsection Anything Groups +@cindex nneething + +From the @code{nndir} backend (which reads a single spool-like +directory), it's just a hop and a skip to @code{nneething}, which +pretends that any arbitrary directory is a newsgroup. Strange, but +true. + +When @code{nneething} is presented with a directory, it will scan this +directory and assign article numbers to each file. When you enter such +a group, @code{nneething} must create ``headers'' that Gnus can use. +After all, Gnus is a newsreader, in case you're +forgetting. @code{nneething} does this in a two-step process. First, it +snoops each file in question. If the file looks like an article (i.e., +the first few lines look like headers), it will use this as the head. +If this is just some arbitrary file without a head (e.g. a C source +file), @code{nneething} will cobble up a header out of thin air. It +will use file ownership, name and date and do whatever it can with these +elements. + +All this should happen automatically for you, and you will be presented +with something that looks very much like a newsgroup. Totally like a +newsgroup, to be precise. If you select an article, it will be displayed +in the article buffer, just as usual. + +If you select a line that represents a directory, Gnus will pop you into +a new summary buffer for this @code{nneething} group. And so on. You can +traverse the entire disk this way, if you feel like, but remember that +Gnus is not dired, really, and does not intend to be, either. + +There are two overall modes to this action---ephemeral or solid. When +doing the ephemeral thing (i.e., @kbd{G D} from the group buffer), Gnus +will not store information on what files you have read, and what files +are new, and so on. If you create a solid @code{nneething} group the +normal way with @kbd{G m}, Gnus will store a mapping table between +article numbers and file names, and you can treat this group like any +other groups. When you activate a solid @code{nneething} group, you will +be told how many unread articles it contains, etc., etc. + +Some variables: + +@table @code +@item nneething-map-file-directory +@vindex nneething-map-file-directory +All the mapping files for solid @code{nneething} groups will be stored +in this directory, which defaults to @file{~/.nneething/}. + +@item nneething-exclude-files +@vindex nneething-exclude-files +All files that match this regexp will be ignored. Nice to use to exclude +auto-save files and the like, which is what it does by default. + +@item nneething-map-file +@vindex nneething-map-file +Name of the map files. +@end table + + +@node Document Groups +@subsection Document Groups +@cindex nndoc +@cindex documentation group +@cindex help group + +@code{nndoc} is a cute little thing that will let you read a single file +as a newsgroup. Several files types are supported: + +@table @code +@cindex babyl +@cindex rmail mbox + +@item babyl +The babyl (rmail) mail box. +@cindex mbox +@cindex Unix mbox + +@item mbox +The standard Unix mbox file. + +@cindex MMDF mail box +@item mmdf +The MMDF mail box format. + +@item news +Several news articles appended into a file. + +@item rnews +@cindex rnews batch files +The rnews batch transport format. +@cindex forwarded messages + +@item forward +Forwarded articles. + +@item mime-digest +@cindex digest +@cindex MIME digest +@cindex 1153 digest +@cindex RFC 1153 digest +@cindex RFC 341 digest +MIME (RFC 1341) digest format. + +@item standard-digest +The standard (RFC 1153) digest format. + +@item slack-digest +Non-standard digest format---matches most things, but does it badly. +@end table + +You can also use the special ``file type'' @code{guess}, which means +that @code{nndoc} will try to guess what file type it is looking at. +@code{digest} means that @code{nndoc} should guess what digest type the +file is. + +@code{nndoc} will not try to change the file or insert any extra headers into +it---it will simply, like, let you use the file as the basis for a +group. And that's it. + +If you have some old archived articles that you want to insert into your +new & spiffy Gnus mail backend, @code{nndoc} can probably help you with +that. Say you have an old @file{RMAIL} file with mail that you now want +to split into your new @code{nnml} groups. You look at that file using +@code{nndoc} (using the @kbd{G f} command in the group buffer +(@pxref{Foreign Groups})), set the process mark on all the articles in +the buffer (@kbd{M P b}, for instance), and then re-spool (@kbd{B r}) +using @code{nnml}. If all goes well, all the mail in the @file{RMAIL} +file is now also stored in lots of @code{nnml} directories, and you can +delete that pesky @file{RMAIL} file. If you have the guts! + +Virtual server variables: + +@table @code +@item nndoc-article-type +@vindex nndoc-article-type +This should be one of @code{mbox}, @code{babyl}, @code{digest}, +@code{news}, @code{rnews}, @code{mmdf}, @code{forward}, @code{rfc934}, +@code{rfc822-forward}, @code{mime-digest}, @code{standard-digest}, +@code{slack-digest}, @code{clari-briefs} or @code{guess}. + +@item nndoc-post-type +@vindex nndoc-post-type +This variable says whether Gnus is to consider the group a news group or +a mail group. There are two valid values: @code{mail} (the default) +and @code{news}. +@end table + +@menu +* Document Server Internals:: How to add your own document types. +@end menu + + +@node Document Server Internals +@subsubsection Document Server Internals + +Adding new document types to be recognized by @code{nndoc} isn't +difficult. You just have to whip up a definition of what the document +looks like, write a predicate function to recognize that document type, +and then hook into @code{nndoc}. + +First, here's an example document type definition: + +@example +(mmdf + (article-begin . "^\^A\^A\^A\^A\n") + (body-end . "^\^A\^A\^A\^A\n")) +@end example + +The definition is simply a unique @dfn{name} followed by a series of +regexp pseudo-variable settings. Below are the possible +variables---don't be daunted by the number of variables; most document +types can be defined with very few settings: + +@table @code +@item first-article +If present, @code{nndoc} will skip past all text until it finds +something that match this regexp. All text before this will be +totally ignored. + +@item article-begin +This setting has to be present in all document type definitions. It +says what the beginning of each article looks like. + +@item head-begin-function +If present, this should be a function that moves point to the head of +the article. + +@item nndoc-head-begin +If present, this should be a regexp that matches the head of the +article. + +@item nndoc-head-end +This should match the end of the head of the article. It defaults to +@samp{^$}---the empty line. + +@item body-begin-function +If present, this function should move point to the beginning of the body +of the article. + +@item body-begin +This should match the beginning of the body of the article. It defaults +to @samp{^\n}. + +@item body-end-function +If present, this function should move point to the end of the body of +the article. + +@item body-end +If present, this should match the end of the body of the article. + +@item file-end +If present, this should match the end of the file. All text after this +regexp will be totally ignored. + +@end table + +So, using these variables @code{nndoc} is able to dissect a document +file into a series of articles, each with a head and a body. However, a +few more variables are needed since not all document types are all that +news-like---variables needed to transform the head or the body into +something that's palatable for Gnus: + +@table @code +@item prepare-body-function +If present, this function will be called when requesting an article. It +will be called with point at the start of the body, and is useful if the +document has encoded some parts of its contents. + +@item article-transform-function +If present, this function is called when requesting an article. It's +meant to be used for more wide-ranging transformation of both head and +body of the article. + +@item generate-head-function +If present, this function is called to generate a head that Gnus can +understand. It is called with the article number as a parameter, and is +expected to generate a nice head for the article in question. It is +called when requesting the headers of all articles. + +@end table + +Let's look at the most complicated example I can come up with---standard +digests: + +@example +(standard-digest + (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) + (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+")) + (prepare-body-function . nndoc-unquote-dashes) + (body-end-function . nndoc-digest-body-end) + (head-end . "^ ?$") + (body-begin . "^ ?\n") + (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$") + (subtype digest guess)) +@end example + +We see that all text before a 70-width line of dashes is ignored; all +text after a line that starts with that @samp{^End of} is also ignored; +each article begins with a 30-width line of dashes; the line separating +the head from the body may contain a single space; and that the body is +run through @code{nndoc-unquote-dashes} before being delivered. + +To hook your own document definition into @code{nndoc}, use the +@code{nndoc-add-type} function. It takes two parameters---the first is +the definition itself and the second (optional) parameter says where in +the document type definition alist to put this definition. The alist is +traversed sequentially, and @code{nndoc-TYPE-type-p} is called for a given type @code{TYPE}. So @code{nndoc-mmdf-type-p} is called to see whether a document +is of @code{mmdf} type, and so on. These type predicates should return +@code{nil} if the document is not of the correct type; @code{t} if it is +of the correct type; and a number if the document might be of the +correct type. A high number means high probability; a low number means +low probability with @samp{0} being the lowest valid number. + + +@node SOUP +@subsection SOUP +@cindex SOUP +@cindex offline + +In the PC world people often talk about ``offline'' newsreaders. These +are thingies that are combined reader/news transport monstrosities. +With built-in modem programs. Yecchh! + +Of course, us Unix Weenie types of human beans use things like +@code{uucp} and, like, @code{nntpd} and set up proper news and mail +transport things like Ghod intended. And then we just use normal +newsreaders. + +However, it can sometimes be convenient to do something a that's a bit +easier on the brain if you have a very slow modem, and you're not really +that interested in doing things properly. + +A file format called @sc{soup} has been developed for transporting news +and mail from servers to home machines and back again. It can be a bit +fiddly. + +First some terminology: + +@table @dfn + +@item server +This is the machine that is connected to the outside world and where you +get news and/or mail from. + +@item home machine +This is the machine that you want to do the actual reading and responding +on. It is typically not connected to the rest of the world in any way. + +@item packet +Something that contains messages and/or commands. There are two kinds +of packets: + +@table @dfn +@item message packets +These are packets made at the server, and typically contain lots of +messages for you to read. These are called @file{SoupoutX.tgz} by +default, where @var{X} is a number. + +@item response packets +These are packets made at the home machine, and typically contains +replies that you've written. These are called @file{SoupinX.tgz} by +default, where @var{X} is a number. + +@end table + +@end table + + +@enumerate + +@item +You log in on the server and create a @sc{soup} packet. You can either +use a dedicated @sc{soup} thingie (like the @code{awk} program), or you +can use Gnus to create the packet with its @sc{soup} commands (@kbd{O +s} and/or @kbd{G s b}; and then @kbd{G s p}) (@pxref{SOUP Commands}). + +@item +You transfer the packet home. Rail, boat, car or modem will do fine. + +@item +You put the packet in your home directory. + +@item +You fire up Gnus on your home machine using the @code{nnsoup} backend as +the native or secondary server. + +@item +You read articles and mail and answer and followup to the things you +want (@pxref{SOUP Replies}). + +@item +You do the @kbd{G s r} command to pack these replies into a @sc{soup} +packet. + +@item +You transfer this packet to the server. + +@item +You use Gnus to mail this packet out with the @kbd{G s s} command. + +@item +You then repeat until you die. + +@end enumerate + +So you basically have a bipartite system---you use @code{nnsoup} for +reading and Gnus for packing/sending these @sc{soup} packets. + +@menu +* SOUP Commands:: Commands for creating and sending @sc{soup} packets +* SOUP Groups:: A backend for reading @sc{soup} packets. +* SOUP Replies:: How to enable @code{nnsoup} to take over mail and news. +@end menu + + +@node SOUP Commands +@subsubsection SOUP Commands + +These are commands for creating and manipulating @sc{soup} packets. + +@table @kbd +@item G s b +@kindex G s b (Group) +@findex gnus-group-brew-soup +Pack all unread articles in the current group +(@code{gnus-group-brew-soup}). This command understands the +process/prefix convention. + +@item G s w +@kindex G s w (Group) +@findex gnus-soup-save-areas +Save all @sc{soup} data files (@code{gnus-soup-save-areas}). + +@item G s s +@kindex G s s (Group) +@findex gnus-soup-send-replies +Send all replies from the replies packet +(@code{gnus-soup-send-replies}). + +@item G s p +@kindex G s p (Group) +@findex gnus-soup-pack-packet +Pack all files into a @sc{soup} packet (@code{gnus-soup-pack-packet}). + +@item G s r +@kindex G s r (Group) +@findex nnsoup-pack-replies +Pack all replies into a replies packet (@code{nnsoup-pack-replies}). + +@item O s +@kindex O s (Summary) +@findex gnus-soup-add-article +This summary-mode command adds the current article to a @sc{soup} packet +(@code{gnus-soup-add-article}). It understands the process/prefix +convention (@pxref{Process/Prefix}). + +@end table + + +There are a few variables to customize where Gnus will put all these +thingies: + +@table @code + +@item gnus-soup-directory +@vindex gnus-soup-directory +Directory where Gnus will save intermediate files while composing +@sc{soup} packets. The default is @file{~/SoupBrew/}. + +@item gnus-soup-replies-directory +@vindex gnus-soup-replies-directory +This is what Gnus will use as a temporary directory while sending our +reply packets. @file{~/SoupBrew/SoupReplies/} is the default. + +@item gnus-soup-prefix-file +@vindex gnus-soup-prefix-file +Name of the file where Gnus stores the last used prefix. The default is +@samp{gnus-prefix}. + +@item gnus-soup-packer +@vindex gnus-soup-packer +A format string command for packing a @sc{soup} packet. The default is +@samp{tar cf - %s | gzip > $HOME/Soupout%d.tgz}. + +@item gnus-soup-unpacker +@vindex gnus-soup-unpacker +Format string command for unpacking a @sc{soup} packet. The default is +@samp{gunzip -c %s | tar xvf -}. + +@item gnus-soup-packet-directory +@vindex gnus-soup-packet-directory +Where Gnus will look for reply packets. The default is @file{~/}. + +@item gnus-soup-packet-regexp +@vindex gnus-soup-packet-regexp +Regular expression matching @sc{soup} reply packets in +@code{gnus-soup-packet-directory}. + +@end table + + +@node SOUP Groups +@subsubsection @sc{soup} Groups +@cindex nnsoup + +@code{nnsoup} is the backend for reading @sc{soup} packets. It will +read incoming packets, unpack them, and put them in a directory where +you can read them at leisure. + +These are the variables you can use to customize its behavior: + +@table @code + +@item nnsoup-tmp-directory +@vindex nnsoup-tmp-directory +When @code{nnsoup} unpacks a @sc{soup} packet, it does it in this +directory. (@file{/tmp/} by default.) + +@item nnsoup-directory +@vindex nnsoup-directory +@code{nnsoup} then moves each message and index file to this directory. +The default is @file{~/SOUP/}. + +@item nnsoup-replies-directory +@vindex nnsoup-replies-directory +All replies will be stored in this directory before being packed into a +reply packet. The default is @file{~/SOUP/replies/"}. + +@item nnsoup-replies-format-type +@vindex nnsoup-replies-format-type +The @sc{soup} format of the replies packets. The default is @samp{?n} +(rnews), and I don't think you should touch that variable. I probably +shouldn't even have documented it. Drats! Too late! + +@item nnsoup-replies-index-type +@vindex nnsoup-replies-index-type +The index type of the replies packet. The default is @samp{?n}, which +means ``none''. Don't fiddle with this one either! + +@item nnsoup-active-file +@vindex nnsoup-active-file +Where @code{nnsoup} stores lots of information. This is not an ``active +file'' in the @code{nntp} sense; it's an Emacs Lisp file. If you lose +this file or mess it up in any way, you're dead. The default is +@file{~/SOUP/active}. + +@item nnsoup-packer +@vindex nnsoup-packer +Format string command for packing a reply @sc{soup} packet. The default +is @samp{tar cf - %s | gzip > $HOME/Soupin%d.tgz}. + +@item nnsoup-unpacker +@vindex nnsoup-unpacker +Format string command for unpacking incoming @sc{soup} packets. The +default is @samp{gunzip -c %s | tar xvf -}. + +@item nnsoup-packet-directory +@vindex nnsoup-packet-directory +Where @code{nnsoup} will look for incoming packets. The default is +@file{~/}. + +@item nnsoup-packet-regexp +@vindex nnsoup-packet-regexp +Regular expression matching incoming @sc{soup} packets. The default is +@samp{Soupout}. + +@item nnsoup-always-save +@vindex nnsoup-always-save +If non-@code{nil}, save the replies buffer after each posted message. + +@end table + + +@node SOUP Replies +@subsubsection SOUP Replies + +Just using @code{nnsoup} won't mean that your postings and mailings end +up in @sc{soup} reply packets automagically. You have to work a bit +more for that to happen. + +@findex nnsoup-set-variables +The @code{nnsoup-set-variables} command will set the appropriate +variables to ensure that all your followups and replies end up in the +@sc{soup} system. + +In specific, this is what it does: + +@lisp +(setq message-send-news-function 'nnsoup-request-post) +(setq message-send-mail-function 'nnsoup-request-mail) +@end lisp + +And that's it, really. If you only want news to go into the @sc{soup} +system you just use the first line. If you only want mail to be +@sc{soup}ed you use the second. + + +@node Web Searches +@subsection Web Searches +@cindex nnweb +@cindex DejaNews +@cindex Alta Vista +@cindex InReference +@cindex Usenet searches +@cindex searching the Usenet + +It's, like, too neat to search the Usenet for articles that match a +string, but it, like, totally @emph{sucks}, like, totally, to use one of +those, like, Web browsers, and you, like, have to, rilly, like, look at +the commercials, so, like, with Gnus you can do @emph{rad}, rilly, +searches without having to use a browser. + +The @code{nnweb} backend allows an easy interface to the mighty search +engine. You create an @code{nnweb} group, enter a search pattern, and +then enter the group and read the articles like you would any normal +group. The @kbd{G w} command in the group buffer (@pxref{Foreign +Groups}) will do this in an easy-to-use fashion. + +@code{nnweb} groups don't really lend themselves to being solid +groups---they have a very fleeting idea of article numbers. In fact, +each time you enter an @code{nnweb} group (not even changing the search +pattern), you are likely to get the articles ordered in a different +manner. Not even using duplicate suppression (@pxref{Duplicate +Suppression}) will help, since @code{nnweb} doesn't even know the +@code{Message-ID} of the articles before reading them using some search +engines (DejaNews, for instance). The only possible way to keep track +of which articles you've read is by scoring on the @code{Date} +header---mark all articles posted before the last date you read the +group as read. + +If the search engine changes its output substantially, @code{nnweb} +won't be able to parse it and will fail. One could hardly fault the Web +providers if they were to do this---their @emph{raison d'être} is to +make money off of advertisements, not to provide services to the +community. Since @code{nnweb} washes the ads off all the articles, one +might think that the providers might be somewhat miffed. We'll see. + +You must have the @code{url} and @code{w3} package installed to be able +to use @code{nnweb}. + +Virtual server variables: + +@table @code +@item nnweb-type +@vindex nnweb-type +What search engine type is being used. The currently supported types +are @code{dejanews}, @code{altavista} and @code{reference}. + +@item nnweb-search +@vindex nnweb-search +The search string to feed to the search engine. + +@item nnweb-max-hits +@vindex nnweb-max-hits +Advisory maximum number of hits per search to display. The default is +100. + +@item nnweb-type-definition +@vindex nnweb-type-definition +Type-to-definition alist. This alist says what @code{nnweb} should do +with the various search engine types. The following elements must be +present: + +@table @code +@item article +Function to decode the article and provide something that Gnus +understands. + +@item map +Function to create an article number to message header and URL alist. + +@item search +Function to send the search string to the search engine. + +@item address +The address the aforementioned function should send the search string +to. + +@item id +Format string URL to fetch an article by @code{Message-ID}. +@end table + +@end table + + + +@node Mail-To-News Gateways +@subsection Mail-To-News Gateways +@cindex mail-to-news gateways +@cindex gateways + +If your local @code{nntp} server doesn't allow posting, for some reason +or other, you can post using one of the numerous mail-to-news gateways. +The @code{nngateway} backend provides the interface. + +Note that you can't read anything from this backend---it can only be +used to post with. + +Server variables: + +@table @code +@item nngateway-address +@vindex nngateway-address +This is the address of the mail-to-news gateway. + +@item nngateway-header-transformation +@vindex nngateway-header-transformation +News headers often have to be transformed in some odd way or other +for the mail-to-news gateway to accept it. This variable says what +transformation should be called, and defaults to +@code{nngateway-simple-header-transformation}. The function is called +narrowed to the headers to be transformed and with one parameter---the +gateway address. + +This default function just inserts a new @code{To} header based on the +@code{Newsgroups} header and the gateway address. +For instance, an article with this @code{Newsgroups} header: + +@example +Newsgroups: alt.religion.emacs +@end example + +will get this @code{From} header inserted: + +@example +To: alt-religion-emacs@@GATEWAY +@end example + +@end table + +So, to use this, simply say something like: + +@lisp +(setq gnus-post-method '(nngateway "GATEWAY.ADDRESS")) +@end lisp + + +@node Combined Groups +@section Combined Groups + +Gnus allows combining a mixture of all the other group types into bigger +groups. + +@menu +* Virtual Groups:: Combining articles from many groups. +* Kibozed Groups:: Looking through parts of the newsfeed for articles. +@end menu + + +@node Virtual Groups +@subsection Virtual Groups +@cindex nnvirtual +@cindex virtual groups + +An @dfn{nnvirtual group} is really nothing more than a collection of +other groups. + +For instance, if you are tired of reading many small groups, you can +put them all in one big group, and then grow tired of reading one +big, unwieldy group. The joys of computing! + +You specify @code{nnvirtual} as the method. The address should be a +regexp to match component groups. + +All marks in the virtual group will stick to the articles in the +component groups. So if you tick an article in a virtual group, the +article will also be ticked in the component group from whence it came. +(And vice versa---marks from the component groups will also be shown in +the virtual group.) + +Here's an example @code{nnvirtual} method that collects all Andrea Dworkin +newsgroups into one, big, happy newsgroup: + +@lisp +(nnvirtual "^alt\\.fan\\.andrea-dworkin$\\|^rec\\.dworkin.*") +@end lisp + +The component groups can be native or foreign; everything should work +smoothly, but if your computer explodes, it was probably my fault. + +Collecting the same group from several servers might actually be a good +idea if users have set the Distribution header to limit distribution. +If you would like to read @samp{soc.motss} both from a server in Japan +and a server in Norway, you could use the following as the group regexp: + +@example +"^nntp+some.server.jp:soc.motss$\\|^nntp+some.server.no:soc.motss$" +@end example + +This should work kinda smoothly---all articles from both groups should +end up in this one, and there should be no duplicates. Threading (and +the rest) will still work as usual, but there might be problems with the +sequence of articles. Sorting on date might be an option here +(@pxref{Selecting a Group}). + +One limitation, however---all groups included in a virtual +group have to be alive (i.e., subscribed or unsubscribed). Killed or +zombie groups can't be component groups for @code{nnvirtual} groups. + +@vindex nnvirtual-always-rescan +If the @code{nnvirtual-always-rescan} is non-@code{nil}, +@code{nnvirtual} will always scan groups for unread articles when +entering a virtual group. If this variable is @code{nil} (which is the +default) and you read articles in a component group after the virtual +group has been activated, the read articles from the component group +will show up when you enter the virtual group. You'll also see this +effect if you have two virtual groups that have a component group in +common. If that's the case, you should set this variable to @code{t}. +Or you can just tap @code{M-g} on the virtual group every time before +you enter it---it'll have much the same effect. + + +@node Kibozed Groups +@subsection Kibozed Groups +@cindex nnkiboze +@cindex kibozing + +@dfn{Kibozing} is defined by @sc{oed} as ``grepping through (parts of) +the news feed''. @code{nnkiboze} is a backend that will do this for +you. Oh joy! Now you can grind any @sc{nntp} server down to a halt +with useless requests! Oh happiness! + +@kindex G k (Group) +To create a kibozed group, use the @kbd{G k} command in the group +buffer. + +The address field of the @code{nnkiboze} method is, as with +@code{nnvirtual}, a regexp to match groups to be ``included'' in the +@code{nnkiboze} group. That's where most similarities between @code{nnkiboze} +and @code{nnvirtual} end. + +In addition to this regexp detailing component groups, an @code{nnkiboze} group +must have a score file to say what articles are to be included in +the group (@pxref{Scoring}). + +@kindex M-x nnkiboze-generate-groups +@findex nnkiboze-generate-groups +You must run @kbd{M-x nnkiboze-generate-groups} after creating the +@code{nnkiboze} groups you want to have. This command will take time. Lots of +time. Oodles and oodles of time. Gnus has to fetch the headers from +all the articles in all the component groups and run them through the +scoring process to determine if there are any articles in the groups +that are to be part of the @code{nnkiboze} groups. + +Please limit the number of component groups by using restrictive +regexps. Otherwise your sysadmin may become annoyed with you, and the +@sc{nntp} site may throw you off and never let you back in again. +Stranger things have happened. + +@code{nnkiboze} component groups do not have to be alive---they can be dead, +and they can be foreign. No restrictions. + +@vindex nnkiboze-directory +The generation of an @code{nnkiboze} group means writing two files in +@code{nnkiboze-directory}, which is @file{~/News/} by default. One +contains the @sc{nov} header lines for all the articles in the group, +and the other is an additional @file{.newsrc} file to store information +on what groups have been searched through to find component articles. + +Articles marked as read in the @code{nnkiboze} group will have +their @sc{nov} lines removed from the @sc{nov} file. + + +@node Gnus Unplugged +@section Gnus Unplugged +@cindex offline +@cindex unplugged +@cindex Agent +@cindex Gnus Agent +@cindex Gnus Unplugged + +In olden times (ca. February '88), people used to run their newsreaders +on big machines with permanent connections to the net. News transport +was dealt with by news servers, and all the newsreaders had to do was to +read news. Believe it or not. + +Nowadays most people read news and mail at home, and use some sort of +modem to connect to the net. To avoid running up huge phone bills, it +would be nice to have a way to slurp down all the news and mail, hang up +the phone, read for several hours, and then upload any responses you +have to make. And then you repeat the procedure. + +Of course, you can use news servers for doing this as well. I've used +@code{inn} together with @code{slurp}, @code{pop} and @code{sendmail} +for some years, but doing that's a bore. Moving the news server +functionality up to the newsreader makes sense if you're the only person +reading news on a machine. + +Using Gnus as an ``offline'' newsreader is quite simple. + +@itemize @bullet +@item +First, set up Gnus as you would do if you were running it on a machine +that has full connection to the net. Go ahead. I'll still be waiting +here. + +@item +Then, put the following magical incantation at the end of your +@file{.gnus.el} file: + +@lisp +(gnus-agentize) +@end lisp +@end itemize + +That's it. Gnus is now an ``offline'' newsreader. + +Of course, to use it as such, you have to learn a few new commands. + +@menu +* Agent Basics:: How it all is supposed to work. +* Agent Categories:: How to tell the Gnus Agent what to download. +* Agent Commands:: New commands for all the buffers. +* Outgoing Messages:: What happens when you post/mail something? +* Agent Variables:: Customizing is fun. +* Example Setup:: An example @file{.gnus.el} file for offline people. +@end menu + + +@node Agent Basics +@subsection Agent Basics + +First, let's get some terminology out of the way. + +The Gnus Agent is said to be @dfn{unplugged} when you have severed the +connection to the net (and notified the Agent that this is the case). +When the connection to the net is up again (and Gnus knows this), the +Agent is @dfn{plugged}. + +The @dfn{local} machine is the one you're running on, and which isn't +connected to the net continously. + +@dfn{Downloading} means fetching things from the net to your local +machine. @dfn{Uploading} is doing the opposite. + +Let's take a typical Gnus session using the Agent. + +@itemize @bullet + +@item +You start Gnus with @code{gnus-unplugged}. This brings up the Gnus +Agent in a disconnected state. You can read all the news that you have +already fetched while in this mode. + +@item +You then decide to see whether any new news has arrived. You connect +your machine to the net (using PPP or whatever), and then hit @kbd{J j} +to make Gnus become @dfn{plugged}. + +@item +You can then read the new news immediately, or you can download the news +onto your local machine. If you want to do the latter, you press @kbd{J +s} to fetch all the eligible articles in all the groups. (To let Gnus +know which articles you want to download, @pxref{Agent Categories}.) + +@item +After fetching the articles, you press @kbd{J j} to make Gnus become +unplugged again, and you shut down the PPP thing (or whatever). And +then you read the news offline. + +@item +And then you go to step 2. +@end itemize + +Here are some things you should do the first time (or so) that you use +the Agent. + +@itemize @bullet + +@item +Decide which servers should be covered by the Agent. If you have a mail +backend, it would probably be nonsensical to have it covered by the +Agent. Go to the server buffer (@kbd{^} in the group buffer) and press +@kbd{J a} the server (or servers) that you wish to have covered by the +Agent (@pxref{Server Agent Commands}). This will typically be only the +primary select method, which is listed on the bottom in the buffer. + +@item +Decide on download policy. @xref{Agent Categories} + +@item +Uhm... that's it. +@end itemize + + +@node Agent Categories +@subsection Agent Categories + +One of the main reasons to integrate the news transport layer into the +newsreader is to allow greater control over what articles to download. +There's not much point in downloading huge amounts of articles, just to +find out that you're not interested in reading any of them. It's better +to be somewhat more conservative in choosing what to download, and then +mark the articles for downloading manually if it should turn out that +you're interested in the articles anyway. + +The main way to control what is to be downloaded is to create a +@dfn{category} and then assign some (or all) groups to this category. +Gnus has its own buffer for creating and managing categories. + +@menu +* Category Syntax:: What a category looks like. +* The Category Buffer:: A buffer for maintaining categories. +* Category Variables:: Customize'r'Us. +@end menu + + +@node Category Syntax +@subsubsection Category Syntax + +A category consists of two things. + +@enumerate +@item +A predicate which (generally) gives a rough outline of which articles +are eligible for downloading; and + +@item +a score rule which (generally) gives you a finer granularity when +deciding what articles to download. (Note that this @dfn{download +score} is wholly unrelated to normal scores.) +@end enumerate + +A predicate consists of predicates with logical operators sprinkled in +between. + +Perhaps some examples are in order. + +Here's a simple predicate. (It's the default predicate, in fact, used +for all groups that don't belong to any other category.) + +@lisp +short +@end lisp + +Quite simple, eh? This predicate is true if and only if the article is +short (for some value of ``short''). + +Here's a more complex predicate: + +@lisp +(or high + (and + (not low) + (not long))) +@end lisp + +This means that an article should be downloaded if it has a high score, +or if the score is not low and the article is not long. You get the +drift. + +The available logical operators are @code{or}, @code{and} and +@code{not}. (If you prefer, you can use the more ``C''-ish operators +@samp{|}, @code{&} and @code{!} instead.) + +The following predicates are pre-defined, but if none of these fit what +you want to do, you can write your own. + +@table @code +@item short +True iff the article is shorter than @code{gnus-agent-short-article} +lines; default 100. + +@item long +True iff the article is longer than @code{gnus-agent-long-article} +lines; default 200. + +@item low +True iff the article has a download score less than +@code{gnus-agent-low-score}; default 0. + +@item high +True iff the article has a download score greater than +@code{gnus-agent-high-score}; default 0. + +@item spam +True iff the Gnus Agent guesses that the article is spam. The +heuristics may change over time, but at present it just computes a +checksum and sees whether articles match. + +@item true +Always true. + +@item false +Always false. +@end table + +If you want to create your own predicate function, here's what you have +to know: The functions are called with no parameters, but the +@code{gnus-headers} and @code{gnus-score} dynamic variables are bound to +useful values. + +Now, the syntax of the download score is the same as the syntax of +normal score files, except that all elements that require actually +seeing the article itself are verboten. This means that only the +following headers can be scored on: @code{From}, @code{Subject}, +@code{Date}, @code{Xref}, @code{Lines}, @code{Chars}, @code{Message-ID}, +and @code{References}. + + +@node The Category Buffer +@subsubsection The Category Buffer + +You'd normally do all category maintenance from the category buffer. +When you enter it for the first time (with the @kbd{J c} command from +the group buffer), you'll only see the @code{default} category. + +The following commands are available in this buffer: + +@table @kbd +@item q +@kindex q (Category) +@findex gnus-category-exit +Return to the group buffer (@code{gnus-category-exit}). + +@item k +@kindex k (Category) +@findex gnus-category-kill +Kill the current category (@code{gnus-category-kill}). + +@item c +@kindex c (Category) +@findex gnus-category-copy +Copy the current category (@code{gnus-category-copy}). + +@item a +@kindex a (Category) +@findex gnus-category-add +Add a new category (@code{gnus-category-add}). + +@item p +@kindex p (Category) +@findex gnus-category-edit-predicate +Edit the predicate of the current category +(@code{gnus-category-edit-predicate}). + +@item g +@kindex g (Category) +@findex gnus-category-edit-groups +Edit the list of groups belonging to the current category +(@code{gnus-category-edit-groups}). + +@item s +@kindex s (Category) +@findex gnus-category-edit-score +Edit the download score rule of the current category +(@code{gnus-category-edit-score}). + +@item l +@kindex l (Category) +@findex gnus-category-list +List all the categories (@code{gnus-category-list}). +@end table + + +@node Category Variables +@subsubsection Category Variables + +@table @code +@item gnus-category-mode-hook +@vindex gnus-category-mode-hook +Hook run in category buffers. + +@item gnus-category-line-format +@vindex gnus-category-line-format +Format of the lines in the category buffer (@pxref{Formatting +Variables}). Legal elements are: + +@table @samp +@item c +The name of the category. + +@item g +The number of groups in the category. +@end table + +@item gnus-category-mode-line-format +@vindex gnus-category-mode-line-format +Format of the category mode line. + +@item gnus-agent-short-article +@vindex gnus-agent-short-article +Articles that have fewer lines than this are short. Default 100. + +@item gnus-agent-long-article +@vindex gnus-agent-long-article +Articles that have more lines than this are long. Default 200. + +@item gnus-agent-low-score +@vindex gnus-agent-low-score +Articles that have a score lower than this have a low score. Default +0. + +@item gnus-agent-high-score +@vindex gnus-agent-high-score +Articles that have a score higher than this have a high score. Default +0. + +@end table + + +@node Agent Commands +@subsection Agent Commands + +All the Gnus Agent commands are on the @kbd{J} submap. The @kbd{J j} +(@code{gnus-agent-toggle-plugged} command works in all modes, and +toggles the plugged/unplugged state of the Gnus Agent. + + +@menu +* Group Agent Commands:: +* Summary Agent Commands:: +* Server Agent Commands:: +@end menu + + +@node Group Agent Commands +@subsubsection Group Agent Commands + +@table @kbd +@item J u +@kindex J u (Agent Group) +@findex gnus-agent-fetch-group +Fetch all eligible articles in the current group +(@code{gnus-agent-fetch-group}). + +@item J c +@kindex J c (Agent Group) +@findex gnus-enter-category-buffer +Enter the Agent category buffer (@code{gnus-enter-category-buffer}). + +@item J s +@kindex J s (Agent Group) +@findex gnus-agent-fetch-session +Fetch all eligible articles in all groups +(@code{gnus-agent-fetch-session}). + +@item J S +@kindex J S (Agent Group) +@findex gnus-group-send-drafts +Send all sendable messages in the draft group +(@code{gnus-agent-fetch-session}). @xref{Drafts} + +@item J a +@kindex J a (Agent Group) +@findex gnus-agent-add-group +Add the current group to an Agent category +(@code{gnus-agent-add-group}). + +@end table + + +@node Summary Agent Commands +@subsubsection Summary Agent Commands + +@table @kbd +@item J # +@kindex J # (Agent Summary) +@findex gnus-agent-mark-article +Mark the article for downloading (@code{gnus-agent-mark-article}). + +@item J M-# +@kindex J M-# (Agent Summary) +@findex gnus-agent-unmark-article +Remove the downloading mark from the article +(@code{gnus-agent-unmark-article}). + +@item @@ +@kindex @@ (Agent Summary) +@findex gnus-agent-toggle-mark +Toggle whether to download the article (@code{gnus-agent-toggle-mark}). + +@item J c +@kindex J c (Agent Summary) +@findex gnus-agent-catchup +Mark all undownloaded articles as read (@code{gnus-agent-catchup}). + +@end table + + +@node Server Agent Commands +@subsubsection Server Agent Commands + +@table @kbd +@item J a +@kindex J a (Agent Server) +@findex gnus-agent-add-server +Add the current server to the list of servers covered by the Gnus Agent +(@code{gnus-agent-add-server}). + +@item J r +@kindex J r (Agent Server) +@findex gnus-agent-remove-server +Remove the current server from the list of servers covered by the Gnus +Agent (@code{gnus-agent-remove-server}). + +@end table + + +@node Outgoing Messages +@subsection Outgoing Messages + +When Gnus is unplugged, all outgoing messages (both mail and news) are +stored in the draft groups (@pxref{Drafts}). You can view them there +after posting, and edit them at will. + +When Gnus is plugged again, you can send the messages either from the +draft group with the special commands available there, or you can use +the @kbd{J S} command in the group buffer to send all the sendable +messages in the draft group. + + + +@node Agent Variables +@subsection Agent Variables + +@table @code +@item gnus-agent-directory +@vindex gnus-agent-directory +Where the Gnus Agent will store its files. The default is +@file{~/News/agent/}. + +@item gnus-agent-plugged-hook +@vindex gnus-agent-plugged-hook +Hook run when connecting to the network. + +@item gnus-agent-unplugged-hook +@vindex gnus-agent-unplugged-hook +Hook run when disconnecting from the network. + +@end table + + +@node Example Setup +@subsection Example Setup + +If you don't want to read this manual, and you have a fairly standard +setup, you may be able to use something like the following as your +@file{.gnus.el} file to get started. + +@lisp +;;; Define how Gnus is to fetch news. We do this over NNTP +;;; from your ISP's server. +(setq gnus-select-method '(nntp "nntp.your-isp.com")) + +;;; Define how Gnus is to read your mail. We read mail from +;;; your ISP's POP server. +(setenv "MAILHOST" "pop.your-isp.com") +(setq nnmail-spool-file "po:username") + +;;; Say how Gnus is to store the mail. We use nnml groups. +(setq gnus-secondary-select-methods '((nnml ""))) + +;;; Make Gnus into an offline newsreader. +(gnus-agentize) +@end lisp + +That should be it, basically. Put that in your @file{~/.gnus.el} file, +edit to suit your needs, start up PPP (or whatever), and type @kbd{M-x +gnus}. + +If this is the first time you've run Gnus, you will be subscribed +automatically to a few default newsgroups. You'll probably want to +subscribe to more groups, and to do that, you have to query the +@sc{nntp} server for a complete list of groups with the @kbd{A A} +command. This usually takes quite a while, but you only have to do it +once. + +After reading and parsing a while, you'll be presented with a list of +groups. Subscribe to the ones you want to read with the @kbd{u} +command. @kbd{l} to make all the killed groups disappear after you've +subscribe to all the groups you want to read. (@kbd{A k} will bring +back all the killed groups.) + +You can now read the groups at once, or you can download the articles +with the @kbd{J s} command. And then read the rest of this manual to +find out which of the other gazillion things you want to customize. + + +@node Scoring +@chapter Scoring +@cindex scoring + +Other people use @dfn{kill files}, but we here at Gnus Towers like +scoring better than killing, so we'd rather switch than fight. They do +something completely different as well, so sit up straight and pay +attention! + +@vindex gnus-summary-mark-below +All articles have a default score (@code{gnus-summary-default-score}), +which is 0 by default. This score may be raised or lowered either +interactively or by score files. Articles that have a score lower than +@code{gnus-summary-mark-below} are marked as read. + +Gnus will read any @dfn{score files} that apply to the current group +before generating the summary buffer. + +There are several commands in the summary buffer that insert score +entries based on the current article. You can, for instance, ask Gnus to +lower or increase the score of all articles with a certain subject. + +There are two sorts of scoring entries: Permanent and temporary. +Temporary score entries are self-expiring entries. Any entries that are +temporary and have not been used for, say, a week, will be removed +silently to help keep the sizes of the score files down. + +@menu +* Summary Score Commands:: Adding score entries for the current group. +* Group Score Commands:: General score commands. +* Score Variables:: Customize your scoring. (My, what terminology). +* Score File Format:: What a score file may contain. +* Score File Editing:: You can edit score files by hand as well. +* Adaptive Scoring:: Big Sister Gnus knows what you read. +* Home Score File:: How to say where new score entries are to go. +* Followups To Yourself:: Having Gnus notice when people answer you. +* Scoring Tips:: How to score effectively. +* Reverse Scoring:: That problem child of old is not problem. +* Global Score Files:: Earth-spanning, ear-splitting score files. +* Kill Files:: They are still here, but they can be ignored. +* Converting Kill Files:: Translating kill files to score files. +* GroupLens:: Getting predictions on what you like to read. +* Advanced Scoring:: Using logical expressions to build score rules. +* Score Decays:: It can be useful to let scores wither away. +@end menu + + +@node Summary Score Commands +@section Summary Score Commands +@cindex score commands + +The score commands that alter score entries do not actually modify real +score files. That would be too inefficient. Gnus maintains a cache of +previously loaded score files, one of which is considered the +@dfn{current score file alist}. The score commands simply insert +entries into this list, and upon group exit, this list is saved. + +The current score file is by default the group's local score file, even +if no such score file actually exists. To insert score commands into +some other score file (e.g. @file{all.SCORE}), you must first make this +score file the current one. + +General score commands that don't actually change the score file: + +@table @kbd + +@item V s +@kindex V s (Summary) +@findex gnus-summary-set-score +Set the score of the current article (@code{gnus-summary-set-score}). + +@item V S +@kindex V S (Summary) +@findex gnus-summary-current-score +Display the score of the current article +(@code{gnus-summary-current-score}). + +@item V t +@kindex V t (Summary) +@findex gnus-score-find-trace +Display all score rules that have been used on the current article +(@code{gnus-score-find-trace}). + +@item V R +@kindex V R (Summary) +@findex gnus-summary-rescore +Run the current summary through the scoring process +(@code{gnus-summary-rescore}). This might be useful if you're playing +around with your score files behind Gnus' back and want to see the +effect you're having. + +@item V a +@kindex V a (Summary) +@findex gnus-summary-score-entry +Add a new score entry, and allow specifying all elements +(@code{gnus-summary-score-entry}). + +@item V c +@kindex V c (Summary) +@findex gnus-score-change-score-file +Make a different score file the current +(@code{gnus-score-change-score-file}). + +@item V e +@kindex V e (Summary) +@findex gnus-score-edit-current-scores +Edit the current score file (@code{gnus-score-edit-current-scores}). +You will be popped into a @code{gnus-score-mode} buffer (@pxref{Score +File Editing}). + +@item V f +@kindex V f (Summary) +@findex gnus-score-edit-file +Edit a score file and make this score file the current one +(@code{gnus-score-edit-file}). + +@item V F +@kindex V F (Summary) +@findex gnus-score-flush-cache +Flush the score cache (@code{gnus-score-flush-cache}). This is useful +after editing score files. + +@item V C +@kindex V C (Summary) +@findex gnus-score-customize +Customize a score file in a visually pleasing manner +(@code{gnus-score-customize}). + +@end table + +The rest of these commands modify the local score file. + +@table @kbd + +@item V m +@kindex V m (Summary) +@findex gnus-score-set-mark-below +Prompt for a score, and mark all articles with a score below this as +read (@code{gnus-score-set-mark-below}). + +@item V x +@kindex V x (Summary) +@findex gnus-score-set-expunge-below +Prompt for a score, and add a score rule to the current score file to +expunge all articles below this score +(@code{gnus-score-set-expunge-below}). +@end table + +The keystrokes for actually making score entries follow a very regular +pattern, so there's no need to list all the commands. (Hundreds of +them.) + +@findex gnus-summary-increase-score +@findex gnus-summary-lower-score + +@enumerate +@item +The first key is either @kbd{I} (upper case i) for increasing the score +or @kbd{L} for lowering the score. +@item +The second key says what header you want to score on. The following +keys are available: +@table @kbd + +@item a +Score on the author name. + +@item s +Score on the subject line. + +@item x +Score on the Xref line---i.e., the cross-posting line. + +@item t +Score on thread---the References line. + +@item d +Score on the date. + +@item l +Score on the number of lines. + +@item i +Score on the Message-ID. + +@item f +Score on followups. + +@item b +Score on the body. + +@item h +Score on the head. +@end table + +@item +The third key is the match type. Which match types are valid depends on +what headers you are scoring on. + +@table @code + +@item strings + +@table @kbd + +@item e +Exact matching. + +@item s +Substring matching. + +@item f +Fuzzy matching (@pxref{Fuzzy Matching}). + +@item r +Regexp matching +@end table + +@item date +@table @kbd + +@item b +Before date. + +@item a +At date. + +@item n +This date. +@end table + +@item number +@table @kbd + +@item < +Less than number. + +@item = +Equal to number. + +@item > +Greater than number. +@end table +@end table + +@item +The fourth and final key says whether this is a temporary (i.e., expiring) +score entry, or a permanent (i.e., non-expiring) score entry, or whether +it is to be done immediately, without adding to the score file. +@table @kbd + +@item t +Temporary score entry. + +@item p +Permanent score entry. + +@item i +Immediately scoring. +@end table + +@end enumerate + +So, let's say you want to increase the score on the current author with +exact matching permanently: @kbd{I a e p}. If you want to lower the +score based on the subject line, using substring matching, and make a +temporary score entry: @kbd{L s s t}. Pretty easy. + +To make things a bit more complicated, there are shortcuts. If you use +a capital letter on either the second or third keys, Gnus will use +defaults for the remaining one or two keystrokes. The defaults are +``substring'' and ``temporary''. So @kbd{I A} is the same as @kbd{I a s +t}, and @kbd{I a R} is the same as @kbd{I a r t}. + +These functions take both the numerical prefix and the symbolic prefix +(@pxref{Symbolic Prefixes}). A numerical prefix says how much to lower +(or increase) the score of the article. A symbolic prefix of @code{a} +says to use the @file{all.SCORE} file for the command instead of the +current score file. + +@vindex gnus-score-mimic-keymap +The @code{gnus-score-mimic-keymap} says whether these commands will +pretend they are keymaps or not. + + +@node Group Score Commands +@section Group Score Commands +@cindex group score commands + +There aren't many of these as yet, I'm afraid. + +@table @kbd + +@item W f +@kindex W f (Group) +@findex gnus-score-flush-cache +Gnus maintains a cache of score alists to avoid having to reload them +all the time. This command will flush the cache +(@code{gnus-score-flush-cache}). + +@end table + + +@node Score Variables +@section Score Variables +@cindex score variables + +@table @code + +@item gnus-use-scoring +@vindex gnus-use-scoring +If @code{nil}, Gnus will not check for score files, and will not, in +general, do any score-related work. This is @code{t} by default. + +@item gnus-kill-killed +@vindex gnus-kill-killed +If this variable is @code{nil}, Gnus will never apply score files to +articles that have already been through the kill process. While this +may save you lots of time, it also means that if you apply a kill file +to a group, and then change the kill file and want to run it over you +group again to kill more articles, it won't work. You have to set this +variable to @code{t} to do that. (It is @code{t} by default.) + +@item gnus-kill-files-directory +@vindex gnus-kill-files-directory +All kill and score files will be stored in this directory, which is +initialized from the @code{SAVEDIR} environment variable by default. +This is @file{~/News/} by default. + +@item gnus-score-file-suffix +@vindex gnus-score-file-suffix +Suffix to add to the group name to arrive at the score file name +(@samp{SCORE} by default.) + +@item gnus-score-uncacheable-files +@vindex gnus-score-uncacheable-files +@cindex score cache +All score files are normally cached to avoid excessive re-loading of +score files. However, if this might make you Emacs grow big and +bloated, so this regexp can be used to weed out score files unlikely to be needed again. It would be a bad idea to deny caching of +@file{all.SCORE}, while it might be a good idea to not cache +@file{comp.infosystems.www.authoring.misc.ADAPT}. In fact, this +variable is @samp{ADAPT$} by default, so no adaptive score files will +be cached. + +@item gnus-save-score +@vindex gnus-save-score +If you have really complicated score files, and do lots of batch +scoring, then you might set this variable to @code{t}. This will make +Gnus save the scores into the @file{.newsrc.eld} file. + +@item gnus-score-interactive-default-score +@vindex gnus-score-interactive-default-score +Score used by all the interactive raise/lower commands to raise/lower +score with. Default is 1000, which may seem excessive, but this is to +ensure that the adaptive scoring scheme gets enough room to play with. +We don't want the small changes from the adaptive scoring to overwrite +manually entered data. + +@item gnus-summary-default-score +@vindex gnus-summary-default-score +Default score of an article, which is 0 by default. + +@item gnus-summary-expunge-below +@vindex gnus-summary-expunge-below +Don't display the summary lines of articles that have scores lower than +this variable. This is @code{nil} by default, which means that no +articles will be hidden. + +@item gnus-score-over-mark +@vindex gnus-score-over-mark +Mark (in the third column) used for articles with a score over the +default. Default is @samp{+}. + +@item gnus-score-below-mark +@vindex gnus-score-below-mark +Mark (in the third column) used for articles with a score below the +default. Default is @samp{-}. + +@item gnus-score-find-score-files-function +@vindex gnus-score-find-score-files-function +Function used to find score files for the current group. This function +is called with the name of the group as the argument. + +Predefined functions available are: +@table @code + +@item gnus-score-find-single +@findex gnus-score-find-single +Only apply the group's own score file. + +@item gnus-score-find-bnews +@findex gnus-score-find-bnews +Apply all score files that match, using bnews syntax. This is the +default. If the current group is @samp{gnu.emacs.gnus}, for instance, +@file{all.emacs.all.SCORE}, @file{not.alt.all.SCORE} and +@file{gnu.all.SCORE} would all apply. In short, the instances of +@samp{all} in the score file names are translated into @samp{.+}, and +then a regexp match is done. + +This means that if you have some score entries that you want to apply to +all groups, then you put those entries in the @file{all.SCORE} file. + +The score files are applied in a semi-random order, although Gnus will +try to apply the more general score files before the more specific score +files. It does this by looking at the number of elements in the score +file names---discarding the @samp{all} elements. + +@item gnus-score-find-hierarchical +@findex gnus-score-find-hierarchical +Apply all score files from all the parent groups. This means that you +can't have score files like @file{all.SCORE}, but you can have +@file{SCORE}, @file{comp.SCORE} and @file{comp.emacs.SCORE}. + +@end table +This variable can also be a list of functions. In that case, all these +functions will be called, and all the returned lists of score files will +be applied. These functions can also return lists of score alists +directly. In that case, the functions that return these non-file score +alists should probably be placed before the ``real'' score file +functions, to ensure that the last score file returned is the local +score file. Phu. + +@item gnus-score-expiry-days +@vindex gnus-score-expiry-days +This variable says how many days should pass before an unused score file +entry is expired. If this variable is @code{nil}, no score file entries +are expired. It's 7 by default. + +@item gnus-update-score-entry-dates +@vindex gnus-update-score-entry-dates +If this variable is non-@code{nil}, matching score entries will have +their dates updated. (This is how Gnus controls expiry---all +non-matching entries will become too old while matching entries will +stay fresh and young.) However, if you set this variable to @code{nil}, +even matching entries will grow old and will have to face that oh-so +grim reaper. + +@item gnus-score-after-write-file-function +@vindex gnus-score-after-write-file-function +Function called with the name of the score file just written. + +@end table + + +@node Score File Format +@section Score File Format +@cindex score file format + +A score file is an @code{emacs-lisp} file that normally contains just a +single form. Casual users are not expected to edit these files; +everything can be changed from the summary buffer. + +Anyway, if you'd like to dig into it yourself, here's an example: + +@lisp +(("from" + ("Lars Ingebrigtsen" -10000) + ("Per Abrahamsen") + ("larsi\\|lmi" -50000 nil R)) + ("subject" + ("Ding is Badd" nil 728373)) + ("xref" + ("alt.politics" -1000 728372 s)) + ("lines" + (2 -100 nil <)) + (mark 0) + (expunge -1000) + (mark-and-expunge -10) + (read-only nil) + (orphan -10) + (adapt t) + (files "/hom/larsi/News/gnu.SCORE") + (exclude-files "all.SCORE") + (local (gnus-newsgroup-auto-expire t) + (gnus-summary-make-false-root empty)) + (eval (ding))) +@end lisp + +This example demonstrates most score file elements. For a different +approach, see @pxref{Advanced Scoring}. + +Even though this looks much like lisp code, nothing here is actually +@code{eval}ed. The lisp reader is used to read this form, though, so it +has to be valid syntactically, if not semantically. + +Six keys are supported by this alist: + +@table @code + +@item STRING +If the key is a string, it is the name of the header to perform the +match on. Scoring can only be performed on these eight headers: +@code{From}, @code{Subject}, @code{References}, @code{Message-ID}, +@code{Xref}, @code{Lines}, @code{Chars} and @code{Date}. In addition to +these headers, there are three strings to tell Gnus to fetch the entire +article and do the match on larger parts of the article: @code{Body} +will perform the match on the body of the article, @code{Head} will +perform the match on the head of the article, and @code{All} will +perform the match on the entire article. Note that using any of these +last three keys will slow down group entry @emph{considerably}. The +final ``header'' you can score on is @code{Followup}. These score +entries will result in new score entries being added for all follow-ups +to articles that matches these score entries. + +Following this key is a arbitrary number of score entries, where each +score entry has one to four elements. +@enumerate + +@item +The first element is the @dfn{match element}. On most headers this will +be a string, but on the Lines and Chars headers, this must be an +integer. + +@item +If the second element is present, it should be a number---the @dfn{score +element}. This number should be an integer in the neginf to posinf +interval. This number is added to the score of the article if the match +is successful. If this element is not present, the +@code{gnus-score-interactive-default-score} number will be used +instead. This is 1000 by default. + +@item +If the third element is present, it should be a number---the @dfn{date +element}. This date says when the last time this score entry matched, +which provides a mechanism for expiring the score entries. It this +element is not present, the score entry is permanent. The date is +represented by the number of days since December 31, 1 BCE. + +@item +If the fourth element is present, it should be a symbol---the @dfn{type +element}. This element specifies what function should be used to see +whether this score entry matches the article. What match types that can +be used depends on what header you wish to perform the match on. +@table @dfn + +@item From, Subject, References, Xref, Message-ID +For most header types, there are the @code{r} and @code{R} (regexp), as +well as @code{s} and @code{S} (substring) types, and @code{e} and +@code{E} (exact match), and @code{w} (word match) types. If this +element is not present, Gnus will assume that substring matching should +be used. @code{R}, @code{S}, and @code{E} differ from the others in +that the matches will be done in a case-sensitive manner. All these +one-letter types are really just abbreviations for the @code{regexp}, +@code{string}, @code{exact}, and @code{word} types, which you can use +instead, if you feel like. + +@item Lines, Chars +These two headers use different match types: @code{<}, @code{>}, +@code{=}, @code{>=} and @code{<=}. When matching on @code{Lines}, be +careful because some backends (like @code{nndir}) do not generate +@code{Lines} header, so every article ends up being marked as having 0 +lines. This can lead to strange results if you happen to lower score of +the articles with few lines. + +@item Date +For the Date header we have three kinda silly match types: +@code{before}, @code{at} and @code{after}. I can't really imagine this +ever being useful, but, like, it would feel kinda silly not to provide +this function. Just in case. You never know. Better safe than sorry. +Once burnt, twice shy. Don't judge a book by its cover. Never not have +sex on a first date. (I have been told that at least one person, and I +quote, ``found this function indispensable'', however.) + +@cindex ISO8601 +@cindex date +A more useful match type is @code{regexp}. With it, you can match the +date string using a regular expression. The date is normalized to +ISO8601 compact format first---@var{YYYYMMDD}@code{T}@var{HHMMSS}. If +you want to match all articles that have been posted on April 1st in +every year, you could use @samp{....0401.........} as a match string, +for instance. (Note that the date is kept in its original time zone, so +this will match articles that were posted when it was April 1st where +the article was posted from. Time zones are such wholesome fun for the +whole family, eh?) + +@item Head, Body, All +These three match keys use the same match types as the @code{From} (etc) +header uses. + +@item Followup +This match key is somewhat special, in that it will match the +@code{From} header, and affect the score of not only the matching +articles, but also all followups to the matching articles. This allows +you e.g. increase the score of followups to your own articles, or +decrease the score of followups to the articles of some known +trouble-maker. Uses the same match types as the @code{From} header +uses. (Using this match key will lead to creation of @file{ADAPT} +files.) + +@item Thread +This match key works along the same lines as the @code{Followup} match +key. If you say that you want to score on a (sub-)thread started by an article with a @code{Message-ID} @var{X}, then you add a +@samp{thread} match. This will add a new @samp{thread} match for each +article that has @var{X} in its @code{References} header. (These new +@samp{thread} matches will use the @code{Message-ID}s of these matching +articles.) This will ensure that you can raise/lower the score of an +entire thread, even though some articles in the thread may not have +complete @code{References} headers. Note that using this may lead to +undeterministic scores of the articles in the thread. (Using this match +key will lead to creation of @file{ADAPT} files.) +@end table +@end enumerate + +@cindex Score File Atoms +@item mark +The value of this entry should be a number. Any articles with a score +lower than this number will be marked as read. + +@item expunge +The value of this entry should be a number. Any articles with a score +lower than this number will be removed from the summary buffer. + +@item mark-and-expunge +The value of this entry should be a number. Any articles with a score +lower than this number will be marked as read and removed from the +summary buffer. + +@item thread-mark-and-expunge +The value of this entry should be a number. All articles that belong to +a thread that has a total score below this number will be marked as read +and removed from the summary buffer. @code{gnus-thread-score-function} +says how to compute the total score for a thread. + +@item files +The value of this entry should be any number of file names. These files +are assumed to be score files as well, and will be loaded the same way +this one was. + +@item exclude-files +The clue of this entry should be any number of files. These files will +not be loaded, even though they would normally be so, for some reason or +other. + +@item eval +The value of this entry will be @code{eval}el. This element will be +ignored when handling global score files. + +@item read-only +Read-only score files will not be updated or saved. Global score files +should feature this atom (@pxref{Global Score Files}). + +@item orphan +The value of this entry should be a number. Articles that do not have +parents will get this number added to their scores. Imagine you follow +some high-volume newsgroup, like @samp{comp.lang.c}. Most likely you +will only follow a few of the threads, also want to see any new threads. + +You can do this with the following two score file entries: + +@example + (orphan -500) + (mark-and-expunge -100) +@end example + +When you enter the group the first time, you will only see the new +threads. You then raise the score of the threads that you find +interesting (with @kbd{I T} or @kbd{I S}), and ignore (@kbd{C y}) the +rest. Next time you enter the group, you will see new articles in the +interesting threads, plus any new threads. + +I.e.---the orphan score atom is for high-volume groups where there +exist a few interesting threads which can't be found automatically by +ordinary scoring rules. + +@item adapt +This entry controls the adaptive scoring. If it is @code{t}, the +default adaptive scoring rules will be used. If it is @code{ignore}, no +adaptive scoring will be performed on this group. If it is a list, this +list will be used as the adaptive scoring rules. If it isn't present, +or is something other than @code{t} or @code{ignore}, the default +adaptive scoring rules will be used. If you want to use adaptive +scoring on most groups, you'd set @code{gnus-use-adaptive-scoring} to +@code{t}, and insert an @code{(adapt ignore)} in the groups where you do +not want adaptive scoring. If you only want adaptive scoring in a few +groups, you'd set @code{gnus-use-adaptive-scoring} to @code{nil}, and +insert @code{(adapt t)} in the score files of the groups where you want +it. + +@item adapt-file +All adaptive score entries will go to the file named by this entry. It +will also be applied when entering the group. This atom might be handy +if you want to adapt on several groups at once, using the same adaptive +file for a number of groups. + +@item local +@cindex local variables +The value of this entry should be a list of @code{(VAR VALUE)} pairs. +Each @var{var} will be made buffer-local to the current summary buffer, +and set to the value specified. This is a convenient, if somewhat +strange, way of setting variables in some groups if you don't like hooks +much. Note that the @var{value} won't be evaluated. +@end table + + +@node Score File Editing +@section Score File Editing + +You normally enter all scoring commands from the summary buffer, but you +might feel the urge to edit them by hand as well, so we've supplied you +with a mode for that. + +It's simply a slightly customized @code{emacs-lisp} mode, with these +additional commands: + +@table @kbd + +@item C-c C-c +@kindex C-c C-c (Score) +@findex gnus-score-edit-done +Save the changes you have made and return to the summary buffer +(@code{gnus-score-edit-done}). + +@item C-c C-d +@kindex C-c C-d (Score) +@findex gnus-score-edit-insert-date +Insert the current date in numerical format +(@code{gnus-score-edit-insert-date}). This is really the day number, if +you were wondering. + +@item C-c C-p +@kindex C-c C-p (Score) +@findex gnus-score-pretty-print +The adaptive score files are saved in an unformatted fashion. If you +intend to read one of these files, you want to @dfn{pretty print} it +first. This command (@code{gnus-score-pretty-print}) does that for +you. + +@end table + +Type @kbd{M-x gnus-score-mode} to use this mode. + +@vindex gnus-score-mode-hook +@code{gnus-score-menu-hook} is run in score mode buffers. + +In the summary buffer you can use commands like @kbd{V f} and @kbd{V +e} to begin editing score files. + + +@node Adaptive Scoring +@section Adaptive Scoring +@cindex adaptive scoring + +If all this scoring is getting you down, Gnus has a way of making it all +happen automatically---as if by magic. Or rather, as if by artificial +stupidity, to be precise. + +@vindex gnus-use-adaptive-scoring +When you read an article, or mark an article as read, or kill an +article, you leave marks behind. On exit from the group, Gnus can sniff +these marks and add score elements depending on what marks it finds. +You turn on this ability by setting @code{gnus-use-adaptive-scoring} to +@code{t} or @code{(line)}. If you want score adaptively on separate +words appearing in the subjects, you should set this variable to +@code{(word)}. If you want to use both adaptive methods, set this +variable to @code{(word line)}. + +@vindex gnus-default-adaptive-score-alist +To give you complete control over the scoring process, you can customize +the @code{gnus-default-adaptive-score-alist} variable. For instance, it +might look something like this: + +@lisp +(defvar gnus-default-adaptive-score-alist + '((gnus-unread-mark) + (gnus-ticked-mark (from 4)) + (gnus-dormant-mark (from 5)) + (gnus-del-mark (from -4) (subject -1)) + (gnus-read-mark (from 4) (subject 2)) + (gnus-expirable-mark (from -1) (subject -1)) + (gnus-killed-mark (from -1) (subject -3)) + (gnus-kill-file-mark) + (gnus-ancient-mark) + (gnus-low-score-mark) + (gnus-catchup-mark (from -1) (subject -1)))) +@end lisp + +As you see, each element in this alist has a mark as a key (either a +variable name or a ``real'' mark---a character). Following this key is +a arbitrary number of header/score pairs. If there are no header/score +pairs following the key, no adaptive scoring will be done on articles +that have that key as the article mark. For instance, articles with +@code{gnus-unread-mark} in the example above will not get adaptive score +entries. + +Each article can have only one mark, so just a single of these rules +will be applied to each article. + +To take @code{gnus-del-mark} as an example---this alist says that all +articles that have that mark (i.e., are marked with @samp{D}) will have a +score entry added to lower based on the @code{From} header by -4, and +lowered by @code{Subject} by -1. Change this to fit your prejudices. + +If you have marked 10 articles with the same subject with +@code{gnus-del-mark}, the rule for that mark will be applied ten times. +That means that that subject will get a score of ten times -1, which +should be, unless I'm much mistaken, -10. + +If you have auto-expirable (mail) groups (@pxref{Expiring Mail}), all +the read articles will be marked with the @samp{E} mark. This'll +probably make adaptive scoring slightly impossible, so auto-expiring and +adaptive scoring doesn't really mix very well. + +The headers you can score on are @code{from}, @code{subject}, +@code{message-id}, @code{references}, @code{xref}, @code{lines}, +@code{chars} and @code{date}. In addition, you can score on +@code{followup}, which will create an adaptive score entry that matches +on the @code{References} header using the @code{Message-ID} of the +current article, thereby matching the following thread. + +You can also score on @code{thread}, which will try to score all +articles that appear in a thread. @code{thread} matches uses a +@code{Message-ID} to match on the @code{References} header of the +article. If the match is made, the @code{Message-ID} of the article is +added to the @code{thread} rule. (Think about it. I'd recommend two +aspirins afterwards.) + +If you use this scheme, you should set the score file atom @code{mark} +to something small---like -300, perhaps, to avoid having small random +changes result in articles getting marked as read. + +After using adaptive scoring for a week or so, Gnus should start to +become properly trained and enhance the authors you like best, and kill +the authors you like least, without you having to say so explicitly. + +You can control what groups the adaptive scoring is to be performed on +by using the score files (@pxref{Score File Format}). This will also +let you use different rules in different groups. + +@vindex gnus-adaptive-file-suffix +The adaptive score entries will be put into a file where the name is the +group name with @code{gnus-adaptive-file-suffix} appended. The default +is @samp{ADAPT}. + +@vindex gnus-score-exact-adapt-limit +When doing adaptive scoring, substring or fuzzy matching would probably +give you the best results in most cases. However, if the header one +matches is short, the possibility for false positives is great, so if +the length of the match is less than +@code{gnus-score-exact-adapt-limit}, exact matching will be used. If +this variable is @code{nil}, exact matching will always be used to avoid +this problem. + +@vindex gnus-default-adaptive-word-score-alist +As mentioned above, you can adapt either on individual words or entire +headers. If you adapt on words, the +@code{gnus-default-adaptive-word-score-alist} variable says what score +each instance of a word should add given a mark. + +@lisp +(setq gnus-default-adaptive-word-score-alist + `((,gnus-read-mark . 30) + (,gnus-catchup-mark . -10) + (,gnus-killed-mark . -20) + (,gnus-del-mark . -15))) +@end lisp + +This is the default value. If you have adaption on words enabled, every +word that appears in subjects of articles marked with +@code{gnus-read-mark} will result in a score rule that increase the +score with 30 points. + +@vindex gnus-default-ignored-adaptive-words +@vindex gnus-ignored-adaptive-words +Words that appear in the @code{gnus-default-ignored-adaptive-words} list +will be ignored. If you wish to add more words to be ignored, use the +@code{gnus-ignored-adaptive-words} list instead. + +@vindex gnus-adaptive-word-syntax-table +When the scoring is done, @code{gnus-adaptive-word-syntax-table} is the +syntax table in effect. It is similar to the standard syntax table, but +it considers numbers to be non-word-constituent characters. + +After using this scheme for a while, it might be nice to write a +@code{gnus-psychoanalyze-user} command to go through the rules and see +what words you like and what words you don't like. Or perhaps not. + +Note that the adaptive word scoring thing is highly experimental and is +likely to change in the future. Initial impressions seem to indicate +that it's totally useless as it stands. Some more work (involving more +rigorous statistical methods) will have to be done to make this useful. + + +@node Home Score File +@section Home Score File + +The score file where new score file entries will go is called the +@dfn{home score file}. This is normally (and by default) the score file +for the group itself. For instance, the home score file for +@samp{gnu.emacs.gnus} is @file{gnu.emacs.gnus.SCORE}. + +However, this may not be what you want. It is often convenient to share +a common home score file among many groups---all @samp{emacs} groups +could perhaps use the same home score file. + +@vindex gnus-home-score-file +The variable that controls this is @code{gnus-home-score-file}. It can +be: + +@enumerate +@item +A string. Then this file will be used as the home score file for all +groups. + +@item +A function. The result of this function will be used as the home score +file. The function will be called with the name of the group as the +parameter. + +@item +A list. The elements in this list can be: + +@enumerate +@item +@var{(regexp file-name)}. If the @var{regexp} matches the group name, +the @var{file-name} will will be used as the home score file. + +@item +A function. If the function returns non-nil, the result will be used as +the home score file. + +@item +A string. Use the string as the home score file. +@end enumerate + +The list will be traversed from the beginning towards the end looking +for matches. + +@end enumerate + +So, if you want to use just a single score file, you could say: + +@lisp +(setq gnus-home-score-file + "my-total-score-file.SCORE") +@end lisp + +If you want to use @file{gnu.SCORE} for all @samp{gnu} groups and +@file{rec.SCORE} for all @samp{rec} groups (and so on), you can say: + +@lisp +(setq gnus-home-score-file + 'gnus-hierarchial-home-score-file) +@end lisp + +This is a ready-made function provided for your convenience. + +If you want to have one score file for the @samp{emacs} groups and +another for the @samp{comp} groups, while letting all other groups use +their own home score files: + +@lisp +(setq gnus-home-score-file + ;; All groups that match the regexp "\\.emacs" + '("\\.emacs" "emacs.SCORE") + ;; All the comp groups in one score file + ("^comp" "comp.SCORE")) +@end lisp + +@vindex gnus-home-adapt-file +@code{gnus-home-adapt-file} works exactly the same way as +@code{gnus-home-score-file}, but says what the home adaptive score file +is instead. All new adaptive file entries will go into the file +specified by this variable, and the same syntax is allowed. + +In addition to using @code{gnus-home-score-file} and +@code{gnus-home-adapt-file}, you can also use group parameters +(@pxref{Group Parameters}) and topic parameters (@pxref{Topic +Parameters}) to achieve much the same. Group and topic parameters take +precedence over this variable. + + +@node Followups To Yourself +@section Followups To Yourself + +Gnus offers two commands for picking out the @code{Message-ID} header in +the current buffer. Gnus will then add a score rule that scores using +this @code{Message-ID} on the @code{References} header of other +articles. This will, in effect, increase the score of all articles that +respond to the article in the current buffer. Quite useful if you want +to easily note when people answer what you've said. + +@table @code + +@item gnus-score-followup-article +@findex gnus-score-followup-article +This will add a score to articles that directly follow up your own +article. + +@item gnus-score-followup-thread +@findex gnus-score-followup-thread +This will add a score to all articles that appear in a thread ``below'' +your own article. +@end table + +@vindex message-sent-hook +These two functions are both primarily meant to be used in hooks like +@code{message-sent-hook}. + +If you look closely at your own @code{Message-ID}, you'll notice that +the first two or three characters are always the same. Here's two of +mine: + +@example + + +@end example + +So ``my'' ident on this machine is @samp{x6}. This can be +exploited---the following rule will raise the score on all followups to +myself: + +@lisp +("references" + ("" + 1000 nil r)) +@end lisp + +Whether it's the first two or first three characters that are ``yours'' +is system-dependent. + + +@node Scoring Tips +@section Scoring Tips +@cindex scoring tips + +@table @dfn + +@item Crossposts +@cindex crossposts +@cindex scoring crossposts +If you want to lower the score of crossposts, the line to match on is +the @code{Xref} header. +@lisp +("xref" (" talk.politics.misc:" -1000)) +@end lisp + +@item Multiple crossposts +If you want to lower the score of articles that have been crossposted to +more than, say, 3 groups: +@lisp +("xref" ("[^:\n]+:[0-9]+ +[^:\n]+:[0-9]+ +[^:\n]+:[0-9]+" -1000 nil r)) +@end lisp + +@item Matching on the body +This is generally not a very good idea---it takes a very long time. +Gnus actually has to fetch each individual article from the server. But +you might want to anyway, I guess. Even though there are three match +keys (@code{Head}, @code{Body} and @code{All}), you should choose one +and stick with it in each score file. If you use any two, each article +will be fetched @emph{twice}. If you want to match a bit on the +@code{Head} and a bit on the @code{Body}, just use @code{All} for all +the matches. + +@item Marking as read +You will probably want to mark articles that has a score below a certain +number as read. This is most easily achieved by putting the following +in your @file{all.SCORE} file: +@lisp +((mark -100)) +@end lisp +You may also consider doing something similar with @code{expunge}. + +@item Negated character classes +If you say stuff like @code{[^abcd]*}, you may get unexpected results. +That will match newlines, which might lead to, well, The Unknown. Say +@code{[^abcd\n]*} instead. +@end table + + +@node Reverse Scoring +@section Reverse Scoring +@cindex reverse scoring + +If you want to keep just articles that have @samp{Sex with Emacs} in the +subject header, and expunge all other articles, you could put something +like this in your score file: + +@lisp +(("subject" + ("Sex with Emacs" 2)) + (mark 1) + (expunge 1)) +@end lisp + +So, you raise all articles that match @samp{Sex with Emacs} and mark the +rest as read, and expunge them to boot. + + +@node Global Score Files +@section Global Score Files +@cindex global score files + +Sure, other newsreaders have ``global kill files''. These are usually +nothing more than a single kill file that applies to all groups, stored +in the user's home directory. Bah! Puny, weak newsreaders! + +What I'm talking about here are Global Score Files. Score files from +all over the world, from users everywhere, uniting all nations in one +big, happy score file union! Ange-score! New and untested! + +@vindex gnus-global-score-files +All you have to do to use other people's score files is to set the +@code{gnus-global-score-files} variable. One entry for each score file, +or each score file directory. Gnus will decide by itself what score +files are applicable to which group. + +Say you want to use the score file +@file{/ftp@@ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE} and +all score files in the @file{/ftp@@ftp.some-where:/pub/score} directory: + +@lisp +(setq gnus-global-score-files + '("/ftp@@ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE" + "/ftp@@ftp.some-where:/pub/score/")) +@end lisp + +@findex gnus-score-search-global-directories +Simple, eh? Directory names must end with a @samp{/}. These +directories are typically scanned only once during each Gnus session. +If you feel the need to manually re-scan the remote directories, you can +use the @code{gnus-score-search-global-directories} command. + +Note that, at present, using this option will slow down group entry +somewhat. (That is---a lot.) + +If you want to start maintaining score files for other people to use, +just put your score file up for anonymous ftp and announce it to the +world. Become a retro-moderator! Participate in the retro-moderator +wars sure to ensue, where retro-moderators battle it out for the +sympathy of the people, luring them to use their score files on false +premises! Yay! The net is saved! + +Here are some tips for the would-be retro-moderator, off the top of my +head: + +@itemize @bullet + +@item +Articles heavily crossposted are probably junk. +@item +To lower a single inappropriate article, lower by @code{Message-ID}. +@item +Particularly brilliant authors can be raised on a permanent basis. +@item +Authors that repeatedly post off-charter for the group can safely be +lowered out of existence. +@item +Set the @code{mark} and @code{expunge} atoms to obliterate the nastiest +articles completely. + +@item +Use expiring score entries to keep the size of the file down. You +should probably have a long expiry period, though, as some sites keep +old articles for a long time. +@end itemize + +... I wonder whether other newsreaders will support global score files +in the future. @emph{Snicker}. Yup, any day now, newsreaders like Blue +Wave, xrn and 1stReader are bound to implement scoring. Should we start +holding our breath yet? + + +@node Kill Files +@section Kill Files +@cindex kill files + +Gnus still supports those pesky old kill files. In fact, the kill file +entries can now be expiring, which is something I wrote before Daniel +Quinlan thought of doing score files, so I've left the code in there. + +In short, kill processing is a lot slower (and I do mean @emph{a lot}) +than score processing, so it might be a good idea to rewrite your kill +files into score files. + +Anyway, a kill file is a normal @code{emacs-lisp} file. You can put any +forms into this file, which means that you can use kill files as some +sort of primitive hook function to be run on group entry, even though +that isn't a very good idea. + +Normal kill files look like this: + +@lisp +(gnus-kill "From" "Lars Ingebrigtsen") +(gnus-kill "Subject" "ding") +(gnus-expunge "X") +@end lisp + +This will mark every article written by me as read, and remove the +marked articles from the summary buffer. Very useful, you'll agree. + +Other programs use a totally different kill file syntax. If Gnus +encounters what looks like a @code{rn} kill file, it will take a stab at +interpreting it. + +Two summary functions for editing a GNUS kill file: + +@table @kbd + +@item M-k +@kindex M-k (Summary) +@findex gnus-summary-edit-local-kill +Edit this group's kill file (@code{gnus-summary-edit-local-kill}). + +@item M-K +@kindex M-K (Summary) +@findex gnus-summary-edit-global-kill +Edit the general kill file (@code{gnus-summary-edit-global-kill}). +@end table + +Two group mode functions for editing the kill files: + +@table @kbd + +@item M-k +@kindex M-k (Group) +@findex gnus-group-edit-local-kill +Edit this group's kill file (@code{gnus-group-edit-local-kill}). + +@item M-K +@kindex M-K (Group) +@findex gnus-group-edit-global-kill +Edit the general kill file (@code{gnus-group-edit-global-kill}). +@end table + +Kill file variables: + +@table @code +@item gnus-kill-file-name +@vindex gnus-kill-file-name +A kill file for the group @samp{soc.motss} is normally called +@file{soc.motss.KILL}. The suffix appended to the group name to get +this file name is detailed by the @code{gnus-kill-file-name} variable. +The ``global'' kill file (not in the score file sense of ``global'', of +course) is just called @file{KILL}. + +@vindex gnus-kill-save-kill-file +@item gnus-kill-save-kill-file +If this variable is non-@code{nil}, Gnus will save the +kill file after processing, which is necessary if you use expiring +kills. + +@item gnus-apply-kill-hook +@vindex gnus-apply-kill-hook +@findex gnus-apply-kill-file-unless-scored +@findex gnus-apply-kill-file +A hook called to apply kill files to a group. It is +@code{(gnus-apply-kill-file)} by default. If you want to ignore the +kill file if you have a score file for the same group, you can set this +hook to @code{(gnus-apply-kill-file-unless-scored)}. If you don't want +kill files to be processed, you should set this variable to @code{nil}. + +@item gnus-kill-file-mode-hook +@vindex gnus-kill-file-mode-hook +A hook called in kill-file mode buffers. + +@end table + + +@node Converting Kill Files +@section Converting Kill Files +@cindex kill files +@cindex converting kill files + +If you have loads of old kill files, you may want to convert them into +score files. If they are ``regular'', you can use +the @file{gnus-kill-to-score.el} package; if not, you'll have to do it +by hand. + +The kill to score conversion package isn't included in Gnus by default. +You can fetch it from +@file{http://www.ifi.uio.no/~larsi/ding-other/gnus-kill-to-score}. + +If your old kill files are very complex---if they contain more +non-@code{gnus-kill} forms than not, you'll have to convert them by +hand. Or just let them be as they are. Gnus will still use them as +before. + + +@node GroupLens +@section GroupLens +@cindex GroupLens + +GroupLens is a collaborative filtering system that helps you work +together with other people to find the quality news articles out of the +huge volume of news articles generated every day. + +To accomplish this the GroupLens system combines your opinions about +articles you have already read with the opinions of others who have done +likewise and gives you a personalized prediction for each unread news +article. Think of GroupLens as a matchmaker. GroupLens watches how you +rate articles, and finds other people that rate articles the same way. +Once it has found some people you agree with it tells you, in the form +of a prediction, what they thought of the article. You can use this +prediction to help you decide whether or not you want to read the +article. + +@menu +* Using GroupLens:: How to make Gnus use GroupLens. +* Rating Articles:: Letting GroupLens know how you rate articles. +* Displaying Predictions:: Displaying predictions given by GroupLens. +* GroupLens Variables:: Customizing GroupLens. +@end menu + + +@node Using GroupLens +@subsection Using GroupLens + +To use GroupLens you must register a pseudonym with your local Better +Bit Bureau (BBB). +@samp{http://www.cs.umn.edu/Research/GroupLens/bbb.html} is the only +better bit in town at the moment. + +Once you have registered you'll need to set a couple of variables. + +@table @code + +@item gnus-use-grouplens +@vindex gnus-use-grouplens +Setting this variable to a non-@code{nil} value will make Gnus hook into +all the relevant GroupLens functions. + +@item grouplens-pseudonym +@vindex grouplens-pseudonym +This variable should be set to the pseudonym you got when registering +with the Better Bit Bureau. + +@item grouplens-newsgroups +@vindex grouplens-newsgroups +A list of groups that you want to get GroupLens predictions for. + +@end table + +That's the minimum of what you need to get up and running with GroupLens. +Once you've registered, GroupLens will start giving you scores for +articles based on the average of what other people think. But, to get +the real benefit of GroupLens you need to start rating articles +yourself. Then the scores GroupLens gives you will be personalized for +you, based on how the people you usually agree with have already rated. + + +@node Rating Articles +@subsection Rating Articles + +In GroupLens, an article is rated on a scale from 1 to 5, inclusive. +Where 1 means something like this article is a waste of bandwidth and 5 +means that the article was really good. The basic question to ask +yourself is, "on a scale from 1 to 5 would I like to see more articles +like this one?" + +There are four ways to enter a rating for an article in GroupLens. + +@table @kbd + +@item r +@kindex r (GroupLens) +@findex bbb-summary-rate-article +This function will prompt you for a rating on a scale of one to five. + +@item k +@kindex k (GroupLens) +@findex grouplens-score-thread +This function will prompt you for a rating, and rate all the articles in +the thread. This is really useful for some of those long running giant +threads in rec.humor. + +@end table + +The next two commands, @kbd{n} and @kbd{,} take a numerical prefix to be +the score of the article you're reading. + +@table @kbd + +@item 1-5 n +@kindex n (GroupLens) +@findex grouplens-next-unread-article +Rate the article and go to the next unread article. + +@item 1-5 , +@kindex , (GroupLens) +@findex grouplens-best-unread-article +Rate the article and go to the next unread article with the highest score. + +@end table + +If you want to give the current article a score of 4 and then go to the +next article, just type @kbd{4 n}. + + +@node Displaying Predictions +@subsection Displaying Predictions + +GroupLens makes a prediction for you about how much you will like a +news article. The predictions from GroupLens are on a scale from 1 to +5, where 1 is the worst and 5 is the best. You can use the predictions +from GroupLens in one of three ways controlled by the variable +@code{gnus-grouplens-override-scoring}. + +@vindex gnus-grouplens-override-scoring +There are three ways to display predictions in grouplens. You may +choose to have the GroupLens scores contribute to, or override the +regular gnus scoring mechanism. override is the default; however, some +people prefer to see the Gnus scores plus the grouplens scores. To get +the separate scoring behavior you need to set +@code{gnus-grouplens-override-scoring} to @code{'separate}. To have the +GroupLens predictions combined with the grouplens scores set it to +@code{'override} and to combine the scores set +@code{gnus-grouplens-override-scoring} to @code{'combine}. When you use +the combine option you will also want to set the values for +@code{grouplens-prediction-offset} and +@code{grouplens-score-scale-factor}. + +@vindex grouplens-prediction-display +In either case, GroupLens gives you a few choices for how you would like +to see your predictions displayed. The display of predictions is +controlled by the @code{grouplens-prediction-display} variable. + +The following are valid values for that variable. + +@table @code +@item prediction-spot +The higher the prediction, the further to the right an @samp{*} is +displayed. + +@item confidence-interval +A numeric confidence interval. + +@item prediction-bar +The higher the prediction, the longer the bar. + +@item confidence-bar +Numerical confidence. + +@item confidence-spot +The spot gets bigger with more confidence. + +@item prediction-num +Plain-old numeric value. + +@item confidence-plus-minus +Prediction +/- confidence. + +@end table + + +@node GroupLens Variables +@subsection GroupLens Variables + +@table @code + +@item gnus-summary-grouplens-line-format +The summary line format used in GroupLens-enhanced summary buffers. It +accepts the same specs as the normal summary line format (@pxref{Summary +Buffer Lines}). The default is @samp{%U%R%z%l%I%(%[%4L: %-20,20n%]%) +%s\n}. + +@item grouplens-bbb-host +Host running the bbbd server. @samp{grouplens.cs.umn.edu} is the +default. + +@item grouplens-bbb-port +Port of the host running the bbbd server. The default is 9000. + +@item grouplens-score-offset +Offset the prediction by this value. In other words, subtract the +prediction value by this number to arrive at the effective score. The +default is 0. + +@item grouplens-score-scale-factor +This variable allows the user to magnify the effect of GroupLens scores. +The scale factor is applied after the offset. The default is 1. + +@end table + + +@node Advanced Scoring +@section Advanced Scoring + +Scoring on Subjects and From headers is nice enough, but what if you're +really interested in what a person has to say only when she's talking +about a particular subject? Or what if you really don't want to +read what person A has to say when she's following up to person B, but +want to read what she says when she's following up to person C? + +By using advanced scoring rules you may create arbitrarily complex +scoring patterns. + +@menu +* Advanced Scoring Syntax:: A definition. +* Advanced Scoring Examples:: What they look like. +* Advanced Scoring Tips:: Getting the most out of it. +@end menu + + +@node Advanced Scoring Syntax +@subsection Advanced Scoring Syntax + +Ordinary scoring rules have a string as the first element in the rule. +Advanced scoring rules have a list as the first element. The second +element is the score to be applied if the first element evaluated to a +non-@code{nil} value. + +These lists may consist of three logical operators, one redirection +operator, and various match operators. + +Logical operators: + +@table @code +@item & +@itemx and +This logical operator will evaluate each of its arguments until it finds +one that evaluates to @code{false}, and then it'll stop. If all arguments +evaluate to @code{true} values, then this operator will return +@code{true}. + +@item | +@itemx or +This logical operator will evaluate each of its arguments until it finds +one that evaluates to @code{true}. If no arguments are @code{true}, +then this operator will return @code{false}. + +@item ! +@itemx not +@itemx ¬ +This logical operator only takes a single argument. It returns the +logical negation of the value of its argument. + +@end table + +There is an @dfn{indirection operator} that will make its arguments +apply to the ancestors of the current article being scored. For +instance, @code{1-} will make score rules apply to the parent of the +current article. @code{2-} will make score rules apply to the +grandparent of the current article. Alternatively, you can write +@code{^^}, where the number of @code{^}s (carets) says how far back into +the ancestry you want to go. + +Finally, we have the match operators. These are the ones that do the +real work. Match operators are header name strings followed by a match +and a match type. A typical match operator looks like @samp{("from" +"Lars Ingebrigtsen" s)}. The header names are the same as when using +simple scoring, and the match types are also the same. + + +@node Advanced Scoring Examples +@subsection Advanced Scoring Examples + +Let's say you want to increase the score of articles written by Lars +when he's talking about Gnus: + +@example +((& + ("from" "Lars Ingebrigtsen") + ("subject" "Gnus")) + 1000) +@end example + +Quite simple, huh? + +When he writes long articles, he sometimes has something nice to say: + +@example +((& + ("from" "Lars Ingebrigtsen") + (| + ("subject" "Gnus") + ("lines" 100 >))) + 1000) +@end example + +However, when he responds to things written by Reig Eigil Logge, you +really don't want to read what he's written: + +@example +((& + ("from" "Lars Ingebrigtsen") + (1- ("from" "Reig Eigir Logge"))) + -100000) +@end example + +Everybody that follows up Redmondo when he writes about disappearing +socks should have their scores raised, but only when they talk about +white socks. However, when Lars talks about socks, it's usually not +very interesting: + +@example +((& + (1- + (& + ("from" "redmondo@@.*no" r) + ("body" "disappearing.*socks" t))) + (! ("from" "Lars Ingebrigtsen")) + ("body" "white.*socks")) + 1000) +@end example + +The possibilities are endless. + + +@node Advanced Scoring Tips +@subsection Advanced Scoring Tips + +The @code{&} and @code{|} logical operators do short-circuit logic. +That is, they stop processing their arguments when it's clear what the +result of the operation will be. For instance, if one of the arguments +of an @code{&} evaluates to @code{false}, there's no point in evaluating +the rest of the arguments. This means that you should put slow matches +(@samp{body}, @samp{header}) last and quick matches (@samp{from}, +@samp{subject}) first. + +The indirection arguments (@code{1-} and so on) will make their +arguments work on previous generations of the thread. If you say +something like: + +@example +... +(1- + (1- + ("from" "lars"))) +... +@end example + +Then that means "score on the from header of the grandparent of the +current article". An indirection is quite fast, but it's better to say: + +@example +(1- + (& + ("from" "Lars") + ("subject" "Gnus"))) +@end example + +than it is to say: + +@example +(& + (1- ("from" "Lars")) + (1- ("subject" "Gnus"))) +@end example + + +@node Score Decays +@section Score Decays +@cindex score decays +@cindex decays + +You may find that your scores have a tendency to grow without +bounds, especially if you're using adaptive scoring. If scores get too +big, they lose all meaning---they simply max out and it's difficult to +use them in any sensible way. + +@vindex gnus-decay-scores +@findex gnus-decay-score +@vindex gnus-score-decay-function +Gnus provides a mechanism for decaying scores to help with this problem. +When score files are loaded and @code{gnus-decay-scores} is +non-@code{nil}, Gnus will run the score files through the decaying +mechanism thereby lowering the scores of all non-permanent score rules. +The decay itself if performed by the @code{gnus-score-decay-function} +function, which is @code{gnus-decay-score} by default. Here's the +definition of that function: + +@lisp +(defun gnus-decay-score (score) + "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'." + (floor + (- score + (* (if (< score 0) 1 -1) + (min (abs score) + (max gnus-score-decay-constant + (* (abs score) + gnus-score-decay-scale))))))) +@end lisp + +@vindex gnus-score-decay-scale +@vindex gnus-score-decay-constant +@code{gnus-score-decay-constant} is 3 by default and +@code{gnus-score-decay-scale} is 0.05. This should cause the following: + +@enumerate +@item +Scores between -3 and 3 will be set to 0 when this function is called. + +@item +Scores with magnitudes between 3 and 60 will be shrunk by 3. + +@item +Scores with magnitudes greater than 60 will be shrunk by 5% of the +score. +@end enumerate + +If you don't like this decay function, write your own. It is called +with the score to be decayed as its only parameter, and it should return +the new score, which should be an integer. + +Gnus will try to decay scores once a day. If you haven't run Gnus for +four days, Gnus will decay the scores four times, for instance. + + +@node Various +@chapter Various + +@menu +* Process/Prefix:: A convention used by many treatment commands. +* Interactive:: Making Gnus ask you many questions. +* Symbolic Prefixes:: How to supply some Gnus functions with options. +* Formatting Variables:: You can specify what buffers should look like. +* Windows Configuration:: Configuring the Gnus buffer windows. +* Compilation:: How to speed Gnus up. +* Mode Lines:: Displaying information in the mode lines. +* Highlighting and Menus:: Making buffers look all nice and cozy. +* Buttons:: Get tendonitis in ten easy steps! +* Daemons:: Gnus can do things behind your back. +* NoCeM:: How to avoid spam and other fatty foods. +* Undo:: Some actions can be undone. +* Moderation:: What to do if you're a moderator. +* XEmacs Enhancements:: There are more pictures and stuff under XEmacs. +* Fuzzy Matching:: What's the big fuzz? +* Thwarting Email Spam:: A how-to on avoiding unsolited commercial email. +* Various Various:: Things that are really various. +@end menu + + +@node Process/Prefix +@section Process/Prefix +@cindex process/prefix convention + +Many functions, among them functions for moving, decoding and saving +articles, use what is known as the @dfn{Process/Prefix convention}. + +This is a method for figuring out what articles the user wants the +command to be performed on. + +It goes like this: + +If the numeric prefix is N, perform the operation on the next N +articles, starting with the current one. If the numeric prefix is +negative, perform the operation on the previous N articles, starting +with the current one. + +@vindex transient-mark-mode +If @code{transient-mark-mode} in non-@code{nil} and the region is +active, all articles in the region will be worked upon. + +If there is no numeric prefix, but some articles are marked with the +process mark, perform the operation on the articles marked with +the process mark. + +If there is neither a numeric prefix nor any articles marked with the +process mark, just perform the operation on the current article. + +Quite simple, really, but it needs to be made clear so that surprises +are avoided. + +Commands that react to the process mark will push the current list of +process marked articles onto a stack and will then clear all process +marked articles. You can restore the previous configuration with the +@kbd{M P y} command (@pxref{Setting Process Marks}). + +@vindex gnus-summary-goto-unread +One thing that seems to shock & horrify lots of people is that, for +instance, @kbd{3 d} does exactly the same as @kbd{d} @kbd{d} @kbd{d}. +Since each @kbd{d} (which marks the current article as read) by default +goes to the next unread article after marking, this means that @kbd{3 d} +will mark the next three unread articles as read, no matter what the +summary buffer looks like. Set @code{gnus-summary-goto-unread} to +@code{nil} for a more straightforward action. + + +@node Interactive +@section Interactive +@cindex interaction + +@table @code + +@item gnus-novice-user +@vindex gnus-novice-user +If this variable is non-@code{nil}, you are either a newcomer to the +World of Usenet, or you are very cautious, which is a nice thing to be, +really. You will be given questions of the type ``Are you sure you want +to do this?'' before doing anything dangerous. This is @code{t} by +default. + +@item gnus-expert-user +@vindex gnus-expert-user +If this variable is non-@code{nil}, you will never ever be asked any +questions by Gnus. It will simply assume you know what you're doing, no +matter how strange. + +@item gnus-interactive-catchup +@vindex gnus-interactive-catchup +Require confirmation before catching up a group if non-@code{nil}. It +is @code{t} by default. + +@item gnus-interactive-exit +@vindex gnus-interactive-exit +Require confirmation before exiting Gnus. This variable is @code{t} by +default. +@end table + + +@node Symbolic Prefixes +@section Symbolic Prefixes +@cindex symbolic prefixes + +Quite a lot of Emacs commands react to the (numeric) prefix. For +instance, @kbd{C-u 4 C-f} moves point four charaters forward, and +@kbd{C-u 9 0 0 I s s p} adds a permanent @code{Subject} substring score +rule of 900 to the current article. + +This is all nice and well, but what if you want to give a command some +additional information? Well, what most commands do is interpret the +``raw'' prefix in some special way. @kbd{C-u 0 C-x C-s} means that one +doesn't want a backup file to be created when saving the current buffer, +for instance. But what if you want to save without making a backup +file, and you want Emacs to flash lights and play a nice tune at the +same time? You can't, and you're probably perfectly happy that way. + +@kindex M-i (Summary) +@findex gnus-symbolic-argument +I'm not, so I've added a second prefix---the @dfn{symbolic prefix}. The +prefix key is @kbd{M-i} (@code{gnus-symbolic-argument}), and the next +character typed in is the value. You can stack as many @kbd{M-i} +prefixes as you want. @kbd{M-i a M-C-u} means ``feed the @kbd{M-C-u} +command the symbolic prefix @code{a}''. @kbd{M-i a M-i b M-C-u} means +``feed the @kbd{M-C-u} command the symbolic prefixes @code{a} and +@code{b}''. You get the drift. + +Typing in symbolic prefixes to commands that don't accept them doesn't +hurt, but it doesn't do any good either. Currently not many Gnus +functions make use of the symbolic prefix. + +If you're interested in how Gnus implements this, @pxref{Extended +Interactive}. + + +@node Formatting Variables +@section Formatting Variables +@cindex formatting variables + +Throughout this manual you've probably noticed lots of variables called things like @code{gnus-group-line-format} and +@code{gnus-summary-mode-line-format}. These control how Gnus is to +output lines in the various buffers. There's quite a lot of them. +Fortunately, they all use the same syntax, so there's not that much to +be annoyed by. + +Here's an example format spec (from the group buffer): @samp{%M%S%5y: +%(%g%)\n}. We see that it is indeed extremely ugly, and that there are +lots of percentages everywhere. + +@menu +* Formatting Basics:: A formatting variable is basically a format string. +* Advanced Formatting:: Modifying output in various ways. +* User-Defined Specs:: Having Gnus call your own functions. +* Formatting Fonts:: Making the formatting look colorful and nice. +@end menu + +Currently Gnus uses the following formatting variables: +@code{gnus-group-line-format}, @code{gnus-summary-line-format}, +@code{gnus-server-line-format}, @code{gnus-topic-line-format}, +@code{gnus-group-mode-line-format}, +@code{gnus-summary-mode-line-format}, +@code{gnus-article-mode-line-format}, +@code{gnus-server-mode-line-format}, and +@code{gnus-summary-pick-line-format}. + +All these format variables can also be arbitrary elisp forms. In that +case, they will be @code{eval}ed to insert the required lines. + +@kindex M-x gnus-update-format +@findex gnus-update-format +Gnus includes a command to help you while creating your own format +specs. @kbd{M-x gnus-update-format} will @code{eval} the current form, +update the spec in question and pop you to a buffer where you can +examine the resulting lisp code to be run to generate the line. + + + +@node Formatting Basics +@subsection Formatting Basics + +Each @samp{%} element will be replaced by some string or other when the +buffer in question is generated. @samp{%5y} means ``insert the @samp{y} +spec, and pad with spaces to get a 5-character field''. + +As with normal C and Emacs Lisp formatting strings, the numerical +modifier between the @samp{%} and the formatting type character will +@dfn{pad} the output so that it is always at least that long. +@samp{%5y} will make the field always (at least) five characters wide by +padding with spaces to the left. If you say @samp{%-5y}, it will pad to +the right instead. + +You may also wish to limit the length of the field to protect against +particularly wide values. For that you can say @samp{%4,6y}, which +means that the field will never be more than 6 characters wide and never +less than 4 characters wide. + + +@node Advanced Formatting +@subsection Advanced Formatting + +It is frequently useful to post-process the fields in some way. +Padding, limiting, cutting off parts and suppressing certain values can +be achieved by using @dfn{tilde modifiers}. A typical tilde spec might +look like @samp{%~(cut 3)~(ignore "0")y}. + +These are the valid modifiers: + +@table @code +@item pad +@itemx pad-left +Pad the field to the left with spaces until it reaches the required +length. + +@item pad-right +Pad the field to the right with spaces until it reaches the required +length. + +@item max +@itemx max-left +Cut off characters from the left until it reaches the specified length. + +@item max-right +Cut off characters from the right until it reaches the specified +length. + +@item cut +@itemx cut-left +Cut off the specified number of characters from the left. + +@item cut-right +Cut off the specified number of characters from the right. + +@item ignore +Return an empty string if the field is equal to the specified value. + +@item form +Use the specified form as the field value when the @samp{@@} spec is +used. +@end table + +Let's take an example. The @samp{%o} spec in the summary mode lines +will return a date in compact ISO8601 format---@samp{19960809T230410}. +This is quite a mouthful, so we want to shave off the century number and +the time, leaving us with a six-character date. That would be +@samp{%~(cut-left 2)~(max-right 6)~(pad 6)o}. (Cutting is done before +maxing, and we need the padding to ensure that the date is never less +than 6 characters to make it look nice in columns.) + +Ignoring is done first; then cutting; then maxing; and then as the very +last operation, padding. + +If you use lots of these advanced thingies, you'll find that Gnus gets +quite slow. This can be helped enormously by running @kbd{M-x +gnus-compile} when you are satisfied with the look of your lines. +@xref{Compilation}. + + +@node User-Defined Specs +@subsection User-Defined Specs + +All the specs allow for inserting user defined specifiers---@samp{u}. +The next character in the format string should be a letter. Gnus +will call the function @code{gnus-user-format-function-}@samp{X}, where +@samp{X} is the letter following @samp{%u}. The function will be passed +a single parameter---what the parameter means depends on what buffer +it's being called from. The function should return a string, which will +be inserted into the buffer just like information from any other +specifier. This function may also be called with dummy values, so it +should protect against that. + +You can also use tilde modifiers (@pxref{Advanced Formatting} to achieve +much the same without defining new functions. Here's an example: +@samp{%~(form (count-lines (point-min) (point)))@@}. The form +given here will be evaluated to yield the current line number, and then +inserted. + + +@node Formatting Fonts +@subsection Formatting Fonts + +There are specs for highlighting, and these are shared by all the format +variables. Text inside the @samp{%(} and @samp{%)} specifiers will get +the special @code{mouse-face} property set, which means that it will be +highlighted (with @code{gnus-mouse-face}) when you put the mouse pointer +over it. + +Text inside the @samp{%[} and @samp{%]} specifiers will have their +normal faces set using @code{gnus-face-0}, which is @code{bold} by +default. If you say @samp{%1[}, you'll get @code{gnus-face-1} instead, +and so on. Create as many faces as you wish. The same goes for the +@code{mouse-face} specs---you can say @samp{%3(hello%)} to have +@samp{hello} mouse-highlighted with @code{gnus-mouse-face-3}. + +Here's an alternative recipe for the group buffer: + +@lisp +;; Create three face types. +(setq gnus-face-1 'bold) +(setq gnus-face-3 'italic) + +;; We want the article count to be in +;; a bold and green face. So we create +;; a new face called `my-green-bold'. +(copy-face 'bold 'my-green-bold) +;; Set the color. +(set-face-foreground 'my-green-bold "ForestGreen") +(setq gnus-face-2 'my-green-bold) + +;; Set the new & fancy format. +(setq gnus-group-line-format + "%M%S%3@{%5y%@}%2[:%] %(%1@{%g%@}%)\n") +@end lisp + +I'm sure you'll be able to use this scheme to create totally unreadable +and extremely vulgar displays. Have fun! + +Note that the @samp{%(} specs (and friends) do not make any sense on the +mode-line variables. + + +@node Windows Configuration +@section Windows Configuration +@cindex windows configuration + +No, there's nothing here about X, so be quiet. + +@vindex gnus-use-full-window +If @code{gnus-use-full-window} non-@code{nil}, Gnus will delete all +other windows and occupy the entire Emacs screen by itself. It is +@code{t} by default. + +@vindex gnus-buffer-configuration +@code{gnus-buffer-configuration} describes how much space each Gnus +buffer should be given. Here's an excerpt of this variable: + +@lisp +((group (vertical 1.0 (group 1.0 point) + (if gnus-carpal (group-carpal 4)))) + (article (vertical 1.0 (summary 0.25 point) + (article 1.0)))) +@end lisp + +This is an alist. The @dfn{key} is a symbol that names some action or +other. For instance, when displaying the group buffer, the window +configuration function will use @code{group} as the key. A full list of +possible names is listed below. + +The @dfn{value} (i.e., the @dfn{split}) says how much space each buffer +should occupy. To take the @code{article} split as an example - + +@lisp +(article (vertical 1.0 (summary 0.25 point) + (article 1.0))) +@end lisp + +This @dfn{split} says that the summary buffer should occupy 25% of upper +half of the screen, and that it is placed over the article buffer. As +you may have noticed, 100% + 25% is actually 125% (yup, I saw y'all +reaching for that calculator there). However, the special number +@code{1.0} is used to signal that this buffer should soak up all the +rest of the space available after the rest of the buffers have taken +whatever they need. There should be only one buffer with the @code{1.0} +size spec per split. + +Point will be put in the buffer that has the optional third element +@code{point}. + +Here's a more complicated example: + +@lisp +(article (vertical 1.0 (group 4) + (summary 0.25 point) + (if gnus-carpal (summary-carpal 4)) + (article 1.0))) +@end lisp + +If the size spec is an integer instead of a floating point number, +then that number will be used to say how many lines a buffer should +occupy, not a percentage. + +If the @dfn{split} looks like something that can be @code{eval}ed (to be +precise---if the @code{car} of the split is a function or a subr), this +split will be @code{eval}ed. If the result is non-@code{nil}, it will +be used as a split. This means that there will be three buffers if +@code{gnus-carpal} is @code{nil}, and four buffers if @code{gnus-carpal} +is non-@code{nil}. + +Not complicated enough for you? Well, try this on for size: + +@lisp +(article (horizontal 1.0 + (vertical 0.5 + (group 1.0) + (gnus-carpal 4)) + (vertical 1.0 + (summary 0.25 point) + (summary-carpal 4) + (article 1.0)))) +@end lisp + +Whoops. Two buffers with the mystery 100% tag. And what's that +@code{horizontal} thingie? + +If the first element in one of the split is @code{horizontal}, Gnus will +split the window horizontally, giving you two windows side-by-side. +Inside each of these strips you may carry on all you like in the normal +fashion. The number following @code{horizontal} says what percentage of +the screen is to be given to this strip. + +For each split, there @emph{must} be one element that has the 100% tag. +The splitting is never accurate, and this buffer will eat any leftover +lines from the splits. + +To be slightly more formal, here's a definition of what a valid split +may look like: + +@example +split = frame | horizontal | vertical | buffer | form +frame = "(frame " size *split ")" +horizontal = "(horizontal " size *split ")" +vertical = "(vertical " size *split ")" +buffer = "(" buffer-name " " size *[ "point" ] ")" +size = number | frame-params +buffer-name = group | article | summary ... +@end example + +The limitations are that the @code{frame} split can only appear as the +top-level split. @var{form} should be an Emacs Lisp form that should +return a valid split. We see that each split is fully recursive, and +may contain any number of @code{vertical} and @code{horizontal} splits. + +@vindex gnus-window-min-width +@vindex gnus-window-min-height +@cindex window height +@cindex window width +Finding the right sizes can be a bit complicated. No window may be less +than @code{gnus-window-min-height} (default 1) characters high, and all +windows must be at least @code{gnus-window-min-width} (default 1) +characters wide. Gnus will try to enforce this before applying the +splits. If you want to use the normal Emacs window width/height limit, +you can just set these two variables to @code{nil}. + +If you're not familiar with Emacs terminology, @code{horizontal} and +@code{vertical} splits may work the opposite way of what you'd expect. +Windows inside a @code{horizontal} split are shown side-by-side, and +windows within a @code{vertical} split are shown above each other. + +@findex gnus-configure-frame +If you want to experiment with window placement, a good tip is to call +@code{gnus-configure-frame} directly with a split. This is the function +that does all the real work when splitting buffers. Below is a pretty +nonsensical configuration with 5 windows; two for the group buffer and +three for the article buffer. (I said it was nonsensical.) If you +@code{eval} the statement below, you can get an idea of how that would +look straight away, without going through the normal Gnus channels. +Play with it until you're satisfied, and then use +@code{gnus-add-configuration} to add your new creation to the buffer +configuration list. + +@lisp +(gnus-configure-frame + '(horizontal 1.0 + (vertical 10 + (group 1.0) + (article 0.3 point)) + (vertical 1.0 + (article 1.0) + (horizontal 4 + (group 1.0) + (article 10))))) +@end lisp + +You might want to have several frames as well. No prob---just use the +@code{frame} split: + +@lisp +(gnus-configure-frame + '(frame 1.0 + (vertical 1.0 + (summary 0.25 point) + (article 1.0)) + (vertical ((height . 5) (width . 15) + (user-position . t) + (left . -1) (top . 1)) + (picon 1.0)))) + +@end lisp + +This split will result in the familiar summary/article window +configuration in the first (or ``main'') frame, while a small additional +frame will be created where picons will be shown. As you can see, +instead of the normal @code{1.0} top-level spec, each additional split +should have a frame parameter alist as the size spec. +@xref{Frame Parameters, , Frame Parameters, elisp, The GNU Emacs Lisp +Reference Manual}. Under XEmacs, a frame property list will be +accepted, too---for instance, @code{(height 5 width 15 left -1 top 1)} +is such a plist. + +Here's a list of all possible keys for +@code{gnus-buffer-configuration}: + +@code{group}, @code{summary}, @code{article}, @code{server}, +@code{browse}, @code{message}, @code{pick}, @code{info}, +@code{summary-faq}, @code{edit-group}, @code{edit-server}, +@code{edit-score}, @code{post}, @code{reply}, @code{forward}, +@code{reply-yank}, @code{mail-bounce}, @code{draft}, @code{pipe}, +@code{bug}, @code{compose-bounce}, and @code{score-trace}. + +Note that the @code{message} key is used for both +@code{gnus-group-mail} and @code{gnus-summary-mail-other-window}. If +it is desirable to distinguish between the two, something like this +might be used: + +@lisp +(message (horizontal 1.0 + (vertical 1.0 (message 1.0 point)) + (vertical 0.24 + (if (buffer-live-p gnus-summary-buffer) + '(summary 0.5)) + (group 1.0))))) +@end lisp + +@findex gnus-add-configuration +Since the @code{gnus-buffer-configuration} variable is so long and +complicated, there's a function you can use to ease changing the config +of a single setting: @code{gnus-add-configuration}. If, for instance, +you want to change the @code{article} setting, you could say: + +@lisp +(gnus-add-configuration + '(article (vertical 1.0 + (group 4) + (summary .25 point) + (article 1.0)))) +@end lisp + +You'd typically stick these @code{gnus-add-configuration} calls in your +@file{.gnus.el} file or in some startup hook---they should be run after +Gnus has been loaded. + +@vindex gnus-always-force-window-configuration +If all windows mentioned in the configuration are already visible, Gnus +won't change the window configuration. If you always want to force the +``right'' window configuration, you can set +@code{gnus-always-force-window-configuration} to non-@code{nil}. + + +@node Compilation +@section Compilation +@cindex compilation +@cindex byte-compilation + +@findex gnus-compile + +Remember all those line format specification variables? +@code{gnus-summary-line-format}, @code{gnus-group-line-format}, and so +on. Now, Gnus will of course heed whatever these variables are, but, +unfortunately, changing them will mean a quite significant slow-down. +(The default values of these variables have byte-compiled functions +associated with them, while the user-generated versions do not, of +course.) + +To help with this, you can run @kbd{M-x gnus-compile} after you've +fiddled around with the variables and feel that you're (kind of) +satisfied. This will result in the new specs being byte-compiled, and +you'll get top speed again. Gnus will save these compiled specs in the +@file{.newsrc.eld} file. (User-defined functions aren't compiled by +this function, though---you should compile them yourself by sticking +them into the @code{.gnus.el} file and byte-compiling that file.) + + +@node Mode Lines +@section Mode Lines +@cindex mode lines + +@vindex gnus-updated-mode-lines +@code{gnus-updated-mode-lines} says what buffers should keep their mode +lines updated. It is a list of symbols. Supported symbols include +@code{group}, @code{article}, @code{summary}, @code{server}, +@code{browse}, and @code{tree}. If the corresponding symbol is present, +Gnus will keep that mode line updated with information that may be +pertinent. If this variable is @code{nil}, screen refresh may be +quicker. + +@cindex display-time + +@vindex gnus-mode-non-string-length +By default, Gnus displays information on the current article in the mode +lines of the summary and article buffers. The information Gnus wishes +to display (e.g. the subject of the article) is often longer than the +mode lines, and therefore have to be cut off at some point. The +@code{gnus-mode-non-string-length} variable says how long the other +elements on the line is (i.e., the non-info part). If you put +additional elements on the mode line (e.g. a clock), you should modify +this variable: + +@c Hook written by Francesco Potorti` +@lisp +(add-hook 'display-time-hook + (lambda () (setq gnus-mode-non-string-length + (+ 21 + (if line-number-mode 5 0) + (if column-number-mode 4 0) + (length display-time-string))))) +@end lisp + +If this variable is @code{nil} (which is the default), the mode line +strings won't be chopped off, and they won't be padded either. Note +that the default is unlikely to be desirable, as even the percentage +complete in the buffer may be crowded off the mode line; the user should +configure this variable appropriately for her configuration. + + +@node Highlighting and Menus +@section Highlighting and Menus +@cindex visual +@cindex highlighting +@cindex menus + +@vindex gnus-visual +The @code{gnus-visual} variable controls most of the Gnus-prettifying +aspects. If @code{nil}, Gnus won't attempt to create menus or use fancy +colors or fonts. This will also inhibit loading the @file{gnus-vis.el} +file. + +This variable can be a list of visual properties that are enabled. The +following elements are valid, and are all included by default: + +@table @code +@item group-highlight +Do highlights in the group buffer. +@item summary-highlight +Do highlights in the summary buffer. +@item article-highlight +Do highlights in the article buffer. +@item highlight +Turn on highlighting in all buffers. +@item group-menu +Create menus in the group buffer. +@item summary-menu +Create menus in the summary buffers. +@item article-menu +Create menus in the article buffer. +@item browse-menu +Create menus in the browse buffer. +@item server-menu +Create menus in the server buffer. +@item score-menu +Create menus in the score buffers. +@item menu +Create menus in all buffers. +@end table + +So if you only want highlighting in the article buffer and menus in all +buffers, you could say something like: + +@lisp +(setq gnus-visual '(article-highlight menu)) +@end lisp + +If you want highlighting only and no menus whatsoever, you'd say: + +@lisp +(setq gnus-visual '(highlight)) +@end lisp + +If @code{gnus-visual} is @code{t}, highlighting and menus will be used +in all Gnus buffers. + +Other general variables that influence the look of all buffers include: + +@table @code +@item gnus-mouse-face +@vindex gnus-mouse-face +This is the face (i.e., font) used for mouse highlighting in Gnus. No +mouse highlights will be done if @code{gnus-visual} is @code{nil}. + +@end table + +There are hooks associated with the creation of all the different menus: + +@table @code + +@item gnus-article-menu-hook +@vindex gnus-article-menu-hook +Hook called after creating the article mode menu. + +@item gnus-group-menu-hook +@vindex gnus-group-menu-hook +Hook called after creating the group mode menu. + +@item gnus-summary-menu-hook +@vindex gnus-summary-menu-hook +Hook called after creating the summary mode menu. + +@item gnus-server-menu-hook +@vindex gnus-server-menu-hook +Hook called after creating the server mode menu. + +@item gnus-browse-menu-hook +@vindex gnus-browse-menu-hook +Hook called after creating the browse mode menu. + +@item gnus-score-menu-hook +@vindex gnus-score-menu-hook +Hook called after creating the score mode menu. + +@end table + + +@node Buttons +@section Buttons +@cindex buttons +@cindex mouse +@cindex click + +Those new-fangled @dfn{mouse} contraptions is very popular with the +young, hep kids who don't want to learn the proper way to do things +these days. Why, I remember way back in the summer of '89, when I was +using Emacs on a Tops 20 system. Three hundred users on one single +machine, and every user was running Simula compilers. Bah! + +Right. + +@vindex gnus-carpal +Well, you can make Gnus display bufferfuls of buttons you can click to +do anything by setting @code{gnus-carpal} to @code{t}. Pretty simple, +really. Tell the chiropractor I sent you. + + +@table @code + +@item gnus-carpal-mode-hook +@vindex gnus-carpal-mode-hook +Hook run in all carpal mode buffers. + +@item gnus-carpal-button-face +@vindex gnus-carpal-button-face +Face used on buttons. + +@item gnus-carpal-header-face +@vindex gnus-carpal-header-face +Face used on carpal buffer headers. + +@item gnus-carpal-group-buffer-buttons +@vindex gnus-carpal-group-buffer-buttons +Buttons in the group buffer. + +@item gnus-carpal-summary-buffer-buttons +@vindex gnus-carpal-summary-buffer-buttons +Buttons in the summary buffer. + +@item gnus-carpal-server-buffer-buttons +@vindex gnus-carpal-server-buffer-buttons +Buttons in the server buffer. + +@item gnus-carpal-browse-buffer-buttons +@vindex gnus-carpal-browse-buffer-buttons +Buttons in the browse buffer. +@end table + +All the @code{buttons} variables are lists. The elements in these list +are either cons cells where the @code{car} contains a text to be displayed and +the @code{cdr} contains a function symbol, or a simple string. + + +@node Daemons +@section Daemons +@cindex demons +@cindex daemons + +Gnus, being larger than any program ever written (allegedly), does lots +of strange stuff that you may wish to have done while you're not +present. For instance, you may want it to check for new mail once in a +while. Or you may want it to close down all connections to all servers +when you leave Emacs idle. And stuff like that. + +Gnus will let you do stuff like that by defining various +@dfn{handlers}. Each handler consists of three elements: A +@var{function}, a @var{time}, and an @var{idle} parameter. + +Here's an example of a handler that closes connections when Emacs has +been idle for thirty minutes: + +@lisp +(gnus-demon-close-connections nil 30) +@end lisp + +Here's a handler that scans for PGP headers every hour when Emacs is +idle: + +@lisp +(gnus-demon-scan-pgp 60 t) +@end lisp + +This @var{time} parameter and than @var{idle} parameter work together +in a strange, but wonderful fashion. Basically, if @var{idle} is +@code{nil}, then the function will be called every @var{time} minutes. + +If @var{idle} is @code{t}, then the function will be called after +@var{time} minutes only if Emacs is idle. So if Emacs is never idle, +the function will never be called. But once Emacs goes idle, the +function will be called every @var{time} minutes. + +If @var{idle} is a number and @var{time} is a number, the function will +be called every @var{time} minutes only when Emacs has been idle for +@var{idle} minutes. + +If @var{idle} is a number and @var{time} is @code{nil}, the function +will be called once every time Emacs has been idle for @var{idle} +minutes. + +And if @var{time} is a string, it should look like @samp{07:31}, and +the function will then be called once every day somewhere near that +time. Modified by the @var{idle} parameter, of course. + +@vindex gnus-demon-timestep +(When I say ``minute'' here, I really mean @code{gnus-demon-timestep} +seconds. This is 60 by default. If you change that variable, +all the timings in the handlers will be affected.) + +@vindex gnus-use-demon +To set the whole thing in motion, though, you have to set +@code{gnus-use-demon} to @code{t}. + +So, if you want to add a handler, you could put something like this in +your @file{.gnus} file: + +@findex gnus-demon-add-handler +@lisp +(gnus-demon-add-handler 'gnus-demon-close-connections 30 t) +@end lisp + +@findex gnus-demon-add-nocem +@findex gnus-demon-add-scanmail +@findex gnus-demon-add-rescan +@findex gnus-demon-add-scan-timestamps +@findex gnus-demon-add-disconnection +Some ready-made functions to do this have been created: +@code{gnus-demon-add-nocem}, @code{gnus-demon-add-disconnection}, +@code{gnus-demon-add-scan-timestamps}, @code{gnus-demon-add-rescan}, and +@code{gnus-demon-add-scanmail}. Just put those functions in your +@file{.gnus} if you want those abilities. + +@findex gnus-demon-init +@findex gnus-demon-cancel +@vindex gnus-demon-handlers +If you add handlers to @code{gnus-demon-handlers} directly, you should +run @code{gnus-demon-init} to make the changes take hold. To cancel all +daemons, you can use the @code{gnus-demon-cancel} function. + +Note that adding daemons can be pretty naughty if you overdo it. Adding +functions that scan all news and mail from all servers every two seconds +is a sure-fire way of getting booted off any respectable system. So +behave. + + +@node NoCeM +@section NoCeM +@cindex nocem +@cindex spam + +@dfn{Spamming} is posting the same article lots and lots of times. +Spamming is bad. Spamming is evil. + +Spamming is usually canceled within a day or so by various anti-spamming +agencies. These agencies usually also send out @dfn{NoCeM} messages. +NoCeM is pronounced ``no see-'em'', and means what the name +implies---these are messages that make the offending articles, like, go +away. + +What use are these NoCeM messages if the articles are canceled anyway? +Some sites do not honor cancel messages and some sites just honor cancels +from a select few people. Then you may wish to make use of the NoCeM +messages, which are distributed in the @samp{alt.nocem.misc} newsgroup. + +Gnus can read and parse the messages in this group automatically, and +this will make spam disappear. + +There are some variables to customize, of course: + +@table @code +@item gnus-use-nocem +@vindex gnus-use-nocem +Set this variable to @code{t} to set the ball rolling. It is @code{nil} +by default. + +@item gnus-nocem-groups +@vindex gnus-nocem-groups +Gnus will look for NoCeM messages in the groups in this list. The +default is @code{("news.lists.filters" "news.admin.net-abuse.bulletins" +"alt.nocem.misc" "news.admin.net-abuse.announce")}. + +@item gnus-nocem-issuers +@vindex gnus-nocem-issuers +There are many people issuing NoCeM messages. This list says what +people you want to listen to. The default is @code{("Automoose-1" +"clewis@@ferret.ocunix.on.ca;" "jem@@xpat.com;" "red@@redpoll.mrfs.oh.us +(Richard E. Depew)")}; fine, upstanding citizens all of them. + +Known despammers that you can put in this list include: + +@table @samp +@item clewis@@ferret.ocunix.on.ca; +@cindex Chris Lewis +Chris Lewis---Major Canadian despammer who has probably canceled more +usenet abuse than anybody else. + +@item Automoose-1 +@cindex CancelMoose[tm] +The CancelMoose[tm] on autopilot. The CancelMoose[tm] is reputed to be +Norwegian, and was the person(s) who invented NoCeM. + +@item jem@@xpat.com; +@cindex Jem +John Milburn---despammer located in Korea who is getting very busy these +days. + +@item red@@redpoll.mrfs.oh.us (Richard E. Depew) +Richard E. Depew---lone American despammer. He mostly cancels binary +postings to non-binary groups and removes spews (regurgitated articles). +@end table + +You do not have to heed NoCeM messages from all these people---just the +ones you want to listen to. You also don't have to accept all NoCeM +messages from the people you like. Each NoCeM message has a @dfn{type} +header that gives the message a (more or less, usually less) rigorous +definition. Common types are @samp{spam}, @samp{spew}, @samp{mmf}, +@samp{binary}, and @samp{troll}. To specify this, you have to use +@var{(issuer conditions ...)} elements in the list. Each condition is +either a string (which is a regexp that matches types you want to use) +or a list on the form @code{(not STRING)}, where @var{string} is a +regexp that matches types you don't want to use. + +For instance, if you want all NoCeM messages from Chris Lewis except his +@samp{troll} messages, you'd say: + +@lisp +("clewis@@ferret.ocunix.on.ca" ".*" (not "troll")) +@end lisp + +On the other hand, if you just want nothing but his @samp{spam} and +@samp{spew} messages, you'd say: + +@lisp +("clewis@@ferret.ocunix.on.ca" (not ".*") "spew" "spam") +@end lisp + +The specs are applied left-to-right. + + +@item gnus-nocem-verifyer +@vindex gnus-nocem-verifyer +@findex mc-verify +This should be a function for verifying that the NoCeM issuer is who she +says she is. The default is @code{mc-verify}, which is a Mailcrypt +function. If this is too slow and you don't care for verification +(which may be dangerous), you can set this variable to @code{nil}. + +If you want signed NoCeM messages to be verified and unsigned messages +not to be verified (but used anyway), you could do something like: + +@lisp +(setq gnus-nocem-verifyer 'my-gnus-mc-verify) + +(defun my-gnus-mc-verify () + (not (eq 'forged + (ignore-errors + (if (mc-verify) + t + 'forged))))) +@end lisp + +This might be dangerous, though. + +@item gnus-nocem-directory +@vindex gnus-nocem-directory +This is where Gnus will store its NoCeM cache files. The default is +@file{~/News/NoCeM/}. + +@item gnus-nocem-expiry-wait +@vindex gnus-nocem-expiry-wait +The number of days before removing old NoCeM entries from the cache. +The default is 15. If you make it shorter Gnus will be faster, but you +might then see old spam. + +@end table + +Using NoCeM could potentially be a memory hog. If you have many living +(i. e., subscribed or unsubscribed groups), your Emacs process will grow +big. If this is a problem, you should kill off all (or most) of your +unsubscribed groups (@pxref{Subscription Commands}). + + +@node Undo +@section Undo +@cindex undo + +It is very useful to be able to undo actions one has done. In normal +Emacs buffers, it's easy enough---you just push the @code{undo} button. +In Gnus buffers, however, it isn't that simple. + +The things Gnus displays in its buffer is of no value whatsoever to +Gnus---it's all just data designed to look nice to the user. +Killing a group in the group buffer with @kbd{C-k} makes the line +disappear, but that's just a side-effect of the real action---the +removal of the group in question from the internal Gnus structures. +Undoing something like that can't be done by the normal Emacs +@code{undo} function. + +Gnus tries to remedy this somewhat by keeping track of what the user +does and coming up with actions that would reverse the actions the user +takes. When the user then presses the @code{undo} key, Gnus will run +the code to reverse the previous action, or the previous actions. +However, not all actions are easily reversible, so Gnus currently offers +a few key functions to be undoable. These include killing groups, +yanking groups, and changing the list of read articles of groups. +That's it, really. More functions may be added in the future, but each +added function means an increase in data to be stored, so Gnus will +never be totally undoable. + +@findex gnus-undo-mode +@vindex gnus-use-undo +@findex gnus-undo +The undoability is provided by the @code{gnus-undo-mode} minor mode. It +is used if @code{gnus-use-undo} is non-@code{nil}, which is the +default. The @kbd{M-C-_} key performs the @code{gnus-undo} command +command, which should feel kinda like the normal Emacs @code{undo} +command. + + +@node Moderation +@section Moderation +@cindex moderation + +If you are a moderator, you can use the @file{gnus-mdrtn.el} package. +It is not included in the standard Gnus package. Write a mail to +@samp{larsi@@gnus.org} and state what group you moderate, and you'll +get a copy. + +The moderation package is implemented as a minor mode for summary +buffers. Put + +@lisp +(add-hook 'gnus-summary-mode-hook 'gnus-moderate) +@end lisp + +in your @file{.gnus.el} file. + +If you are the moderator of @samp{rec.zoofle}, this is how it's +supposed to work: + +@enumerate +@item +You split your incoming mail by matching on +@samp{Newsgroups:.*rec.zoofle}, which will put all the to-be-posted +articles in some mail group---for instance, @samp{nnml:rec.zoofle}. + +@item +You enter that group once in a while and post articles using the @kbd{e} +(edit-and-post) or @kbd{s} (just send unedited) commands. + +@item +If, while reading the @samp{rec.zoofle} newsgroup, you happen upon some +articles that weren't approved by you, you can cancel them with the +@kbd{c} command. +@end enumerate + +To use moderation mode in these two groups, say: + +@lisp +(setq gnus-moderated-list + "^nnml:rec.zoofle$\\|^rec.zoofle$") +@end lisp + + +@node XEmacs Enhancements +@section XEmacs Enhancements +@cindex XEmacs + +XEmacs is able to display pictures and stuff, so Gnus has taken +advantage of that. + +@menu +* Picons:: How to display pictures of what your reading. +* Smileys:: Show all those happy faces the way they were meant to be shown. +* Toolbar:: Click'n'drool. +* XVarious:: Other XEmacsy Gnusey variables. +@end menu + + +@node Picons +@subsection Picons + +@iftex +@iflatex +\gnuspicon{tmp/picons-att.ps} +\gnuspicon{tmp/picons-berkeley.ps} +\gnuspicon{tmp/picons-caltech.ps} +\gnuspicon{tmp/picons-canada.ps} +\gnuspicon{tmp/picons-cr.ps} +\gnuspicon{tmp/picons-cygnus.ps} +\gnuspicon{tmp/picons-gov.ps} +\gnuspicon{tmp/picons-mit.ps} +\gnuspicon{tmp/picons-nasa.ps} +\gnuspicon{tmp/picons-qmw.ps} +\gnuspicon{tmp/picons-rms.ps} +\gnuspicon{tmp/picons-ruu.ps} +@end iflatex +@end iftex + +So... You want to slow down your news reader even more! This is a +good way to do so. Its also a great way to impress people staring +over your shoulder as you read news. + +@menu +* Picon Basics:: What are picons and How do I get them. +* Picon Requirements:: Don't go further if you aren't using XEmacs. +* Easy Picons:: Displaying Picons---the easy way. +* Hard Picons:: The way you should do it. You'll learn something. +* Picon Configuration:: Other variables you can trash/tweak/munge/play with. +@end menu + + +@node Picon Basics +@subsubsection Picon Basics + +What are Picons? To quote directly from the Picons Web site: + +@quotation +@dfn{Picons} is short for ``personal icons''. They're small, +constrained images used to represent users and domains on the net, +organized into databases so that the appropriate image for a given +e-mail address can be found. Besides users and domains, there are picon +databases for Usenet newsgroups and weather forecasts. The picons are +in either monochrome @code{XBM} format or color @code{XPM} and +@code{GIF} formats. +@end quotation + +For instructions on obtaining and installing the picons databases, point +your Web browser at +@file{http://www.cs.indiana.edu/picons/ftp/index.html}. + +@vindex gnus-picons-database +Gnus expects picons to be installed into a location pointed to by +@code{gnus-picons-database}. + + +@node Picon Requirements +@subsubsection Picon Requirements + +To have Gnus display Picons for you, you must be running XEmacs +19.13 or greater since all other versions of Emacs aren't yet able to +display images. + +Additionally, you must have @code{xpm} support compiled into XEmacs. + +@vindex gnus-picons-convert-x-face +If you want to display faces from @code{X-Face} headers, you must have +the @code{netpbm} utilities installed, or munge the +@code{gnus-picons-convert-x-face} variable to use something else. + + +@node Easy Picons +@subsubsection Easy Picons + +To enable displaying picons, simply put the following line in your +@file{~/.gnus} file and start Gnus. + +@lisp +(setq gnus-use-picons t) +(add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) +(add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t) +(add-hook 'gnus-article-display-hook 'gnus-picons-article-display-x-face) +@end lisp + + +@node Hard Picons +@subsubsection Hard Picons + +Gnus can display picons for you as you enter and leave groups and +articles. It knows how to interact with three sections of the picons +database. Namely, it can display the picons newsgroup pictures, +author's face picture(s), and the authors domain. To enable this +feature, you need to first decide where to display them. + +@table @code + +@item gnus-picons-display-where +@vindex gnus-picons-display-where +Where the picon images should be displayed. It is @code{picons} by +default (which by default maps to the buffer @samp{*Picons*}). Other +valid places could be @code{article}, @code{summary}, or +@samp{*scratch*} for all I care. Just make sure that you've made the +buffer visible using the standard Gnus window configuration +routines---@pxref{Windows Configuration}. + +@end table + +@iftex +@iflatex +\gnuspicon{tmp/picons-seuu.ps} +\gnuspicon{tmp/picons-stanford.ps} +\gnuspicon{tmp/picons-sun.ps} +\gnuspicon{tmp/picons-ubc.ps} +\gnuspicon{tmp/picons-ufl.ps} +\gnuspicon{tmp/picons-uio.ps} +\gnuspicon{tmp/picons-unit.ps} +\gnuspicon{tmp/picons-upenn.ps} +\gnuspicon{tmp/picons-wesleyan.ps} +@end iflatex +@end iftex + +Note: If you set @code{gnus-use-picons} to @code{t}, it will set up your +window configuration for you to include the @code{picons} buffer. + +Now that you've made that decision, you need to add the following +functions to the appropriate hooks so these pictures will get +displayed at the right time. + +@vindex gnus-article-display-hook +@vindex gnus-picons-display-where +@table @code +@item gnus-article-display-picons +@findex gnus-article-display-picons +Looks up and displays the picons for the author and the author's domain +in the @code{gnus-picons-display-where} buffer. Should be added to the +@code{gnus-article-display-hook}. + +@item gnus-group-display-picons +@findex gnus-article-display-picons +Displays picons representing the current group. This function should +be added to the @code{gnus-summary-prepare-hook} or to the +@code{gnus-article-display-hook} if @code{gnus-picons-display-where} +is set to @code{article}. + +@item gnus-picons-article-display-x-face +@findex gnus-article-display-picons +Decodes and displays the X-Face header if present. This function +should be added to @code{gnus-article-display-hook}. + +@end table + +Note: You must append them to the hook, so make sure to specify 't' +for the append flag of @code{add-hook}: + +@lisp +(add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) +@end lisp + + +@node Picon Configuration +@subsubsection Picon Configuration + +The following variables offer further control over how things are +done, where things are located, and other useless stuff you really +don't need to worry about. + +@table @code +@item gnus-picons-database +@vindex gnus-picons-database +The location of the picons database. Should point to a directory +containing the @file{news}, @file{domains}, @file{users} (and so on) +subdirectories. Defaults to @file{/usr/local/faces}. + +@item gnus-picons-news-directory +@vindex gnus-picons-news-directory +Sub-directory of the faces database containing the icons for +newsgroups. + +@item gnus-picons-user-directories +@vindex gnus-picons-user-directories +List of subdirectories to search in @code{gnus-picons-database} for user +faces. @code{("local" "users" "usenix" "misc")} is the default. + +@item gnus-picons-domain-directories +@vindex gnus-picons-domain-directories +List of subdirectories to search in @code{gnus-picons-database} for +domain name faces. Defaults to @code{("domains")}. Some people may +want to add @samp{unknown} to this list. + +@item gnus-picons-convert-x-face +@vindex gnus-picons-convert-x-face +The command to use to convert the @code{X-Face} header to an X bitmap +(@code{xbm}). Defaults to @code{(format "@{ echo '/* Width=48, +Height=48 */'; uncompface; @} | icontopbm | pbmtoxbm > %s" +gnus-picons-x-face-file-name)} + +@item gnus-picons-x-face-file-name +@vindex gnus-picons-x-face-file-name +Names a temporary file to store the @code{X-Face} bitmap in. Defaults +to @code{(format "/tmp/picon-xface.%s.xbm" (user-login-name))}. + +@item gnus-picons-buffer +@vindex gnus-picons-buffer +The name of the buffer that @code{picons} points to. Defaults to +@samp{*Icon Buffer*}. + +@end table + +@node Smileys +@subsection Smileys +@cindex smileys + +@dfn{Smiley} is a package separate from Gnus, but since Gnus is +currently the only package that uses Smiley, it is documented here. + +In short---to use Smiley in Gnus, put the following in your +@file{.gnus.el} file: + +@lisp +(add-hook 'gnus-article-display-hook 'gnus-smiley-display t) +@end lisp + +Smiley maps text smiley faces---@samp{:-)}, @samp{:-=}, @samp{:-(} and +the like---to pictures and displays those instead of the text smiley +faces. The conversion is controlled by a list of regexps that matches +text and maps that to file names. + +@vindex smiley-nosey-regexp-alist +@vindex smiley-deformed-regexp-alist +Smiley supplies two example conversion alists by default: +@code{smiley-deformed-regexp-alist} (which matches @samp{:)}, @samp{:(} +and so on), and @code{smiley-nosey-regexp-alist} (which matches +@samp{:-)}, @samp{:-(} and so on). + +The alist used is specified by the @code{smiley-regexp-alist} variable, +which defaults to the value of @code{smiley-deformed-regexp-alist}. + +Here's the default value of @code{smiley-smiley-regexp-alist}: + +@lisp +(setq smiley-nosey-regexp-alist + '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm") + ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") + ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm") + ("\\(:-+[@}»]+\\)\\W" 1 "FaceHappy.xpm") + ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") + ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm") + ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm") + ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm") + ("\\(:-+[(@{]+\\)\\W" 1 "FaceSad.xpm") + ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm") + ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm") + ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm") + ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm") + ("\\(;-+[>)@}»]+\\)\\W" 1 "FaceWinking.xpm") + ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm") + ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm") + ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))) +@end lisp + +The first item in each element is the regexp to be matched; the second +element is the regexp match group that is to be replaced by the picture; +and the third element is the name of the file to be displayed. + +The following variables customize where Smiley will look for these +files, as well as the color to be used and stuff: + +@table @code + +@item smiley-data-directory +@vindex smiley-data-directory +Where Smiley will look for smiley faces files. + +@item smiley-flesh-color +@vindex smiley-flesh-color +Skin color. The default is @samp{yellow}, which is really racist. + +@item smiley-features-color +@vindex smiley-features-color +Color of the features of the face. The default is @samp{black}. + +@item smiley-tongue-color +@vindex smiley-tongue-color +Color of the tongue. The default is @samp{red}. + +@item smiley-circle-color +@vindex smiley-circle-color +Color of the circle around the face. The default is @samp{black}. + +@item smiley-mouse-face +@vindex smiley-mouse-face +Face used for mouse highlighting over the smiley face. + +@end table + + +@node Toolbar +@subsection Toolbar + +@table @code + +@item gnus-use-toolbar +@vindex gnus-use-toolbar +If @code{nil}, don't display toolbars. If non-@code{nil}, it should be +one of @code{default-toolbar}, @code{top-toolbar}, @code{bottom-toolbar}, +@code{right-toolbar}, or @code{left-toolbar}. + +@item gnus-group-toolbar +@vindex gnus-group-toolbar +The toolbar in the group buffer. + +@item gnus-summary-toolbar +@vindex gnus-summary-toolbar +The toolbar in the summary buffer. + +@item gnus-summary-mail-toolbar +@vindex gnus-summary-mail-toolbar +The toolbar in the summary buffer of mail groups. + +@end table + + +@node XVarious +@subsection Various XEmacs Variables + +@table @code +@item gnus-xmas-glyph-directory +@vindex gnus-xmas-glyph-directory +This is where Gnus will look for pictures. Gnus will normally +auto-detect this directory, but you may set it manually if you have an +unusual directory structure. + +@item gnus-xmas-logo-color-alist +@vindex gnus-xmas-logo-color-alist +This is an alist where the key is a type symbol and the values are the +foreground and background color of the splash page glyph. + +@item gnus-xmas-logo-color-style +@vindex gnus-xmas-logo-color-style +This is the key used to look up the color in the alist described above. +Legal values include @code{flame}, @code{pine}, @code{moss}, +@code{irish}, @code{sky}, @code{tin}, @code{velvet}, @code{grape}, +@code{labia}, @code{berry}, @code{neutral}, and @code{september}. + +@item gnus-xmas-modeline-glyph +@vindex gnus-xmas-modeline-glyph +A glyph displayed in all Gnus mode lines. It is a tiny gnu head by +default. + +@end table + + + + +@node Fuzzy Matching +@section Fuzzy Matching +@cindex fuzzy matching + +Gnus provides @dfn{fuzzy matching} of @code{Subject} lines when doing +things like scoring, thread gathering and thread comparison. + +As opposed to regular expression matching, fuzzy matching is very fuzzy. +It's so fuzzy that there's not even a definition of what @dfn{fuzziness} +means, and the implementation has changed over time. + +Basically, it tries to remove all noise from lines before comparing. +@samp{Re: }, parenthetical remarks, white space, and so on, are filtered +out of the strings before comparing the results. This often leads to +adequate results---even when faced with strings generated by text +manglers masquerading as newsreaders. + + +@node Thwarting Email Spam +@section Thwarting Email Spam +@cindex email spam +@cindex spam +@cindex UCE +@cindex unsolicited commercial email + +In these last days of the Usenet, commercial vultures are hanging about +and grepping through news like crazy to find email addresses they can +foist off their scams and products to. As a reaction to this, many +people have started putting nonsense addresses into their @code{From} +lines. I think this is counterproductive---it makes it difficult for +people to send you legitimate mail in response to things you write, as +well as making it difficult to see who wrote what. This rewriting may +perhaps be a bigger menace than the unsolicited commercial email itself +in the end. + +The biggest problem I have with email spam is that it comes in under +false pretenses. I press @kbd{g} and Gnus merrily informs me that I +have 10 new emails. I say ``Golly gee! Happy is me!'' and select the +mail group, only to find two pyramid schemes, seven advertisements +(``New! Miracle tonic for growing full, lustrouos hair on your toes!'') +and one mail asking me to repent and find some god. + +This is annoying. + +The way to deal with this is having Gnus split out all spam into a +@samp{spam} mail group (@pxref{Splitting Mail}). + +First, pick one (1) valid mail address that you can be reached at, and +put it in your @code{From} header of all your news articles. (I've +chosen @samp{larsi@@trym.ifi.uio.no}, but for many addresses on the form +@samp{larsi+usenet@@ifi.uio.no} will be a better choice. Ask your +sysadm whether your sendmail installation accepts keywords in the local +part of the mail address.) + +@lisp +(setq message-default-news-headers + "From: Lars Magne Ingebrigtsen \n") +@end lisp + +Then put the following split rule in @code{nnmail-split-fancy} +(@pxref{Fancy Mail Splitting}): + +@lisp +( + ... + (to "larsi@@trym.ifi.uio.no" + (| ("subject" "re:.*" "misc") + ("references" ".*@@.*" "misc") + "spam")) + ... +) +@end lisp + +This says that all mail to this address is suspect, but if it has a +@code{Subject} that starts with a @samp{Re:} or has a @code{References} +header, it's probably ok. All the rest goes to the @samp{spam} group. +(This idea probably comes from Tim Pierce.) + +In addition, many mail spammers talk directly to your @code{smtp} server +and do not include your email address explicitly in the @code{To} +header. Why they do this is unknown---perhaps it's to thwart this +twarting scheme? In any case, this is trivial to deal with---you just +put anything not addressed to you in the @samp{spam} group by ending +your fancy split rule in this way: + +@lisp +( + ... + (to "larsi" "misc") + "spam") +@end lisp + +In my experience, this will sort virtually everything into the right +group. You still have to check the @samp{spam} group from time to time to +check for legitimate mail, though. If you feel like being a good net +citizen, you can even send off complaints to the proper authorities on +each unsolicited commercial email---at your leisure. + +If you are also a lazy net citizen, you will probably prefer complaining +automatically with the @file{gnus-junk.el} package, availiable FOR FREE +at @file{}. +Since most e-mail spam is sent automatically, this may reconcile the +cosmic balance somewhat. + +This works for me. It allows people an easy way to contact me (they can +just press @kbd{r} in the usual way), and I'm not bothered at all with +spam. It's a win-win situation. Forging @code{From} headers to point +to non-existant domains is yucky, in my opinion. + + +@node Various Various +@section Various Various +@cindex mode lines +@cindex highlights + +@table @code + +@item gnus-home-directory +All Gnus path variables will be initialized from this variable, which +defaults to @file{~/}. + +@item gnus-directory +@vindex gnus-directory +Most Gnus storage path variables will be initialized from this variable, +which defaults to the @samp{SAVEDIR} environment variable, or +@file{~/News/} if that variable isn't set. + +@item gnus-default-directory +@vindex gnus-default-directory +Not related to the above variable at all---this variable says what the +default directory of all Gnus buffers should be. If you issue commands +like @kbd{C-x C-f}, the prompt you'll get starts in the current buffer's +default directory. If this variable is @code{nil} (which is the +default), the default directory will be the default directory of the +buffer you were in when you started Gnus. + +@item gnus-verbose +@vindex gnus-verbose +This variable is an integer between zero and ten. The higher the value, +the more messages will be displayed. If this variable is zero, Gnus +will never flash any messages, if it is seven (which is the default), +most important messages will be shown, and if it is ten, Gnus won't ever +shut up, but will flash so many messages it will make your head swim. + +@item gnus-verbose-backends +@vindex gnus-verbose-backends +This variable works the same way as @code{gnus-verbose}, but it applies +to the Gnus backends instead of Gnus proper. + +@item nnheader-max-head-length +@vindex nnheader-max-head-length +When the backends read straight heads of articles, they all try to read +as little as possible. This variable (default 4096) specifies +the absolute max length the backends will try to read before giving up +on finding a separator line between the head and the body. If this +variable is @code{nil}, there is no upper read bound. If it is +@code{t}, the backends won't try to read the articles piece by piece, +but read the entire articles. This makes sense with some versions of +@code{ange-ftp} or @code{efs}. + +@item nnheader-head-chop-length +@vindex nnheader-head-chop-length +This variable (default 2048) says how big a piece of each article to +read when doing the operation described above. + +@item nnheader-file-name-translation-alist +@vindex nnheader-file-name-translation-alist +@cindex file names +@cindex invalid characters in file names +@cindex characters in file names +This is an alist that says how to translate characters in file names. +For instance, if @samp{:} is invalid as a file character in file names +on your system (you OS/2 user you), you could say something like: + +@lisp +(setq nnheader-file-name-translation-alist + '((?: . ?_))) +@end lisp + +In fact, this is the default value for this variable on OS/2 and MS +Windows (phooey) systems. + +@item gnus-hidden-properties +@vindex gnus-hidden-properties +This is a list of properties to use to hide ``invisible'' text. It is +@code{(invisible t intangible t)} by default on most systems, which +makes invisible text invisible and intangible. + +@item gnus-parse-headers-hook +@vindex gnus-parse-headers-hook +A hook called before parsing headers. It can be used, for instance, to +gather statistics on the headers fetched, or perhaps you'd like to prune +some headers. I don't see why you'd want that, though. + +@item gnus-shell-command-separator +@vindex gnus-shell-command-separator +String used to separate two shell commands. The default is @samp{;}. + + +@end table + + +@node The End +@chapter The End + +Well, that's the manual---you can get on with your life now. Keep in +touch. Say hello to your cats from me. + +My @strong{ghod}---I just can't stand goodbyes. Sniffle. + +Ol' Charles Reznikoff said it pretty well, so I leave the floor to him: + +@quotation +@strong{Te Deum} + +@sp 1 +Not because of victories @* +I sing,@* +having none,@* +but for the common sunshine,@* +the breeze,@* +the largess of the spring. + +@sp 1 +Not for victory@* +but for the day's work done@* +as well as I was able;@* +not for a seat upon the dais@* +but at the common table.@* +@end quotation + + +@node Appendices +@chapter Appendices + +@menu +* History:: How Gnus got where it is today. +* Terminology:: We use really difficult, like, words here. +* Customization:: Tailoring Gnus to your needs. +* Troubleshooting:: What you might try if things do not work. +* A Programmers Guide to Gnus:: Rilly, rilly technical stuff. +* Emacs for Heathens:: A short introduction to Emacsian terms. +* Frequently Asked Questions:: A question-and-answer session. +@end menu + + +@node History +@section History + +@cindex history +@sc{gnus} was written by Masanobu @sc{Umeda}. When autumn crept up in +'94, Lars Magne Ingebrigtsen grew bored and decided to rewrite Gnus. + +If you want to investigate the person responsible for this outrage, you +can point your (feh!) web browser to +@file{http://www.ifi.uio.no/~larsi/}. This is also the primary +distribution point for the new and spiffy versions of Gnus, and is known +as The Site That Destroys Newsrcs And Drives People Mad. + +During the first extended alpha period of development, the new Gnus was +called ``(ding) Gnus''. @dfn{(ding)} is, of course, short for +@dfn{ding is not Gnus}, which is a total and utter lie, but who cares? +(Besides, the ``Gnus'' in this abbreviation should probably be +pronounced ``news'' as @sc{Umeda} intended, which makes it a more +appropriate name, don't you think?) + +In any case, after spending all that energy on coming up with a new and +spunky name, we decided that the name was @emph{too} spunky, so we +renamed it back again to ``Gnus''. But in mixed case. ``Gnus'' vs. +``@sc{gnus}''. New vs. old. + +The first ``proper'' release of Gnus 5 was done in November 1995 when it +was included in the Emacs 19.30 distribution (132 (ding) Gnus releases +plus 15 Gnus 5.0 releases). + +In May 1996 the next Gnus generation (aka. ``September Gnus'' (after 99 +releases)) was released under the name ``Gnus 5.2'' (40 releases). + +On July 28th 1996 work on Red Gnus was begun, and it was released on +January 25th 1997 (after 84 releases) as ``Gnus 5.4''. + +If you happen upon a version of Gnus that has a prefixed name -- +``(ding) Gnus'', ``September Gnus'', ``Red Gnus'', ``Quassia Gnus'' -- +don't panic. Don't let it know that you're frightened. Back away. +Slowly. Whatever you do, don't run. Walk away, calmly, until you're +out of its reach. Find a proper released version of Gnus and snuggle up +to that instead. + +@menu +* Why?:: What's the point of Gnus? +* Compatibility:: Just how compatible is Gnus with @sc{gnus}? +* Conformity:: Gnus tries to conform to all standards. +* Emacsen:: Gnus can be run on a few modern Emacsen. +* Contributors:: Oodles of people. +* New Features:: Pointers to some of the new stuff in Gnus. +* Newest Features:: Features so new that they haven't been written yet. +@end menu + + +@node Why? +@subsection Why? + +What's the point of Gnus? + +I want to provide a ``rad'', ``happening'', ``way cool'' and ``hep'' +newsreader, that lets you do anything you can think of. That was my +original motivation, but while working on Gnus, it has become clear to +me that this generation of newsreaders really belong in the stone age. +Newsreaders haven't developed much since the infancy of the net. If the +volume continues to rise with the current rate of increase, all current +newsreaders will be pretty much useless. How do you deal with +newsgroups that have thousands of new articles each day? How do you +keep track of millions of people who post? + +Gnus offers no real solutions to these questions, but I would very much +like to see Gnus being used as a testing ground for new methods of +reading and fetching news. Expanding on @sc{Umeda}-san's wise decision +to separate the newsreader from the backends, Gnus now offers a simple +interface for anybody who wants to write new backends for fetching mail +and news from different sources. I have added hooks for customizations +everywhere I could imagine it being useful. By doing so, I'm inviting +every one of you to explore and invent. + +May Gnus never be complete. @kbd{C-u 100 M-x all-hail-emacs} and +@kbd{C-u 100 M-x all-hail-xemacs}. + + +@node Compatibility +@subsection Compatibility + +@cindex compatibility +Gnus was designed to be fully compatible with @sc{gnus}. Almost all key +bindings have been kept. More key bindings have been added, of course, +but only in one or two obscure cases have old bindings been changed. + +Our motto is: +@quotation +@cartouche +@center In a cloud bones of steel. +@end cartouche +@end quotation + +All commands have kept their names. Some internal functions have changed +their names. + +The @code{gnus-uu} package has changed drastically. @xref{Decoding +Articles}. + +One major compatibility question is the presence of several summary +buffers. All variables relevant while reading a group are +buffer-local to the summary buffer they belong in. Although many +important variables have their values copied into their global +counterparts whenever a command is executed in the summary buffer, this +change might lead to incorrect values being used unless you are careful. + +All code that relies on knowledge of @sc{gnus} internals will probably +fail. To take two examples: Sorting @code{gnus-newsrc-alist} (or +changing it in any way, as a matter of fact) is strictly verboten. Gnus +maintains a hash table that points to the entries in this alist (which +speeds up many functions), and changing the alist directly will lead to +peculiar results. + +@cindex hilit19 +@cindex highlighting +Old hilit19 code does not work at all. In fact, you should probably +remove all hilit code from all Gnus hooks +(@code{gnus-group-prepare-hook} and @code{gnus-summary-prepare-hook}). +Gnus provides various integrated functions for highlighting. These are +faster and more accurate. To make life easier for everybody, Gnus will +by default remove all hilit calls from all hilit hooks. Uncleanliness! +Away! + +Packages like @code{expire-kill} will no longer work. As a matter of +fact, you should probably remove all old @sc{gnus} packages (and other +code) when you start using Gnus. More likely than not, Gnus already +does what you have written code to make @sc{gnus} do. (Snicker.) + +Even though old methods of doing things are still supported, only the +new methods are documented in this manual. If you detect a new method of +doing something while reading this manual, that does not mean you have +to stop doing it the old way. + +Gnus understands all @sc{gnus} startup files. + +@kindex M-x gnus-bug +@findex gnus-bug +@cindex reporting bugs +@cindex bugs +Overall, a casual user who hasn't written much code that depends on +@sc{gnus} internals should suffer no problems. If problems occur, +please let me know by issuing that magic command @kbd{M-x gnus-bug}. + + +@node Conformity +@subsection Conformity + +No rebels without a clue here, ma'am. We conform to all standards known +to (wo)man. Except for those standards and/or conventions we disagree +with, of course. + +@table @strong + +@item RFC 822 +@cindex RFC 822 +There are no known breaches of this standard. + +@item RFC 1036 +@cindex RFC 1036 +There are no known breaches of this standard, either. + +@item Good Net-Keeping Seal of Approval +@cindex Good Net-Keeping Seal of Approval +Gnus has been through the Seal process and failed. I think it'll pass +the next inspection. + +@item Son-of-RFC 1036 +@cindex Son-of-RFC 1036 +We do have some breaches to this one. + +@table @emph + +@item MIME +Gnus does no MIME handling, and this standard-to-be seems to think that +MIME is the bees' knees, so we have major breakage here. + +@item X-Newsreader +This is considered to be a ``vanity header'', while I consider it to be +consumer information. After seeing so many badly formatted articles +coming from @code{tin} and @code{Netscape} I know not to use either of +those for posting articles. I would not have known that if it wasn't +for the @code{X-Newsreader} header. +@end table + +@end table + +If you ever notice Gnus acting non-compliant with regards to the texts +mentioned above, don't hesitate to drop a note to Gnus Towers and let us +know. + + +@node Emacsen +@subsection Emacsen +@cindex Emacsen +@cindex XEmacs +@cindex Mule +@cindex Emacs + +Gnus should work on : + +@itemize @bullet + +@item +Emacs 19.32 and up. + +@item +XEmacs 19.14 and up. + +@item +Mule versions based on Emacs 19.32 and up. + +@end itemize + +Gnus will absolutely not work on any Emacsen older than that. Not +reliably, at least. + +There are some vague differences between Gnus on the various +platforms---XEmacs features more graphics (a logo and a toolbar)---but +other than that, things should look pretty much the same under all +Emacsen. + + +@node Contributors +@subsection Contributors +@cindex contributors + +The new Gnus version couldn't have been done without the help of all the +people on the (ding) mailing list. Every day for over a year I have +gotten billions of nice bug reports from them, filling me with joy, +every single one of them. Smooches. The people on the list have been +tried beyond endurance, what with my ``oh, that's a neat idea , yup, I'll release it right away no wait, that doesn't +work at all , yup, I'll ship that one off right away no, wait, that absolutely does not work'' policy for releases. +Micro$oft---bah. Amateurs. I'm @emph{much} worse. (Or is that +``worser''? ``much worser''? ``worsest''?) + +I would like to take this opportunity to thank the Academy for... oops, +wrong show. + +@itemize @bullet + +@item +Masanobu @sc{Umeda}---the writer of the original @sc{gnus}. + +@item +Per Abrahamsen---custom, scoring, highlighting and @sc{soup} code (as +well as numerous other things). + +@item +Luis Fernandes---design and graphics. + +@item +Erik Naggum---help, ideas, support, code and stuff. + +@item +Wes Hardaker---@file{gnus-picon.el} and the manual section on +@dfn{picons} (@pxref{Picons}). + +@item +Kim-Minh Kaplan---further work on the picon code. + +@item +Brad Miller---@file{gnus-gl.el} and the GroupLens manual section +(@pxref{GroupLens}). + +@item +Sudish Joseph---innumerable bug fixes. + +@item +Ilja Weis---@file{gnus-topic.el}. + +@item +Steven L. Baur---lots and lots and lots of bugs detections and fixes. + +@item +Vladimir Alexiev---the refcard and reference booklets. + +@item +Felix Lee & Jamie Zawinsky---I stole some pieces from the XGnus +distribution by Felix Lee and JWZ. + +@item +Scott Byer---@file{nnfolder.el} enhancements & rewrite. + +@item +Peter Mutsaers---orphan article scoring code. + +@item +Ken Raeburn---POP mail support. + +@item +Hallvard B Furuseth---various bits and pieces, especially dealing with +.newsrc files. + +@item +Brian Edmonds---@file{gnus-bbdb.el}. + +@item +David Moore---rewrite of @file{nnvirtual.el} and many other things. + +@item +Kevin Davidson---came up with the name @dfn{ding}, so blame him. + +@item +François Pinard---many, many interesting and thorough bug reports. + +@end itemize + +This manual was proof-read by Adrian Aichner, with Ricardo Nassif, Mark +Borges, and Jost Krieger proof-reading parts of the manual. + +The following people have contributed many patches and suggestions: + +Christopher Davis, +Andrew Eskilsson, +Kai Grossjohann, +David Kågedal, +Richard Pieri, +Fabrice Popineau, +Daniel Quinlan, +Jason L. Tibbitts, III, +and +Jack Vinson. + +Also thanks to the following for patches and stuff: + +Adrian Aichner, +Peter Arius, +Matt Armstrong, +Marc Auslander, +Robert Bihlmeyer, +Chris Bone, +Mark Borges, +Mark Boyns, +Lance A. Brown, +Kees de Bruin, +Martin Buchholz, +Kevin Buhr, +Alastair Burt, +Joao Cachopo, +Zlatko Calusic, +Massimo Campostrini, +Dan Christensen, +Michael R. Cook, +Glenn Coombs, +Frank D. Cringle, +Geoffrey T. Dairiki, +Andre Deparade, +Ulrik Dickow, +Dave Disser, +Joev Dubach, +Michael Welsh Duggan, +Paul Eggert, +Michael Ernst, +Luc Van Eycken, +Sam Falkner, +Nelson Jose dos Santos Ferreira, +Sigbjorn Finne, +Gary D. Foster, +Paul Franklin, +Guy Geens, +Arne Georg Gleditsch, +David S. Goldberg, +Michelangelo Grigni, +D. Hall, +Magnus Hammerin, +Raja R. Harinath, +Hisashige Kenji, @c Hisashige +Marc Horowitz, +Gunnar Horrigmo, +Brad Howes, +François Felix Ingrand, +Ishikawa Ichiro, @c Ishikawa +Lee Iverson, +Rajappa Iyer, +Andreas Jaeger, +Randell Jesup, +Fred Johansen, +Greg Klanderman, +Karl Kleinpaste, +Peter Skov Knudsen, +Shuhei Kobayashi, @c Kobayashi +Thor Kristoffersen, +Jens Lautenbacher, +Carsten Leonhardt, +James LewisMoss, +Christian Limpach, +Markus Linnala, +Dave Love, +Tonny Madsen, +Shlomo Mahlab, +Nat Makarevitch, +David Martin, +Gordon Matzigkeit, +Timo Metzemakers, +Richard Mlynarik, +Lantz Moore, +Morioka Tomohiko, @c Morioka +Erik Toubro Nielsen, +Hrvoje Niksic, +Andy Norman, +C. R. Oldham, +Alexandre Oliva, +Ken Olstad, +Masaharu Onishi, @c Onishi +Hideki Ono, @c Ono +William Perry, +Stephen Peters, +Ulrich Pfeifer, +John McClary Prevost, +Colin Rafferty, +Bart Robinson, +Jason Rumney, +Jay Sachs, +Dewey M. Sasser, +Loren Schall, +Dan Schmidt, +Ralph Schleicher, +Philippe Schnoebelen, +Randal L. Schwartz, +Justin Sheehy, +Danny Siu, +Matt Simmons, +Paul D. Smith, +Jeff Sparkes, +Toby Speight, +Michael Sperber, +Darren Stalder, +Richard Stallman, +Greg Stark, +Paul Stodghill, +Kurt Swanson, +Samuel Tardieu, +Teddy, +Chuck Thompson, +Philippe Troin, +James Troup, +Enami Tsugutomo, @c ? +Aaron M. Ucko, +Jan Vroonhof, +Barry A. Warsaw, +Christoph Wedler, +Joe Wells, +and +Katsumi Yamaoka. @c Yamaoka + +For a full overview of what each person has done, the ChangeLogs +included in the Gnus alpha distributions should give ample reading +(550kB and counting). + +Apologies to everybody that I've forgotten, of which there are many, I'm +sure. + +Gee, that's quite a list of people. I guess that must mean that there +actually are people who are using Gnus. Who'd'a thunk it! + + +@node New Features +@subsection New Features +@cindex new features + +@menu +* ding Gnus:: New things in Gnus 5.0/5.1, the first new Gnus. +* September Gnus:: The Thing Formally Known As Gnus 5.3/5.3. +* Red Gnus:: Third time best---Gnus 5.4/5.5. +@end menu + +These lists are, of course, just @emph{short} overviews of the +@emph{most} important new features. No, really. There are tons more. +Yes, we have feeping creaturism in full effect. + + +@node ding Gnus +@subsubsection (ding) Gnus + +New features in Gnus 5.0/5.1: + +@itemize @bullet + +@item +The look of all buffers can be changed by setting format-like variables +(@pxref{Group Buffer Format} and @pxref{Summary Buffer Format}). + +@item +Local spool and several @sc{nntp} servers can be used at once +(@pxref{Select Methods}). + +@item +You can combine groups into virtual groups (@pxref{Virtual Groups}). + +@item +You can read a number of different mail formats (@pxref{Getting Mail}). +All the mail backends implement a convenient mail expiry scheme +(@pxref{Expiring Mail}). + +@item +Gnus can use various strategies for gathering threads that have lost +their roots (thereby gathering loose sub-threads into one thread) or it +can go back and retrieve enough headers to build a complete thread +(@pxref{Customizing Threading}). + +@item +Killed groups can be displayed in the group buffer, and you can read +them as well (@pxref{Listing Groups}). + +@item +Gnus can do partial group updates---you do not have to retrieve the +entire active file just to check for new articles in a few groups +(@pxref{The Active File}). + +@item +Gnus implements a sliding scale of subscribedness to groups +(@pxref{Group Levels}). + +@item +You can score articles according to any number of criteria +(@pxref{Scoring}). You can even get Gnus to find out how to score +articles for you (@pxref{Adaptive Scoring}). + +@item +Gnus maintains a dribble buffer that is auto-saved the normal Emacs +manner, so it should be difficult to lose much data on what you have +read if your machine should go down (@pxref{Auto Save}). + +@item +Gnus now has its own startup file (@file{.gnus}) to avoid cluttering up +the @file{.emacs} file. + +@item +You can set the process mark on both groups and articles and perform +operations on all the marked items (@pxref{Process/Prefix}). + +@item +You can grep through a subset of groups and create a group from the +results (@pxref{Kibozed Groups}). + +@item +You can list subsets of groups according to, well, anything +(@pxref{Listing Groups}). + +@item +You can browse foreign servers and subscribe to groups from those +servers (@pxref{Browse Foreign Server}). + +@item +Gnus can fetch articles, asynchronously, on a second connection to the +server (@pxref{Asynchronous Fetching}). + +@item +You can cache articles locally (@pxref{Article Caching}). + +@item +The uudecode functions have been expanded and generalized +(@pxref{Decoding Articles}). + +@item +You can still post uuencoded articles, which was a little-known feature +of @sc{gnus}' past (@pxref{Uuencoding and Posting}). + +@item +Fetching parents (and other articles) now actually works without +glitches (@pxref{Finding the Parent}). + +@item +Gnus can fetch FAQs and group descriptions (@pxref{Group Information}). + +@item +Digests (and other files) can be used as the basis for groups +(@pxref{Document Groups}). + +@item +Articles can be highlighted and customized (@pxref{Customizing +Articles}). + +@item +URLs and other external references can be buttonized (@pxref{Article +Buttons}). + +@item +You can do lots of strange stuff with the Gnus window & frame +configuration (@pxref{Windows Configuration}). + +@item +You can click on buttons instead of using the keyboard +(@pxref{Buttons}). + +@end itemize + + +@node September Gnus +@subsubsection September Gnus + +New features in Gnus 5.2/5.3: + +@itemize @bullet + +@item +A new message composition mode is used. All old customization variables +for @code{mail-mode}, @code{rnews-reply-mode} and @code{gnus-msg} are +now obsolete. + +@item +Gnus is now able to generate @dfn{sparse} threads---threads where +missing articles are represented by empty nodes (@pxref{Customizing +Threading}). + +@lisp +(setq gnus-build-sparse-threads 'some) +@end lisp + +@item +Outgoing articles are stored on a special archive server +(@pxref{Archived Messages}). + +@item +Partial thread regeneration now happens when articles are +referred. + +@item +Gnus can make use of GroupLens predictions (@pxref{GroupLens}). + +@item +Picons (personal icons) can be displayed under XEmacs (@pxref{Picons}). + +@item +A @code{trn}-like tree buffer can be displayed (@pxref{Tree Display}). + +@lisp +(setq gnus-use-trees t) +@end lisp + +@item +An @code{nn}-like pick-and-read minor mode is available for the summary +buffers (@pxref{Pick and Read}). + +@lisp +(add-hook 'gnus-summary-mode-hook 'gnus-pick-mode) +@end lisp + +@item +In binary groups you can use a special binary minor mode (@pxref{Binary +Groups}). + +@item +Groups can be grouped in a folding topic hierarchy (@pxref{Group +Topics}). + +@lisp +(add-hook 'gnus-group-mode-hook 'gnus-topic-mode) +@end lisp + +@item +Gnus can re-send and bounce mail (@pxref{Summary Mail Commands}). + +@item +Groups can now have a score, and bubbling based on entry frequency +is possible (@pxref{Group Score}). + +@lisp +(add-hook 'gnus-summary-exit-hook 'gnus-summary-bubble-group) +@end lisp + +@item +Groups can be process-marked, and commands can be performed on +groups of groups (@pxref{Marking Groups}). + +@item +Caching is possible in virtual groups. + +@item +@code{nndoc} now understands all kinds of digests, mail boxes, rnews +news batches, ClariNet briefs collections, and just about everything +else (@pxref{Document Groups}). + +@item +Gnus has a new backend (@code{nnsoup}) to create/read SOUP packets +(@pxref{SOUP}). + +@item +The Gnus cache is much faster. + +@item +Groups can be sorted according to many criteria (@pxref{Sorting +Groups}). + +@item +New group parameters have been introduced to set list-addresses and +expiry times (@pxref{Group Parameters}). + +@item +All formatting specs allow specifying faces to be used +(@pxref{Formatting Fonts}). + +@item +There are several more commands for setting/removing/acting on process +marked articles on the @kbd{M P} submap (@pxref{Setting Process Marks}). + +@item +The summary buffer can be limited to show parts of the available +articles based on a wide range of criteria. These commands have been +bound to keys on the @kbd{/} submap (@pxref{Limiting}). + +@item +Articles can be made persistent with the @kbd{*} command +(@pxref{Persistent Articles}). + +@item +All functions for hiding article elements are now toggles. + +@item +Article headers can be buttonized (@pxref{Article Washing}). + +@lisp +(add-hook 'gnus-article-display-hook + 'gnus-article-add-buttons-to-head) +@end lisp + +@item +All mail backends support fetching articles by @code{Message-ID}. + +@item +Duplicate mail can now be treated properly (@pxref{Duplicates}). + +@item +All summary mode commands are available directly from the article +buffer (@pxref{Article Keymap}). + +@item +Frames can be part of @code{gnus-buffer-configuration} (@pxref{Windows +Configuration}). + +@item +Mail can be re-scanned by a daemonic process (@pxref{Daemons}). + +@item +Gnus can make use of NoCeM files to weed out spam (@pxref{NoCeM}). + +@lisp +(setq gnus-use-nocem t) +@end lisp + +@item +Groups can be made permanently visible (@pxref{Listing Groups}). + +@lisp +(setq gnus-permanently-visible-groups "^nnml:") +@end lisp + +@item +Many new hooks have been introduced to make customizing easier. + +@item +Gnus respects the @code{Mail-Copies-To} header. + +@item +Threads can be gathered by looking at the @code{References} header +(@pxref{Customizing Threading}). + +@lisp +(setq gnus-summary-thread-gathering-function + 'gnus-gather-threads-by-references) +@end lisp + +@item +Read articles can be stored in a special backlog buffer to avoid +refetching (@pxref{Article Backlog}). + +@lisp +(setq gnus-keep-backlog 50) +@end lisp + +@item +A clean copy of the current article is always stored in a separate +buffer to allow easier treatment. + +@item +Gnus can suggest where to save articles (@pxref{Saving Articles}). + +@item +Gnus doesn't have to do as much prompting when saving (@pxref{Saving +Articles}). + +@lisp +(setq gnus-prompt-before-saving t) +@end lisp + +@item +@code{gnus-uu} can view decoded files asynchronously while fetching +articles (@pxref{Other Decode Variables}). + +@lisp +(setq gnus-uu-grabbed-file-functions 'gnus-uu-grab-view) +@end lisp + +@item +Filling in the article buffer now works properly on cited text +(@pxref{Article Washing}). + +@item +Hiding cited text adds buttons to toggle hiding, and how much +cited text to hide is now customizable (@pxref{Article Hiding}). + +@lisp +(setq gnus-cited-lines-visible 2) +@end lisp + +@item +Boring headers can be hidden (@pxref{Article Hiding}). + +@lisp +(add-hook 'gnus-article-display-hook + 'gnus-article-hide-boring-headers t) +@end lisp + +@item +Default scoring values can now be set from the menu bar. + +@item +Further syntax checking of outgoing articles have been added. + +@end itemize + + +@node Red Gnus +@subsubsection Red Gnus + +New features in Gnus 5.4/5.5: + +@itemize @bullet + +@item +@file{nntp.el} has been totally rewritten in an asynchronous fashion. + +@item +Article prefetching functionality has been moved up into +Gnus (@pxref{Asynchronous Fetching}). + +@item +Scoring can now be performed with logical operators like @code{and}, +@code{or}, @code{not}, and parent redirection (@pxref{Advanced +Scoring}). + +@item +Article washing status can be displayed in the +article mode line (@pxref{Misc Article}). + +@item +@file{gnus.el} has been split into many smaller files. + +@item +Suppression of duplicate articles based on Message-ID can be done +(@pxref{Duplicate Suppression}). + +@lisp +(setq gnus-suppress-duplicates t) +@end lisp + +@item +New variables for specifying what score and adapt files are to be +considered home score and adapt files (@pxref{Home Score File}) have +been added. + +@item +@code{nndoc} was rewritten to be easily extendable (@pxref{Document +Server Internals}). + +@item +Groups can inherit group parameters from parent topics (@pxref{Topic +Parameters}). + +@item +Article editing has been revamped and is now actually usable. + +@item +Signatures can be recognized in more intelligent fashions +(@pxref{Article Signature}). + +@item +Summary pick mode has been made to look more @code{nn}-like. Line +numbers are displayed and the @kbd{.} command can be used to pick +articles (@code{Pick and Read}). + +@item +Commands for moving the @file{.newsrc.eld} from one server to +another have been added (@pxref{Changing Servers}). + +@item +There's a way now to specify that ``uninteresting'' fields be suppressed +when generating lines in buffers (@pxref{Advanced Formatting}). + +@item +Several commands in the group buffer can be undone with @kbd{M-C-_} +(@pxref{Undo}). + +@item +Scoring can be done on words using the new score type @code{w} +(@pxref{Score File Format}). + +@item +Adaptive scoring can be done on a Subject word-by-word basis +(@pxref{Adaptive Scoring}). + +@lisp +(setq gnus-use-adaptive-scoring '(word)) +@end lisp + +@item +Scores can be decayed (@pxref{Score Decays}). + +@lisp +(setq gnus-decay-scores t) +@end lisp + +@item +Scoring can be performed using a regexp on the Date header. The Date is +normalized to compact ISO 8601 format first (@pxref{Score File Format}). + +@item +A new command has been added to remove all data on articles from +the native server (@pxref{Changing Servers}). + +@item +A new command for reading collections of documents +(@code{nndoc} with @code{nnvirtual} on top) has been added---@kbd{M-C-d} +(@pxref{Really Various Summary Commands}). + +@item +Process mark sets can be pushed and popped (@pxref{Setting Process +Marks}). + +@item +A new mail-to-news backend makes it possible to post even when the NNTP +server doesn't allow posting (@pxref{Mail-To-News Gateways}). + +@item +A new backend for reading searches from Web search engines +(@dfn{DejaNews}, @dfn{Alta Vista}, @dfn{InReference}) has been added +(@pxref{Web Searches}). + +@item +Groups inside topics can now be sorted using the standard sorting +functions, and each topic can be sorted independently (@pxref{Topic +Sorting}). + +@item +Subsets of the groups can be sorted independently (@code{Sorting +Groups}). + +@item +Cached articles can be pulled into the groups (@pxref{Summary Generation +Commands}). + +@item +Score files are now applied in a more reliable order (@pxref{Score +Variables}). + +@item +Reports on where mail messages end up can be generated (@pxref{Splitting +Mail}). + +@item +More hooks and functions have been added to remove junk from incoming +mail before saving the mail (@pxref{Washing Mail}). + +@item +Emphasized text can be properly fontisized: + +@lisp +(add-hook 'gnus-article-display-hook 'gnus-article-emphasize) +@end lisp + +@end itemize + + +@node Newest Features +@subsection Newest Features +@cindex todo + +Also known as the @dfn{todo list}. Sure to be implemented before the +next millennium. + +Be afraid. Be very afraid. + +@itemize @bullet +@item +Native @sc{mime} support is something that should be done. +@item +Really do unbinhexing. +@end itemize + +And much, much, much more. There is more to come than has already been +implemented. (But that's always true, isn't it?) + +@file{} is where the actual +up-to-the-second todo list is located, so if you're really curious, you +could point your Web browser over that-a-way. + +@iftex + +@node The Manual +@section The Manual +@cindex colophon +@cindex manual + +This manual was generated from a TeXinfo file and then run through +either @code{texi2dvi} +@iflatex +or my own home-brewed TeXinfo to \LaTeX\ transformer, +and then run through @code{latex} and @code{dvips} +@end iflatex +to get what you hold in your hands now. + +The following conventions have been used: + +@enumerate + +@item +This is a @samp{string} + +@item +This is a @kbd{keystroke} + +@item +This is a @file{file} + +@item +This is a @code{symbol} + +@end enumerate + +So if I were to say ``set @code{flargnoze} to @samp{yes}'', that would +mean: + +@lisp +(setq flargnoze "yes") +@end lisp + +If I say ``set @code{flumphel} to @code{yes}'', that would mean: + +@lisp +(setq flumphel 'yes) +@end lisp + +@samp{yes} and @code{yes} are two @emph{very} different things---don't +ever get them confused. + +@iflatex +@c @head +Of course, everything in this manual is of vital interest, so you should +read it all. Several times. However, if you feel like skimming the +manual, look for that gnu head you should see in the margin over +there---it means that what's being discussed is of more importance than +the rest of the stuff. (On the other hand, if everything is infinitely +important, how can anything be more important than that? Just one more +of the mysteries of this world, I guess.) +@end iflatex + +@end iftex + + +@node Terminology +@section Terminology + +@cindex terminology +@table @dfn + +@item news +@cindex news +This is what you are supposed to use this thing for---reading news. +News is generally fetched from a nearby @sc{nntp} server, and is +generally publicly available to everybody. If you post news, the entire +world is likely to read just what you have written, and they'll all +snigger mischievously. Behind your back. + +@item mail +@cindex mail +Everything that's delivered to you personally is mail. Some news/mail +readers (like Gnus) blur the distinction between mail and news, but +there is a difference. Mail is private. News is public. Mailing is +not posting, and replying is not following up. + +@item reply +@cindex reply +Send a mail to the person who has written what you are reading. + +@item follow up +@cindex follow up +Post an article to the current newsgroup responding to the article you +are reading. + +@item backend +@cindex backend +Gnus gets fed articles from a number of backends, both news and mail +backends. Gnus does not handle the underlying media, so to speak---this +is all done by the backends. + +@item native +@cindex native +Gnus will always use one method (and backend) as the @dfn{native}, or +default, way of getting news. + +@item foreign +@cindex foreign +You can also have any number of foreign groups active at the same time. +These are groups that use non-native non-secondary backends for getting +news. + +@item secondary +@cindex secondary +Secondary backends are somewhere half-way between being native and being +foreign, but they mostly act like they are native. + +@item article +@cindex article +A message that has been posted as news. + +@item mail message +@cindex mail message +A message that has been mailed. + +@item message +@cindex message +A mail message or news article + +@item head +@cindex head +The top part of a message, where administrative information (etc.) is +put. + +@item body +@cindex body +The rest of an article. Everything not in the head is in the +body. + +@item header +@cindex header +A line from the head of an article. + +@item headers +@cindex headers +A collection of such lines, or a collection of heads. Or even a +collection of @sc{nov} lines. + +@item @sc{nov} +@cindex nov +When Gnus enters a group, it asks the backend for the headers of all +unread articles in the group. Most servers support the News OverView +format, which is more compact and much faster to read and parse than the +normal @sc{head} format. + +@item level +@cindex levels +Each group is subscribed at some @dfn{level} or other (1-9). The ones +that have a lower level are ``more'' subscribed than the groups with a +higher level. In fact, groups on levels 1-5 are considered +@dfn{subscribed}; 6-7 are @dfn{unsubscribed}; 8 are @dfn{zombies}; and 9 +are @dfn{killed}. Commands for listing groups and scanning for new +articles will all use the numeric prefix as @dfn{working level}. + +@item killed groups +@cindex killed groups +No information on killed groups is stored or updated, which makes killed +groups much easier to handle than subscribed groups. + +@item zombie groups +@cindex zombie groups +Just like killed groups, only slightly less dead. + +@item active file +@cindex active file +The news server has to keep track of what articles it carries, and what +groups exist. All this information in stored in the active file, which +is rather large, as you might surmise. + +@item bogus groups +@cindex bogus groups +A group that exists in the @file{.newsrc} file, but isn't known to the +server (i.e., it isn't in the active file), is a @emph{bogus group}. +This means that the group probably doesn't exist (any more). + +@item server +@cindex server +A machine one can connect to and get news (or mail) from. + +@item select method +@cindex select method +A structure that specifies the backend, the server and the virtual +server settings. + +@item virtual server +@cindex virtual server +A named select method. Since a select method defines all there is to +know about connecting to a (physical) server, taking the thing as a +whole is a virtual server. + +@item washing +@cindex washing +Taking a buffer and running it through a filter of some sort. The +result will (more often than not) be cleaner and more pleasing than the +original. + +@item ephemeral groups +@cindex ephemeral groups +Most groups store data on what articles you have read. @dfn{Ephemeral} +groups are groups that will have no data stored---when you exit the +group, it'll disappear into the aether. + +@item solid groups +@cindex solid groups +This is the opposite of ephemeral groups. All groups listed in the +group buffer are solid groups. + +@item sparse articles +@cindex sparse articles +These are article placeholders shown in the summary buffer when +@code{gnus-build-sparse-threads} has been switched on. + +@item threading +@cindex threading +To put responses to articles directly after the articles they respond +to---in a hierarchical fashion. + +@item root +@cindex root +@cindex thread root +The first article in a thread is the root. It is the ancestor of all +articles in the thread. + +@item parent +@cindex parent +An article that has responses. + +@item child +@cindex child +An article that responds to a different article---its parent. + +@item digest +@cindex digest +A collection of messages in one file. The most common digest format is +specified by RFC1153. + +@end table + + +@node Customization +@section Customization +@cindex general customization + +All variables are properly documented elsewhere in this manual. This +section is designed to give general pointers on how to customize Gnus +for some quite common situations. + +@menu +* Slow/Expensive Connection:: You run a local Emacs and get the news elsewhere. +* Slow Terminal Connection:: You run a remote Emacs. +* Little Disk Space:: You feel that having large setup files is icky. +* Slow Machine:: You feel like buying a faster machine. +@end menu + + +@node Slow/Expensive Connection +@subsection Slow/Expensive @sc{nntp} Connection + +If you run Emacs on a machine locally, and get your news from a machine +over some very thin strings, you want to cut down on the amount of data +Gnus has to get from the @sc{nntp} server. + +@table @code + +@item gnus-read-active-file +Set this to @code{nil}, which will inhibit Gnus from requesting the +entire active file from the server. This file is often v. large. You +also have to set @code{gnus-check-new-newsgroups} and +@code{gnus-check-bogus-newsgroups} to @code{nil} to make sure that Gnus +doesn't suddenly decide to fetch the active file anyway. + +@item gnus-nov-is-evil +This one has to be @code{nil}. If not, grabbing article headers from +the @sc{nntp} server will not be very fast. Not all @sc{nntp} servers +support @sc{xover}; Gnus will detect this by itself. +@end table + + +@node Slow Terminal Connection +@subsection Slow Terminal Connection + +Let's say you use your home computer for dialing up the system that runs +Emacs and Gnus. If your modem is slow, you want to reduce (as much as +possible) the amount of data sent over the wires. + +@table @code + +@item gnus-auto-center-summary +Set this to @code{nil} to inhibit Gnus from re-centering the summary +buffer all the time. If it is @code{vertical}, do only vertical +re-centering. If it is neither @code{nil} nor @code{vertical}, do both +horizontal and vertical recentering. + +@item gnus-visible-headers +Cut down on the headers included in the articles to the +minimum. You can, in fact, make do without them altogether---most of the +useful data is in the summary buffer, anyway. Set this variable to +@samp{^NEVVVVER} or @samp{From:}, or whatever you feel you need. + +@item gnus-article-display-hook +Set this hook to all the available hiding commands: +@lisp +(setq gnus-article-display-hook + '(gnus-article-hide-headers gnus-article-hide-signature + gnus-article-hide-citation)) +@end lisp + +@item gnus-use-full-window +By setting this to @code{nil}, you can make all the windows smaller. +While this doesn't really cut down much generally, it means that you +have to see smaller portions of articles before deciding that you didn't +want to read them anyway. + +@item gnus-thread-hide-subtree +If this is non-@code{nil}, all threads in the summary buffer will be +hidden initially. + +@item gnus-updated-mode-lines +If this is @code{nil}, Gnus will not put information in the buffer mode +lines, which might save some time. +@end table + + +@node Little Disk Space +@subsection Little Disk Space +@cindex disk space + +The startup files can get rather large, so you may want to cut their +sizes a bit if you are running out of space. + +@table @code + +@item gnus-save-newsrc-file +If this is @code{nil}, Gnus will never save @file{.newsrc}---it will +only save @file{.newsrc.eld}. This means that you will not be able to +use any other newsreaders than Gnus. This variable is @code{t} by +default. + +@item gnus-save-killed-list +If this is @code{nil}, Gnus will not save the list of dead groups. You +should also set @code{gnus-check-new-newsgroups} to @code{ask-server} +and @code{gnus-check-bogus-newsgroups} to @code{nil} if you set this +variable to @code{nil}. This variable is @code{t} by default. + +@end table + + +@node Slow Machine +@subsection Slow Machine +@cindex slow machine + +If you have a slow machine, or are just really impatient, there are a +few things you can do to make Gnus run faster. + +Set @code{gnus-check-new-newsgroups} and +@code{gnus-check-bogus-newsgroups} to @code{nil} to make startup faster. + +Set @code{gnus-show-threads}, @code{gnus-use-cross-reference} and +@code{gnus-nov-is-evil} to @code{nil} to make entering and exiting the +summary buffer faster. + +Set @code{gnus-article-display-hook} to @code{nil} to make article +processing a bit faster. + + +@node Troubleshooting +@section Troubleshooting +@cindex troubleshooting + +Gnus works @emph{so} well straight out of the box---I can't imagine any +problems, really. + +Ahem. + +@enumerate + +@item +Make sure your computer is switched on. + +@item +Make sure that you really load the current Gnus version. If you have +been running @sc{gnus}, you need to exit Emacs and start it up again before +Gnus will work. + +@item +Try doing an @kbd{M-x gnus-version}. If you get something that looks +like @samp{Gnus v5.46; nntp 4.0} you have the right files loaded. If, +on the other hand, you get something like @samp{NNTP 3.x} or @samp{nntp +flee}, you have some old @file{.el} files lying around. Delete these. + +@item +Read the help group (@kbd{G h} in the group buffer) for a FAQ and a +how-to. + +@item +@vindex max-lisp-eval-depth +Gnus works on many recursive structures, and in some extreme (and very +rare) cases Gnus may recurse down ``too deeply'' and Emacs will beep at +you. If this happens to you, set @code{max-lisp-eval-depth} to 500 or +something like that. +@end enumerate + +If all else fails, report the problem as a bug. + +@cindex bugs +@cindex reporting bugs + +@kindex M-x gnus-bug +@findex gnus-bug +If you find a bug in Gnus, you can report it with the @kbd{M-x gnus-bug} +command. @kbd{M-x set-variable RET debug-on-error RET t RET}, and send +me the backtrace. I will fix bugs, but I can only fix them if you send +me a precise description as to how to reproduce the bug. + +You really can never be too detailed in a bug report. Always use the +@kbd{M-x gnus-bug} command when you make bug reports, even if it creates +a 10Kb mail each time you use it, and even if you have sent me your +environment 500 times before. I don't care. I want the full info each +time. + +It is also important to remember that I have no memory whatsoever. If +you send a bug report, and I send you a reply, and then you just send +back ``No, it's not! Moron!'', I will have no idea what you are +insulting me about. Always over-explain everything. It's much easier +for all of us---if I don't have all the information I need, I will just +mail you and ask for more info, and everything takes more time. + +If the problem you're seeing is very visual, and you can't quite explain +it, copy the Emacs window to a file (with @code{xwd}, for instance), put +it somewhere it can be reached, and include the URL of the picture in +the bug report. + +If you just need help, you are better off asking on +@samp{gnu.emacs.gnus}. I'm not very helpful. + +@cindex gnu.emacs.gnus +@cindex ding mailing list +You can also ask on the ding mailing list---@samp{ding@@gnus.org}. +Write to @samp{ding-request@@gnus.org} to subscribe. + + +@node A Programmers Guide to Gnus +@section A Programmer@'s Guide to Gnus + +It is my hope that other people will figure out smart stuff that Gnus +can do, and that other people will write those smart things as well. To +facilitate that I thought it would be a good idea to describe the inner +workings of Gnus. And some of the not-so-inner workings, while I'm at +it. + +You can never expect the internals of a program not to change, but I +will be defining (in some details) the interface between Gnus and its +backends (this is written in stone), the format of the score files +(ditto), data structures (some are less likely to change than others) +and general methods of operation. + +@menu +* Gnus Utility Functions:: Common functions and variable to use. +* Backend Interface:: How Gnus communicates with the servers. +* Score File Syntax:: A BNF definition of the score file standard. +* Headers:: How Gnus stores headers internally. +* Ranges:: A handy format for storing mucho numbers. +* Group Info:: The group info format. +* Extended Interactive:: Symbolic prefixes and stuff. +* Emacs/XEmacs Code:: Gnus can be run under all modern Emacsen. +* Various File Formats:: Formats of files that Gnus use. +@end menu + + +@node Gnus Utility Functions +@subsection Gnus Utility Functions +@cindex Gnus utility functions +@cindex utility functions +@cindex functions +@cindex internal variables + +When writing small functions to be run from hooks (and stuff), it's +vital to have access to the Gnus internal functions and variables. +Below is a list of the most common ones. + +@table @code + +@item gnus-newsgroup-name +@vindex gnus-newsgroup-name +This variable holds the name of the current newsgroup. + +@item gnus-find-method-for-group +@findex gnus-find-method-for-group +A function that returns the select method for @var{group}. + +@item gnus-group-real-name +@findex gnus-group-real-name +Takes a full (prefixed) Gnus group name, and returns the unprefixed +name. + +@item gnus-group-prefixed-name +@findex gnus-group-prefixed-name +Takes an unprefixed group name and a select method, and returns the full +(prefixed) Gnus group name. + +@item gnus-get-info +@findex gnus-get-info +Returns the group info list for @var{group}. + +@item gnus-add-current-to-buffer-list +@findex gnus-add-current-to-buffer-list +Adds the current buffer to the list of buffers to be killed on Gnus +exit. + +@item gnus-continuum-version +@findex gnus-continuum-version +Takes a Gnus version string as a parameter and returns a floating point +number. Earlier versions will always get a lower number than later +versions. + +@item gnus-group-read-only-p +@findex gnus-group-read-only-p +Says whether @var{group} is read-only or not. + +@item gnus-news-group-p +@findex gnus-news-group-p +Says whether @var{group} came from a news backend. + +@item gnus-ephemeral-group-p +@findex gnus-ephemeral-group-p +Says whether @var{group} is ephemeral or not. + +@item gnus-server-to-method +@findex gnus-server-to-method +Returns the select method corresponding to @var{server}. + +@item gnus-server-equal +@findex gnus-server-equal +Says whether two virtual servers are equal. + +@item gnus-group-native-p +@findex gnus-group-native-p +Says whether @var{group} is native or not. + +@item gnus-group-secondary-p +@findex gnus-group-secondary-p +Says whether @var{group} is secondary or not. + +@item gnus-group-foreign-p +@findex gnus-group-foreign-p +Says whether @var{group} is foreign or not. + +@item group-group-find-parameter +@findex group-group-find-parameter +Returns the parameter list of @var{group}. If given a second parameter, +returns the value of that parameter for @var{group}. + +@item gnus-group-set-parameter +@findex gnus-group-set-parameter +Takes three parameters; @var{group}, @var{parameter} and @var{value}. + +@item gnus-narrow-to-body +@findex gnus-narrow-to-body +Narrows the current buffer to the body of the article. + +@item gnus-check-backend-function +@findex gnus-check-backend-function +Takes two parameters, @var{function} and @var{group}. If the backend +@var{group} comes from supports @var{function}, return non-@code{nil}. + +@lisp +(gnus-check-backend-function "request-scan" "nnml:misc") +=> t +@end lisp + +@item gnus-read-method +@findex gnus-read-method +Prompts the user for a select method. + +@end table + + +@node Backend Interface +@subsection Backend Interface + +Gnus doesn't know anything about @sc{nntp}, spools, mail or virtual +groups. It only knows how to talk to @dfn{virtual servers}. A virtual +server is a @dfn{backend} and some @dfn{backend variables}. As examples +of the first, we have @code{nntp}, @code{nnspool} and @code{nnmbox}. As +examples of the latter we have @code{nntp-port-number} and +@code{nnmbox-directory}. + +When Gnus asks for information from a backend---say @code{nntp}---on +something, it will normally include a virtual server name in the +function parameters. (If not, the backend should use the ``current'' +virtual server.) For instance, @code{nntp-request-list} takes a virtual +server as its only (optional) parameter. If this virtual server hasn't +been opened, the function should fail. + +Note that a virtual server name has no relation to some physical server +name. Take this example: + +@lisp +(nntp "odd-one" + (nntp-address "ifi.uio.no") + (nntp-port-number 4324)) +@end lisp + +Here the virtual server name is @samp{odd-one} while the name of +the physical server is @samp{ifi.uio.no}. + +The backends should be able to switch between several virtual servers. +The standard backends implement this by keeping an alist of virtual +server environments that they pull down/push up when needed. + +There are two groups of interface functions: @dfn{required functions}, +which must be present, and @dfn{optional functions}, which Gnus will +always check for presence before attempting to call 'em. + +All these functions are expected to return data in the buffer +@code{nntp-server-buffer} (@samp{ *nntpd*}), which is somewhat +unfortunately named, but we'll have to live with it. When I talk about +@dfn{resulting data}, I always refer to the data in that buffer. When I +talk about @dfn{return value}, I talk about the function value returned by +the function call. Functions that fail should return @code{nil} as the +return value. + +Some backends could be said to be @dfn{server-forming} backends, and +some might be said not to be. The latter are backends that generally +only operate on one group at a time, and have no concept of ``server'' +-- they have a group, and they deliver info on that group and nothing +more. + +In the examples and definitions I will refer to the imaginary backend +@code{nnchoke}. + +@cindex @code{nnchoke} + +@menu +* Required Backend Functions:: Functions that must be implemented. +* Optional Backend Functions:: Functions that need not be implemented. +* Error Messaging:: How to get messages and report errors. +* Writing New Backends:: Extending old backends. +* Hooking New Backends Into Gnus:: What has to be done on the Gnus end. +* Mail-like Backends:: Some tips on mail backends. +@end menu + + +@node Required Backend Functions +@subsubsection Required Backend Functions + +@table @code + +@item (nnchoke-retrieve-headers ARTICLES &optional GROUP SERVER FETCH-OLD) + +@var{articles} is either a range of article numbers or a list of +@code{Message-ID}s. Current backends do not fully support either---only +sequences (lists) of article numbers, and most backends do not support +retrieval of @code{Message-ID}s. But they should try for both. + +The result data should either be HEADs or NOV lines, and the result +value should either be @code{headers} or @code{nov} to reflect this. +This might later be expanded to @code{various}, which will be a mixture +of HEADs and NOV lines, but this is currently not supported by Gnus. + +If @var{fetch-old} is non-@code{nil} it says to try fetching "extra +headers", in some meaning of the word. This is generally done by +fetching (at most) @var{fetch-old} extra headers less than the smallest +article number in @code{articles}, and filling the gaps as well. The +presence of this parameter can be ignored if the backend finds it +cumbersome to follow the request. If this is non-@code{nil} and not a +number, do maximum fetches. + +Here's an example HEAD: + +@example +221 1056 Article retrieved. +Path: ifi.uio.no!sturles +From: sturles@@ifi.uio.no (Sturle Sunde) +Newsgroups: ifi.discussion +Subject: Re: Something very droll +Date: 27 Oct 1994 14:02:57 +0100 +Organization: Dept. of Informatics, University of Oslo, Norway +Lines: 26 +Message-ID: <38o8e1$a0o@@holmenkollen.ifi.uio.no> +References: <38jdmq$4qu@@visbur.ifi.uio.no> +NNTP-Posting-Host: holmenkollen.ifi.uio.no +. +@end example + +So a @code{headers} return value would imply that there's a number of +these in the data buffer. + +Here's a BNF definition of such a buffer: + +@example +headers = *head +head = error / valid-head +error-message = [ "4" / "5" ] 2number " " eol +valid-head = valid-message *header "." eol +valid-message = "221 " " Article retrieved." eol +header = eol +@end example + +If the return value is @code{nov}, the data buffer should contain +@dfn{network overview database} lines. These are basically fields +separated by tabs. + +@example +nov-buffer = *nov-line +nov-line = 8*9 [ field ] eol +field = +@end example + +For a closer look at what should be in those fields, +@pxref{Headers}. + + +@item (nnchoke-open-server SERVER &optional DEFINITIONS) + +@var{server} is here the virtual server name. @var{definitions} is a +list of @code{(VARIABLE VALUE)} pairs that define this virtual server. + +If the server can't be opened, no error should be signaled. The backend +may then choose to refuse further attempts at connecting to this +server. In fact, it should do so. + +If the server is opened already, this function should return a +non-@code{nil} value. There should be no data returned. + + +@item (nnchoke-close-server &optional SERVER) + +Close connection to @var{server} and free all resources connected +to it. Return @code{nil} if the server couldn't be closed for some +reason. + +There should be no data returned. + + +@item (nnchoke-request-close) + +Close connection to all servers and free all resources that the backend +have reserved. All buffers that have been created by that backend +should be killed. (Not the @code{nntp-server-buffer}, though.) This +function is generally only called when Gnus is shutting down. + +There should be no data returned. + + +@item (nnchoke-server-opened &optional SERVER) + +If @var{server} is the current virtual server, and the connection to the +physical server is alive, then this function should return a +non-@code{nil} vlue. This function should under no circumstances +attempt to reconnect to a server we have lost connection to. + +There should be no data returned. + + +@item (nnchoke-status-message &optional SERVER) + +This function should return the last error message from @var{server}. + +There should be no data returned. + + +@item (nnchoke-request-article ARTICLE &optional GROUP SERVER TO-BUFFER) + +The result data from this function should be the article specified by +@var{article}. This might either be a @code{Message-ID} or a number. +It is optional whether to implement retrieval by @code{Message-ID}, but +it would be nice if that were possible. + +If @var{to-buffer} is non-@code{nil}, the result data should be returned +in this buffer instead of the normal data buffer. This is to make it +possible to avoid copying large amounts of data from one buffer to +another, while Gnus mainly requests articles to be inserted directly +into its article buffer. + +If it is at all possible, this function should return a cons cell where +the @code{car} is the group name the article was fetched from, and the @code{cdr} is +the article number. This will enable Gnus to find out what the real +group and article numbers are when fetching articles by +@code{Message-ID}. If this isn't possible, @code{t} should be returned +on successful article retrieval. + + +@item (nnchoke-request-group GROUP &optional SERVER FAST) + +Get data on @var{group}. This function also has the side effect of +making @var{group} the current group. + +If @var{FAST}, don't bother to return useful data, just make @var{group} +the current group. + +Here's an example of some result data and a definition of the same: + +@example +211 56 1000 1059 ifi.discussion +@end example + +The first number is the status, which should be 211. Next is the +total number of articles in the group, the lowest article number, the +highest article number, and finally the group name. Note that the total +number of articles may be less than one might think while just +considering the highest and lowest article numbers, but some articles +may have been canceled. Gnus just discards the total-number, so +whether one should take the bother to generate it properly (if that is a +problem) is left as an exercise to the reader. + +@example +group-status = [ error / info ] eol +error = [ "4" / "5" ] 2 " " +info = "211 " 3* [ " " ] +@end example + + +@item (nnchoke-close-group GROUP &optional SERVER) + +Close @var{group} and free any resources connected to it. This will be +a no-op on most backends. + +There should be no data returned. + + +@item (nnchoke-request-list &optional SERVER) + +Return a list of all groups available on @var{server}. And that means +@emph{all}. + +Here's an example from a server that only carries two groups: + +@example +ifi.test 0000002200 0000002000 y +ifi.discussion 3324 3300 n +@end example + +On each line we have a group name, then the highest article number in +that group, the lowest article number, and finally a flag. + +@example +active-file = *active-line +active-line = name " " " " " " flags eol +name = +flags = "n" / "y" / "m" / "x" / "j" / "=" name +@end example + +The flag says whether the group is read-only (@samp{n}), is moderated +(@samp{m}), is dead (@samp{x}), is aliased to some other group +(@samp{=other-group}) or none of the above (@samp{y}). + + +@item (nnchoke-request-post &optional SERVER) + +This function should post the current buffer. It might return whether +the posting was successful or not, but that's not required. If, for +instance, the posting is done asynchronously, it has generally not been +completed by the time this function concludes. In that case, this +function should set up some kind of sentinel to beep the user loud and +clear if the posting could not be completed. + +There should be no result data from this function. + +@end table + + +@node Optional Backend Functions +@subsubsection Optional Backend Functions + +@table @code + +@item (nnchoke-retrieve-groups GROUPS &optional SERVER) + +@var{groups} is a list of groups, and this function should request data +on all those groups. How it does it is of no concern to Gnus, but it +should attempt to do this in a speedy fashion. + +The return value of this function can be either @code{active} or +@code{group}, which says what the format of the result data is. The +former is in the same format as the data from +@code{nnchoke-request-list}, while the latter is a buffer full of lines +in the same format as @code{nnchoke-request-group} gives. + +@example +group-buffer = *active-line / *group-status +@end example + + +@item (nnchoke-request-update-info GROUP INFO &optional SERVER) + +A Gnus group info (@pxref{Group Info}) is handed to the backend for +alterations. This comes in handy if the backend really carries all the +information (as is the case with virtual and imap groups). This +function should destructively alter the info to suit its needs, and +should return the (altered) group info. + +There should be no result data from this function. + + +@item (nnchoke-request-type GROUP &optional ARTICLE) + +When the user issues commands for ``sending news'' (@kbd{F} in the +summary buffer, for instance), Gnus has to know whether the article the +user is following up on is news or mail. This function should return +@code{news} if @var{article} in @var{group} is news, @code{mail} if it +is mail and @code{unknown} if the type can't be decided. (The +@var{article} parameter is necessary in @code{nnvirtual} groups which +might very well combine mail groups and news groups.) Both @var{group} +and @var{article} may be @code{nil}. + +There should be no result data from this function. + + +@item (nnchoke-request-update-mark GROUP ARTICLE MARK) + +If the user tries to set a mark that the backend doesn't like, this +function may change the mark. Gnus will use whatever this function +returns as the mark for @var{article} instead of the original +@var{mark}. If the backend doesn't care, it must return the original +@var{mark}, and not @code{nil} or any other type of garbage. + +The only use for this I can see is what @code{nnvirtual} does with +it---if a component group is auto-expirable, marking an article as read +in the virtual group should result in the article being marked as +expirable. + +There should be no result data from this function. + + +@item (nnchoke-request-scan &optional GROUP SERVER) + +This function may be called at any time (by Gnus or anything else) to +request that the backend check for incoming articles, in one way or +another. A mail backend will typically read the spool file or query the +POP server when this function is invoked. The @var{group} doesn't have +to be heeded---if the backend decides that it is too much work just +scanning for a single group, it may do a total scan of all groups. It +would be nice, however, to keep things local if that's practical. + +There should be no result data from this function. + + +@item (nnchoke-request-group-description GROUP &optional SERVER) + +The result data from this function should be a description of +@var{group}. + +@example +description-line = name description eol +name = +description = +@end example + +@item (nnchoke-request-list-newsgroups &optional SERVER) + +The result data from this function should be the description of all +groups available on the server. + +@example +description-buffer = *description-line +@end example + + +@item (nnchoke-request-newgroups DATE &optional SERVER) + +The result data from this function should be all groups that were +created after @samp{date}, which is in normal human-readable date +format. The data should be in the active buffer format. + + +@item (nnchoke-request-create-group GROUP &optional SERVER) + +This function should create an empty group with name @var{group}. + +There should be no return data. + + +@item (nnchoke-request-expire-articles ARTICLES &optional GROUP SERVER FORCE) + +This function should run the expiry process on all articles in the +@var{articles} range (which is currently a simple list of article +numbers.) It is left up to the backend to decide how old articles +should be before they are removed by this function. If @var{force} is +non-@code{nil}, all @var{articles} should be deleted, no matter how new +they are. + +This function should return a list of articles that it did not/was not +able to delete. + +There should be no result data returned. + + +@item (nnchoke-request-move-article ARTICLE GROUP SERVER ACCEPT-FORM +&optional LAST) + +This function should move @var{article} (which is a number) from +@var{group} by calling @var{accept-form}. + +This function should ready the article in question for moving by +removing any header lines it has added to the article, and generally +should ``tidy up'' the article. Then it should @code{eval} +@var{accept-form} in the buffer where the ``tidy'' article is. This +will do the actual copying. If this @code{eval} returns a +non-@code{nil} value, the article should be removed. + +If @var{last} is @code{nil}, that means that there is a high likelihood +that there will be more requests issued shortly, so that allows some +optimizations. + +The function should return a cons where the @code{car} is the group name and +the @code{cdr} is the article number that the article was entered as. + +There should be no data returned. + + +@item (nnchoke-request-accept-article GROUP &optional SERVER LAST) + +This function takes the current buffer and inserts it into @var{group}. +If @var{last} in @code{nil}, that means that there will be more calls to +this function in short order. + +The function should return a cons where the @code{car} is the group name and +the @code{cdr} is the article number that the article was entered as. + +There should be no data returned. + + +@item (nnchoke-request-replace-article ARTICLE GROUP BUFFER) + +This function should remove @var{article} (which is a number) from +@var{group} and insert @var{buffer} there instead. + +There should be no data returned. + + +@item (nnchoke-request-delete-group GROUP FORCE &optional SERVER) + +This function should delete @var{group}. If @var{force}, it should +really delete all the articles in the group, and then delete the group +itself. (If there is such a thing as ``the group itself''.) + +There should be no data returned. + + +@item (nnchoke-request-rename-group GROUP NEW-NAME &optional SERVER) + +This function should rename @var{group} into @var{new-name}. All +articles in @var{group} should move to @var{new-name}. + +There should be no data returned. + +@end table + + +@node Error Messaging +@subsubsection Error Messaging + +@findex nnheader-report +@findex nnheader-get-report +The backends should use the function @code{nnheader-report} to report +error conditions---they should not raise errors when they aren't able to +perform a request. The first argument to this function is the backend +symbol, and the rest are interpreted as arguments to @code{format} if +there are multiple of them, or just a string if there is one of them. +This function must always returns @code{nil}. + +@lisp +(nnheader-report 'nnchoke "You did something totally bogus") + +(nnheader-report 'nnchoke "Could not request group %s" group) +@end lisp + +Gnus, in turn, will call @code{nnheader-get-report} when it gets a +@code{nil} back from a server, and this function returns the most +recently reported message for the backend in question. This function +takes one argument---the server symbol. + +Internally, these functions access @var{backend}@code{-status-string}, +so the @code{nnchoke} backend will have its error message stored in +@code{nnchoke-status-string}. + + +@node Writing New Backends +@subsubsection Writing New Backends + +Many backends are quite similar. @code{nnml} is just like +@code{nnspool}, but it allows you to edit the articles on the server. +@code{nnmh} is just like @code{nnml}, but it doesn't use an active file, +and it doesn't maintain overview databases. @code{nndir} is just like +@code{nnml}, but it has no concept of ``groups'', and it doesn't allow +editing articles. + +It would make sense if it were possible to ``inherit'' functions from +backends when writing new backends. And, indeed, you can do that if you +want to. (You don't have to if you don't want to, of course.) + +All the backends declare their public variables and functions by using a +package called @code{nnoo}. + +To inherit functions from other backends (and allow other backends to +inherit functions from the current backend), you should use the +following macros: + +@table @code + +@item nnoo-declare +This macro declares the first parameter to be a child of the subsequent +parameters. For instance: + +@lisp +(nnoo-declare nndir + nnml nnmh) +@end lisp + +@code{nndir} has declared here that it intends to inherit functions from +both @code{nnml} and @code{nnmh}. + +@item defvoo +This macro is equivalent to @code{defvar}, but registers the variable as +a public server variable. Most state-oriented variables should be +declared with @code{defvoo} instead of @code{defvar}. + +In addition to the normal @code{defvar} parameters, it takes a list of +variables in the parent backends to map the variable to when executing +a function in those backends. + +@lisp +(defvoo nndir-directory nil + "Where nndir will look for groups." + nnml-current-directory nnmh-current-directory) +@end lisp + +This means that @code{nnml-current-directory} will be set to +@code{nndir-directory} when an @code{nnml} function is called on behalf +of @code{nndir}. (The same with @code{nnmh}.) + +@item nnoo-define-basics +This macro defines some common functions that almost all backends should +have. + +@example +(nnoo-define-basics nndir) +@end example + +@item deffoo +This macro is just like @code{defun} and takes the same parameters. In +addition to doing the normal @code{defun} things, it registers the +function as being public so that other backends can inherit it. + +@item nnoo-map-functions +This macro allows mapping of functions from the current backend to +functions from the parent backends. + +@example +(nnoo-map-functions nndir + (nnml-retrieve-headers 0 nndir-current-group 0 0) + (nnmh-request-article 0 nndir-current-group 0 0)) +@end example + +This means that when @code{nndir-retrieve-headers} is called, the first, +third, and fourth parameters will be passed on to +@code{nnml-retrieve-headers}, while the second parameter is set to the +value of @code{nndir-current-group}. + +@item nnoo-import +This macro allows importing functions from backends. It should be the +last thing in the source file, since it will only define functions that +haven't already been defined. + +@example +(nnoo-import nndir + (nnmh + nnmh-request-list + nnmh-request-newgroups) + (nnml)) +@end example + +This means that calls to @code{nndir-request-list} should just be passed +on to @code{nnmh-request-list}, while all public functions from +@code{nnml} that haven't been defined in @code{nndir} yet should be +defined now. + +@end table + +Below is a slightly shortened version of the @code{nndir} backend. + +@lisp +;;; nndir.el --- single directory newsgroup access for Gnus +;; Copyright (C) 1995,96 Free Software Foundation, Inc. + +;;; Code: + +(require 'nnheader) +(require 'nnmh) +(require 'nnml) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nndir + nnml nnmh) + +(defvoo nndir-directory nil + "Where nndir will look for groups." + nnml-current-directory nnmh-current-directory) + +(defvoo nndir-nov-is-evil nil + "*Non-nil means that nndir will never retrieve NOV headers." + nnml-nov-is-evil) + +(defvoo nndir-current-group "" nil nnml-current-group nnmh-current-group) +(defvoo nndir-top-directory nil nil nnml-directory nnmh-directory) +(defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail) + +(defvoo nndir-status-string "" nil nnmh-status-string) +(defconst nndir-version "nndir 1.0") + +;;; Interface functions. + +(nnoo-define-basics nndir) + +(deffoo nndir-open-server (server &optional defs) + (setq nndir-directory + (or (cadr (assq 'nndir-directory defs)) + server)) + (unless (assq 'nndir-directory defs) + (push `(nndir-directory ,server) defs)) + (push `(nndir-current-group + ,(file-name-nondirectory (directory-file-name nndir-directory))) + defs) + (push `(nndir-top-directory + ,(file-name-directory (directory-file-name nndir-directory))) + defs) + (nnoo-change-server 'nndir server defs)) + +(nnoo-map-functions nndir + (nnml-retrieve-headers 0 nndir-current-group 0 0) + (nnmh-request-article 0 nndir-current-group 0 0) + (nnmh-request-group nndir-current-group 0 0) + (nnmh-close-group nndir-current-group 0)) + +(nnoo-import nndir + (nnmh + nnmh-status-message + nnmh-request-list + nnmh-request-newgroups)) + +(provide 'nndir) +@end lisp + + +@node Hooking New Backends Into Gnus +@subsubsection Hooking New Backends Into Gnus + +@vindex gnus-valid-select-methods +Having Gnus start using your new backend is rather easy---you just +declare it with the @code{gnus-declare-backend} functions. This will +enter the backend into the @code{gnus-valid-select-methods} variable. + +@code{gnus-declare-backend} takes two parameters---the backend name and +an arbitrary number of @dfn{abilities}. + +Here's an example: + +@lisp +(gnus-declare-backend "nnchoke" 'mail 'respool 'address) +@end lisp + +The abilities can be: + +@table @code +@item mail +This is a mailish backend---followups should (probably) go via mail. +@item post +This is a newsish backend---followups should (probably) go via news. +@item post-mail +This backend supports both mail and news. +@item none +This is neither a post nor mail backend---it's something completely +different. +@item respool +It supports respooling---or rather, it is able to modify its source +articles and groups. +@item address +The name of the server should be in the virtual server name. This is +true for almost all backends. +@item prompt-address +The user should be prompted for an address when doing commands like +@kbd{B} in the group buffer. This is true for backends like +@code{nntp}, but not @code{nnmbox}, for instance. +@end table + + +@node Mail-like Backends +@subsubsection Mail-like Backends + +One of the things that separate the mail backends from the rest of the +backends is the heavy dependence by the mail backends on common +functions in @file{nnmail.el}. For instance, here's the definition of +@code{nnml-request-scan}: + +@lisp +(deffoo nnml-request-scan (&optional group server) + (setq nnml-article-file-alist nil) + (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) +@end lisp + +It simply calls @code{nnmail-get-new-mail} with a few parameters, +and @code{nnmail} takes care of all the moving and splitting of the +mail. + +This function takes four parameters. + +@table @var +@item method +This should be a symbol to designate which backend is responsible for +the call. + +@item exit-function +This function should be called after the splitting has been performed. + +@item temp-directory +Where the temporary files should be stored. + +@item group +This optional argument should be a group name if the splitting is to be +performed for one group only. +@end table + +@code{nnmail-get-new-mail} will call @var{backend}@code{-save-mail} to +save each article. @var{backend}@code{-active-number} will be called to +find the article number assigned to this article. + +The function also uses the following variables: +@var{backend}@code{-get-new-mail} (to see whether to get new mail for +this backend); and @var{backend}@code{-group-alist} and +@var{backend}@code{-active-file} to generate the new active file. +@var{backend}@code{-group-alist} should be a group-active alist, like +this: + +@example +(("a-group" (1 . 10)) + ("some-group" (34 . 39))) +@end example + + +@node Score File Syntax +@subsection Score File Syntax + +Score files are meant to be easily parsable, but yet extremely +mallable. It was decided that something that had the same read syntax +as an Emacs Lisp list would fit that spec. + +Here's a typical score file: + +@lisp +(("summary" + ("win95" -10000 nil s) + ("Gnus")) + ("from" + ("Lars" -1000)) + (mark -100)) +@end lisp + +BNF definition of a score file: + +@example +score-file = "" / "(" *element ")" +element = rule / atom +rule = string-rule / number-rule / date-rule +string-rule = "(" quote string-header quote space *string-match ")" +number-rule = "(" quote number-header quote space *number-match ")" +date-rule = "(" quote date-header quote space *date-match ")" +quote = +string-header = "subject" / "from" / "references" / "message-id" / + "xref" / "body" / "head" / "all" / "followup" +number-header = "lines" / "chars" +date-header = "date" +string-match = "(" quote quote [ "" / [ space score [ "" / + space date [ "" / [ space string-match-t ] ] ] ] ] ")" +score = "nil" / +date = "nil" / +string-match-t = "nil" / "s" / "substring" / "S" / "Substring" / + "r" / "regex" / "R" / "Regex" / + "e" / "exact" / "E" / "Exact" / + "f" / "fuzzy" / "F" / "Fuzzy" +number-match = "(" [ "" / [ space score [ "" / + space date [ "" / [ space number-match-t ] ] ] ] ] ")" +number-match-t = "nil" / "=" / "<" / ">" / ">=" / "<=" +date-match = "(" quote quote [ "" / [ space score [ "" / + space date [ "" / [ space date-match-t ] ] ] ] ")" +date-match-t = "nil" / "at" / "before" / "after" +atom = "(" [ required-atom / optional-atom ] ")" +required-atom = mark / expunge / mark-and-expunge / files / + exclude-files / read-only / touched +optional-atom = adapt / local / eval +mark = "mark" space nil-or-number +nil-or-number = "nil" / +expunge = "expunge" space nil-or-number +mark-and-expunge = "mark-and-expunge" space nil-or-number +files = "files" *[ space ] +exclude-files = "exclude-files" *[ space ] +read-only = "read-only" [ space "nil" / space "t" ] +adapt = "adapt" [ space "ignore" / space "t" / space adapt-rule ] +adapt-rule = "(" *[ *[ "(" ")" ] ")" +local = "local" *[ space "(" space

")" ] +eval = "eval" space +space = *[ " " / / ] +@end example + +Any unrecognized elements in a score file should be ignored, but not +discarded. + +As you can see, white space is needed, but the type and amount of white +space is irrelevant. This means that formatting of the score file is +left up to the programmer---if it's simpler to just spew it all out on +one looong line, then that's ok. + +The meaning of the various atoms are explained elsewhere in this +manual (@pxref{Score File Format}). + + +@node Headers +@subsection Headers + +Internally Gnus uses a format for storing article headers that +corresponds to the @sc{nov} format in a mysterious fashion. One could +almost suspect that the author looked at the @sc{nov} specification and +just shamelessly @emph{stole} the entire thing, and one would be right. + +@dfn{Header} is a severely overloaded term. ``Header'' is used in +RFC1036 to talk about lines in the head of an article (e.g., +@code{From}). It is used by many people as a synonym for +``head''---``the header and the body''. (That should be avoided, in my +opinion.) And Gnus uses a format internally that it calls ``header'', +which is what I'm talking about here. This is a 9-element vector, +basically, with each header (ouch) having one slot. + +These slots are, in order: @code{number}, @code{subject}, @code{from}, +@code{date}, @code{id}, @code{references}, @code{chars}, @code{lines}, +@code{xref}. There are macros for accessing and setting these +slots---they all have predictable names beginning with +@code{mail-header-} and @code{mail-header-set-}, respectively. + +The @code{xref} slot is really a @code{misc} slot. Any extra info will +be put in there. + + +@node Ranges +@subsection Ranges + +@sc{gnus} introduced a concept that I found so useful that I've started +using it a lot and have elaborated on it greatly. + +The question is simple: If you have a large amount of objects that are +identified by numbers (say, articles, to take a @emph{wild} example) +that you want to qualify as being ``included'', a normal sequence isn't +very useful. (A 200,000 length sequence is a bit long-winded.) + +The solution is as simple as the question: You just collapse the +sequence. + +@example +(1 2 3 4 5 6 10 11 12) +@end example + +is transformed into + +@example +((1 . 6) (10 . 12)) +@end example + +To avoid having those nasty @samp{(13 . 13)} elements to denote a +lonesome object, a @samp{13} is a valid element: + +@example +((1 . 6) 7 (10 . 12)) +@end example + +This means that comparing two ranges to find out whether they are equal +is slightly tricky: + +@example +((1 . 5) 7 8 (10 . 12)) +@end example + +and + +@example +((1 . 5) (7 . 8) (10 . 12)) +@end example + +are equal. In fact, any non-descending list is a range: + +@example +(1 2 3 4 5) +@end example + +is a perfectly valid range, although a pretty long-winded one. This is +also valid: + +@example +(1 . 5) +@end example + +and is equal to the previous range. + +Here's a BNF definition of ranges. Of course, one must remember the +semantic requirement that the numbers are non-descending. (Any number +of repetition of the same number is allowed, but apt to disappear in +range handling.) + +@example +range = simple-range / normal-range +simple-range = "(" number " . " number ")" +normal-range = "(" start-contents ")" +contents = "" / simple-range *[ " " contents ] / + number *[ " " contents ] +@end example + +Gnus currently uses ranges to keep track of read articles and article +marks. I plan on implementing a number of range operators in C if The +Powers That Be are willing to let me. (I haven't asked yet, because I +need to do some more thinking on what operators I need to make life +totally range-based without ever having to convert back to normal +sequences.) + + +@node Group Info +@subsection Group Info + +Gnus stores all permanent info on groups in a @dfn{group info} list. +This list is from three to six elements (or more) long and exhaustively +describes the group. + +Here are two example group infos; one is a very simple group while the +second is a more complex one: + +@example +("no.group" 5 (1 . 54324)) + +("nnml:my.mail" 3 ((1 . 5) 9 (20 . 55)) + ((tick (15 . 19)) (replied 3 6 (19 . 3))) + (nnml "") + (auto-expire (to-address "ding@@gnus.org"))) +@end example + +The first element is the @dfn{group name}---as Gnus knows the group, +anyway. The second element is the @dfn{subscription level}, which +normally is a small integer. The third element is a list of ranges of +read articles. The fourth element is a list of lists of article marks +of various kinds. The fifth element is the select method (or virtual +server, if you like). The sixth element is a list of @dfn{group +parameters}, which is what this section is about. + +Any of the last three elements may be missing if they are not required. +In fact, the vast majority of groups will normally only have the first +three elements, which saves quite a lot of cons cells. + +Here's a BNF definition of the group info format: + +@example +info = "(" group space level space read + [ "" / [ space marks-list [ "" / [ space method [ "" / + space parameters ] ] ] ] ] ")" +group = quote quote +level = +read = range +marks-lists = nil / "(" *marks ")" +marks = "(" range ")" +method = "(" *elisp-forms ")" +parameters = "(" *elisp-forms ")" +@end example + +Actually that @samp{marks} rule is a fib. A @samp{marks} is a +@samp{} consed on to a @samp{range}, but that's a bitch to say +in pseudo-BNF. + +If you have a Gnus info and want to access the elements, Gnus offers a +series of macros for getting/setting these elements. + +@table @code +@item gnus-info-group +@itemx gnus-info-set-group +@findex gnus-info-group +@findex gnus-info-set-group +Get/set the group name. + +@item gnus-info-rank +@itemx gnus-info-set-rank +@findex gnus-info-rank +@findex gnus-info-set-rank +Get/set the group rank. + +@item gnus-info-level +@itemx gnus-info-set-level +@findex gnus-info-level +@findex gnus-info-set-level +Get/set the group level. + +@item gnus-info-score +@itemx gnus-info-set-score +@findex gnus-info-score +@findex gnus-info-set-score +Get/set the group score. + +@item gnus-info-read +@itemx gnus-info-set-read +@findex gnus-info-read +@findex gnus-info-set-read +Get/set the ranges of read articles. + +@item gnus-info-marks +@itemx gnus-info-set-marks +@findex gnus-info-marks +@findex gnus-info-set-marks +Get/set the lists of ranges of marked articles. + +@item gnus-info-method +@itemx gnus-info-set-method +@findex gnus-info-method +@findex gnus-info-set-method +Get/set the group select method. + +@item gnus-info-params +@itemx gnus-info-set-params +@findex gnus-info-params +@findex gnus-info-set-params +Get/set the group parameters. +@end table + +All the getter functions take one parameter---the info list. The setter +functions take two parameters---the info list and the new value. + +The last three elements in the group info aren't mandatory, so it may be +necessary to extend the group info before setting the element. If this +is necessary, you can just pass on a non-@code{nil} third parameter to +the three final setter functions to have this happen automatically. + + +@node Extended Interactive +@subsection Extended Interactive +@cindex interactive +@findex gnus-interactive + +Gnus extends the standard Emacs @code{interactive} specification +slightly to allow easy use of the symbolic prefix (@pxref{Symbolic +Prefixes}). Here's an example of how this is used: + +@lisp +(defun gnus-summary-increase-score (&optional score symp) + (interactive (gnus-interactive "P\ny")) + ... + ) +@end lisp + +The best thing to do would have been to implement +@code{gnus-interactive} as a macro which would have returned an +@code{interactive} form, but this isn't possible since Emacs checks +whether a function is interactive or not by simply doing an @code{assq} +on the lambda form. So, instead we have @code{gnus-interactive} +function that takes a string and returns values that are usable to +@code{interactive}. + +This function accepts (almost) all normal @code{interactive} specs, but +adds a few more. + +@table @samp +@item y +@vindex gnus-current-prefix-symbol +The current symbolic prefix---the @code{gnus-current-prefix-symbol} +variable. + +@item Y +@vindex gnus-current-prefix-symbols +A list of the current symbolic prefixes---the +@code{gnus-current-prefix-symbol} variable. + +@item A +The current article number---the @code{gnus-summary-article-number} +function. + +@item H +The current article header---the @code{gnus-summary-article-header} +function. + +@item g +The current group name---the @code{gnus-group-group-name} +function. + +@end table + + +@node Emacs/XEmacs Code +@subsection Emacs/XEmacs Code +@cindex XEmacs +@cindex Emacsen + +While Gnus runs under Emacs, XEmacs and Mule, I decided that one of the +platforms must be the primary one. I chose Emacs. Not because I don't +like XEmacs or Mule, but because it comes first alphabetically. + +This means that Gnus will byte-compile under Emacs with nary a warning, +while XEmacs will pump out gigabytes of warnings while byte-compiling. +As I use byte-compilation warnings to help me root out trivial errors in +Gnus, that's very useful. + +I've also consistently used Emacs function interfaces, but have used +Gnusey aliases for the functions. To take an example: Emacs defines a +@code{run-at-time} function while XEmacs defines a @code{start-itimer} +function. I then define a function called @code{gnus-run-at-time} that +takes the same parameters as the Emacs @code{run-at-time}. When running +Gnus under Emacs, the former function is just an alias for the latter. +However, when running under XEmacs, the former is an alias for the +following function: + +@lisp +(defun gnus-xmas-run-at-time (time repeat function &rest args) + (start-itimer + "gnus-run-at-time" + `(lambda () + (,function ,@@args)) + time repeat)) +@end lisp + +This sort of thing has been done for bunches of functions. Gnus does +not redefine any native Emacs functions while running under XEmacs---it +does this @code{defalias} thing with Gnus equivalents instead. Cleaner +all over. + +In the cases where the XEmacs function interface was obviously cleaner, +I used it instead. For example @code{gnus-region-active-p} is an alias +for @code{region-active-p} in XEmacs, whereas in Emacs it is a function. + +Of course, I could have chosen XEmacs as my native platform and done +mapping functions the other way around. But I didn't. The performance +hit these indirections impose on Gnus under XEmacs should be slight. + + +@node Various File Formats +@subsection Various File Formats + +@menu +* Active File Format:: Information on articles and groups available. +* Newsgroups File Format:: Group descriptions. +@end menu + + +@node Active File Format +@subsubsection Active File Format + +The active file lists all groups available on the server in +question. It also lists the highest and lowest current article numbers +in each group. + +Here's an excerpt from a typical active file: + +@example +soc.motss 296030 293865 y +alt.binaries.pictures.fractals 3922 3913 n +comp.sources.unix 1605 1593 m +comp.binaries.ibm.pc 5097 5089 y +no.general 1000 900 y +@end example + +Here's a pseudo-BNF definition of this file: + +@example +active = *group-line +group-line = group space high-number space low-number space flag +group = +space = " " +high-number = +low-number = +flag = "y" / "n" / "m" / "j" / "x" / "=" group +@end example + + +@node Newsgroups File Format +@subsubsection Newsgroups File Format + +The newsgroups file lists groups along with their descriptions. Not all +groups on the server have to be listed, and not all groups in the file +have to exist on the server. The file is meant purely as information to +the user. + +The format is quite simple; a group name, a tab, and the description. +Here's the definition: + +@example +newsgroups = *line +line = group tab description +group = +tab = +description = +@end example + + +@node Emacs for Heathens +@section Emacs for Heathens + +Believe it or not, but some people who use Gnus haven't really used +Emacs much before they embarked on their journey on the Gnus Love Boat. +If you are one of those unfortunates whom ``@kbd{M-C-a}'', ``kill the +region'', and ``set @code{gnus-flargblossen} to an alist where the key +is a regexp that is used for matching on the group name'' are magical +phrases with little or no meaning, then this appendix is for you. If +you are already familiar with Emacs, just ignore this and go fondle your +cat instead. + +@menu +* Keystrokes:: Entering text and executing commands. +* Emacs Lisp:: The built-in Emacs programming language. +@end menu + + +@node Keystrokes +@subsection Keystrokes + +@itemize @bullet +@item +Q: What is an experienced Emacs user? + +@item +A: A person who wishes that the terminal had pedals. +@end itemize + +Yes, when you use Emacs, you are apt to use the control key, the shift +key and the meta key a lot. This is very annoying to some people +(notably @code{vi}le users), and the rest of us just love the hell out +of it. Just give up and submit. Emacs really does stand for +``Escape-Meta-Alt-Control-Shift'', and not ``Editing Macros'', as you +may have heard from other disreputable sources (like the Emacs author). + +The shift keys are normally located near your pinky fingers, and are +normally used to get capital letters and stuff. You probably use it all +the time. The control key is normally marked ``CTRL'' or something like +that. The meta key is, funnily enough, never marked as such on any +keyboard. The one I'm currently at has a key that's marked ``Alt'', +which is the meta key on this keyboard. It's usually located somewhere +to the left hand side of the keyboard, usually on the bottom row. + +Now, us Emacs people don't say ``press the meta-control-m key'', +because that's just too inconvenient. We say ``press the @kbd{M-C-m} +key''. @kbd{M-} is the prefix that means ``meta'' and ``C-'' is the +prefix that means ``control''. So ``press @kbd{C-k}'' means ``press +down the control key, and hold it down while you press @kbd{k}''. +``Press @kbd{M-C-k}'' means ``press down and hold down the meta key and +the control key and then press @kbd{k}''. Simple, ay? + +This is somewhat complicated by the fact that not all keyboards have a +meta key. In that case you can use the ``escape'' key. Then @kbd{M-k} +means ``press escape, release escape, press @kbd{k}''. That's much more +work than if you have a meta key, so if that's the case, I respectfully +suggest you get a real keyboard with a meta key. You can't live without +it. + + + +@node Emacs Lisp +@subsection Emacs Lisp + +Emacs is the King of Editors because it's really a Lisp interpreter. +Each and every key you tap runs some Emacs Lisp code snippet, and since +Emacs Lisp is an interpreted language, that means that you can configure +any key to run any arbitrary code. You just, like, do it. + +Gnus is written in Emacs Lisp, and is run as a bunch of interpreted +functions. (These are byte-compiled for speed, but it's still +interpreted.) If you decide that you don't like the way Gnus does +certain things, it's trivial to have it do something a different way. +(Well, at least if you know how to write Lisp code.) However, that's +beyond the scope of this manual, so we are simply going to talk about +some common constructs that you normally use in your @file{.emacs} file +to customize Gnus. + +If you want to set the variable @code{gnus-florgbnize} to four (4), you +write the following: + +@lisp +(setq gnus-florgbnize 4) +@end lisp + +This function (really ``special form'') @code{setq} is the one that can +set a variable to some value. This is really all you need to know. Now +you can go and fill your @code{.emacs} file with lots of these to change +how Gnus works. + +If you have put that thing in your @code{.emacs} file, it will be read +and @code{eval}ed (which is lisp-ese for ``run'') the next time you +start Emacs. If you want to change the variable right away, simply say +@kbd{C-x C-e} after the closing parenthesis. That will @code{eval} the +previous ``form'', which is a simple @code{setq} statement here. + +Go ahead---just try it, if you're located at your Emacs. After you +@kbd{C-x C-e}, you will see @samp{4} appear in the echo area, which +is the return value of the form you @code{eval}ed. + +Some pitfalls: + +If the manual says ``set @code{gnus-read-active-file} to @code{some}'', +that means: + +@lisp +(setq gnus-read-active-file 'some) +@end lisp + +On the other hand, if the manual says ``set @code{gnus-nntp-server} to +@samp{nntp.ifi.uio.no}'', that means: + +@lisp +(setq gnus-nntp-server "nntp.ifi.uio.no") +@end lisp + +So be careful not to mix up strings (the latter) with symbols (the +former). The manual is unambiguous, but it can be confusing. + + +@include gnus-faq.texi + +@node Index +@chapter Index +@printindex cp + +@node Key Index +@chapter Key Index +@printindex ky + +@summarycontents +@contents +@bye + +@iftex +@iflatex +\end{document} +@end iflatex +@end iftex + +@c End: + diff --git a/texi/gnuslogo.refcard b/texi/gnuslogo.refcard new file mode 100644 index 0000000..aacf40e --- /dev/null +++ b/texi/gnuslogo.refcard @@ -0,0 +1,243 @@ +%!PS-Adobe-2.0 EPSF-1.2 +%%Creator: Adobe Illustrator 88(TM) format generated by CorelTRACE Version 2.0C +%%Title: /home/menja/c/larsi/gnus.eps +%%BoundingBox: 0 0 924.5 907.2 +%%CreationDate: Tue Feb 20 01:51:37 1996 +%%DocumentFonts: +%%ColorUsage: B & W +%%TileBox: 0 0 924.5 907.2 +%%EndComments +%%BeginProcSet:Adobe_Illustrator_1.1 0 0 +% Copyright 1992 Corel Corporation. + +% All rights reserved. +.15 .15 scale + +/wPSMDict 150 dict def +wPSMDict begin +/bd {bind def} bind def +/ld {load def} bd +/xd {exch def} bd +/_ null def +/$c 0 def +/$m 0 def +/$y 0 def +/$k 0 def +/$t 1 def +/$n _ def +/$o 0 def +/$C 0 def +/$M 0 def +/$Y 0 def +/$K 0 def +/$T 1 def +/$N _ def +/$O 0 def +/$h false def +/$al 0 def +/$tr 0 def +/$le 0 def +/$lx 0 def +/$ly 0 def +/$ctm matrix currentmatrix def +/@cp /closepath ld +/@gs /gsave ld +/@gr /grestore ld +/@MN {2 copy le{pop}{exch pop}ifelse}bd +/setcmykcolor where {pop}{/setcmykcolor{4 1 roll +3 {3 index add 1 @MN 1 exch sub 3 1 roll} repeat +setrgbcolor +pop}bd}ifelse +/@tc{dup 1 ge{pop}{4 {dup +6 -1 roll +mul +exch}repeat +pop}ifelse}bd +/@scc{$c $m $y $k $t @tc setcmykcolor true}bd +/@SCC{$C $M $Y $K $T @tc setcmykcolor true}bd +/@sm{/$ctm $ctm currentmatrix def}bd +/x {/$t xd /$n xd +/$k xd /$y xd /$m xd /$c xd}bd +/X {/$T xd /$N xd +/$K xd /$Y xd /$M xd /$C xd}bd +/g {1 exch sub 0 0 0 +4 -1 roll +_ 1 x}bd +/G {1 exch sub 0 0 0 +4 -1 roll +_ 1 X}bd +/k {_ 1 x}bd +/K {_ 1 X}bd +/d /setdash ld +/i {dup 0 ne {setflat} {pop} ifelse}bd +/j /setlinejoin ld +/J /setlinecap ld +/M /setmiterlimit ld +/w /setlinewidth ld +/O {/$o xd}bd +/R {/$O xd}bd +/c /curveto ld +/C /c ld +/l /lineto ld +/L /l ld +/m /moveto ld +/n /newpath ld +/N /newpath ld +/F {@scc{eofill}if n} bd +/f {@cp F}bd +/S {@SCC{stroke}if n} bd +/s {@cp +S}bd +/B {@gs F @gr +S}bd +/b {@cp B }bd +/u {}bd +/U {}bd +%%EndProlog +%%BeginSetup +%%EndSetup +1 i +2 J +0 j +4 M +[]0 d + +%%Note: traced as Normal_Outline +0 g +259.2 78.2 m +327.3 178.5 L +327.8 179.0 328.3 180.0 329.7 180.4 C +373.4 241.9 L +388.8 263.5 L +389.2 264.0 390.7 264.4 391.6 265.4 C +413.7 298.0 453.6 351.8 468.0 404.6 C +467.5 405.6 467.5 407.0 467.5 407.0 C +442.0 367.6 411.3 319.2 379.2 279.3 C +372.0 267.3 366.7 265.9 361.9 254.8 C +333.1 216.0 L +323.5 207.3 311.0 185.2 302.8 175.6 C +298.0 165.6 293.2 164.1 288.9 154.0 C +282.2 147.8 282.2 139.6 276.4 132.4 C +258.2 77.7 L +258.2 77.7 259.2 78.2 259.2 78.2 C +f +0 g +470.8 211.6 m +470.8 211.6 472.3 212.1 472.3 212.1 C +518.8 305.2 L +531.3 317.2 L +537.6 314.8 539.0 300.9 548.6 301.9 C +555.8 301.9 554.8 302.8 561.6 306.2 C +595.2 357.1 L +595.6 358.0 597.6 358.5 598.5 360.0 C +615.8 398.4 650.8 450.7 657.6 483.8 C +658.0 486.2 658.0 488.1 658.0 489.6 C +654.2 489.1 656.1 485.2 650.4 479.5 C +634.5 446.8 611.5 402.2 592.8 377.2 C +588.0 370.0 581.7 365.7 577.4 358.5 C +570.2 355.6 568.3 351.3 560.1 356.6 C +554.8 360.0 553.9 364.8 550.0 370.0 C +548.1 371.5 550.0 370.5 547.2 371.0 C +541.4 365.2 L +511.2 319.6 484.3 276.0 471.8 220.3 C +470.8 215.5 471.3 215.5 469.4 212.1 C +469.4 212.1 470.8 211.6 470.8 211.6 C +f +0 g +731.0 292.8 m +756.0 351.3 751.6 407.0 771.3 468.0 C +783.3 520.8 809.7 582.2 822.2 635.0 C +829.4 684.4 855.8 732.0 825.1 789.1 C +811.6 797.7 799.6 805.4 784.8 802.0 C +757.9 792.0 732.9 743.0 726.2 712.8 C +727.6 708.4 727.2 707.0 730.0 704.6 C +731.0 704.1 732.9 704.1 734.4 704.6 C +737.2 709.9 L +754.0 747.3 L +758.8 755.0 771.8 754.0 781.9 751.2 C +788.1 748.3 791.5 745.9 797.7 744.0 C +831.8 680.1 800.6 611.0 784.3 542.8 C +765.6 478.5 748.3 431.5 739.2 370.5 C +733.9 347.5 729.1 318.7 730.0 292.8 C +730.0 292.8 731.0 292.8 731.0 292.8 C +f +0 g +434.4 462.7 m +460.3 496.8 462.2 532.8 458.4 575.5 C +456.4 588.0 451.2 599.0 445.4 609.1 C +435.3 620.1 435.3 622.5 421.9 630.7 C +411.8 619.6 398.4 604.8 391.6 586.0 C +393.6 581.7 396.4 584.1 401.7 577.9 C +403.2 577.4 404.6 576.9 404.6 576.9 C +407.0 574.5 406.0 573.6 410.4 571.2 C +414.2 564.0 418.5 558.2 424.3 545.7 C +437.2 526.5 428.1 489.6 433.9 462.2 C +433.9 462.2 434.4 462.7 434.4 462.7 C +f +0 g +226.0 482.4 m +281.7 485.7 311.0 531.3 357.1 565.9 C +362.8 572.1 364.8 574.0 368.6 580.3 C +368.6 581.7 369.1 582.7 369.6 584.6 C +370.0 585.6 371.5 587.0 372.9 588.0 C +381.6 606.2 L +377.2 605.2 374.8 602.8 371.0 597.6 C +346.0 576.4 316.8 552.0 289.9 536.1 C +288.9 535.2 288.0 534.2 288.0 534.2 C +273.6 528.0 263.5 527.5 247.6 530.8 C +242.4 535.2 239.0 536.1 238.0 544.3 C +239.5 572.1 266.8 600.0 281.2 624.9 C +293.7 637.9 300.4 650.4 311.5 668.1 C +312.0 669.1 313.9 669.6 314.8 671.0 C +319.6 679.6 L +319.6 680.1 319.6 681.6 319.2 682.0 C +285.6 649.4 258.7 601.4 229.9 555.8 C +216.4 529.9 205.4 511.2 210.2 491.0 C +212.6 483.8 218.8 484.8 226.0 482.4 C +f +0 g +624.9 600.4 m +645.1 606.2 L +676.3 622.5 694.5 658.0 710.8 698.4 C +710.4 704.1 711.3 704.6 712.3 709.4 C +696.9 685.9 693.6 667.6 662.4 653.7 C +654.7 651.3 649.4 650.4 639.3 650.8 C +633.1 654.2 625.4 659.0 621.6 670.5 C +597.6 620.6 L +600.9 612.4 604.3 607.2 613.4 603.8 C +617.2 603.3 621.1 601.4 624.9 600.4 C +f +0 g +528.4 619.2 m +548.6 617.2 564.9 629.2 578.8 645.6 C +584.1 651.8 586.5 662.8 591.8 671.0 C +593.2 681.6 603.8 690.2 601.9 704.1 C +598.5 705.1 599.0 698.8 594.7 694.0 C +581.7 679.6 L +569.7 668.6 545.7 663.8 532.8 673.9 C +487.2 697.9 467.5 754.5 413.2 772.8 C +393.1 778.0 387.3 771.8 367.2 760.3 C +360.9 755.5 357.6 744.9 351.3 740.6 C +347.0 740.6 349.9 743.5 344.6 747.3 C +344.1 748.8 343.6 750.2 343.6 750.2 C +322.5 770.8 L +312.9 775.2 300.9 784.3 287.0 779.0 C +283.6 777.1 281.7 776.1 279.3 775.2 C +250.0 750.7 229.4 705.6 181.4 697.4 C +165.6 705.1 160.3 715.2 150.7 733.9 C +130.5 685.4 L +142.5 663.3 L +147.3 661.9 147.3 660.4 151.2 655.6 C +160.8 650.4 169.9 649.4 182.8 655.2 C +212.1 676.8 L +213.1 677.7 214.0 678.7 216.0 679.2 C +238.5 695.5 250.5 727.6 279.3 735.3 C +296.1 727.2 312.4 715.6 326.8 695.5 C +330.2 688.3 331.6 684.9 335.5 681.1 C +345.1 694.5 352.8 717.6 372.9 721.9 C +423.3 726.7 453.6 670.5 498.2 631.6 C +510.7 624.4 517.4 621.1 528.4 619.2 C +f +%%Trailer +end +showpage diff --git a/texi/gnusref.tex b/texi/gnusref.tex new file mode 100644 index 0000000..da186fe --- /dev/null +++ b/texi/gnusref.tex @@ -0,0 +1,687 @@ +% include file for the Gnus refcard and booklet +\def\progver{5.0}\def\refver{5.0} % program and refcard versions +\def\date{16 September 1995} +\def\author{Vladimir Alexiev $<$vladimir@cs.ualberta.ca$>$} +\raggedbottom\raggedright +\newlength{\logowidth}\setlength{\logowidth}{6.861in} +\newlength{\logoheight}\setlength{\logoheight}{7.013in} +\newlength{\keycolwidth} +\newenvironment{keys}[1]% #1 is the widest key + {\nopagebreak%\noindent% + \settowidth{\keycolwidth}{#1}% + \addtolength{\keycolwidth}{\tabcolsep}% + \addtolength{\keycolwidth}{-\columnwidth}% + \begin{tabular}{@{}l@{\hspace{\tabcolsep}}p{-\keycolwidth}@{}}}% + {\end{tabular}\\} +\catcode`\^=12 % allow ^ to be typed literally +\newcommand{\B}[1]{{\bf#1})} % bold l)etter + +\def\Title{ +\begin{center} +{\bf\LARGE Gnus \progver\ Reference \Guide\\} +%{\normalsize \Guide\ version \refver} +\end{center} +} + +\newcommand\Logo[1]{\centerline{ +\makebox[\logoscale\logowidth][l]{\vbox to \logoscale\logoheight +{\vfill\special{psfile=gnuslogo.#1}}\vspace{-\baselineskip}}}} + +\def\CopyRight{ +\begin{center} +Copyright \copyright\ 1995 Free Software Foundation, Inc.\\* +Copyright \copyright\ 1995 \author.\\* +Created from the Gnus manual Copyright \copyright\ 1994 Lars Magne +Ingebrigtsen.\\* +and the Emacs Help Bindings feature (C-h b).\\* +Gnus logo copyright \copyright\ 1995 Luis Fernandes.\\* +\end{center} + +Permission is granted to make and distribute copies of this reference +\guide{} provided the copyright notice and this permission are preserved on +all copies. Please send corrections, additions and suggestions to the +above email address. \Guide{} last edited on \date. +} + +\def\Notes{ +\subsec{Notes} +{\samepage +Gnus is complex. Currently it has some 346 interactive (user-callable) +functions. Of these 279 are in the two major modes (Group and +Summary/Article). Many of these functions have more than one binding, some +have 3 or even 4 bindings. The total number of keybindings is 389. So in +order to save 40\% space, every function is listed only once on this +\guide, under the ``more logical'' binding. Alternative bindings are given +in parentheses in the beginning of the description. + +Many Gnus commands are affected by the numeric prefix. Normally you enter a +prefix by holding the Meta key and typing a number, but in most Gnus modes +you don't need to use Meta since the digits are not self-inserting. The +prefixed behavior of commands is given in [brackets]. Often the prefix is +used to specify: + +\quad [distance] How many objects to move the point over. + +\quad [scope] How many objects to operate on (including the current one). + +\quad [p/p] The ``Process/Prefix Convention'': If a prefix is given then it +determines how many objects to operate on. Else if there are some objects +marked with the process mark \#, these are operated on. Else only the +current object is affected. + +\quad [level] A group subscribedness level. Only groups with a lower or +equal level will be affected by the operation. If no prefix is given, +`gnus-group-default-list-level' is used. If +`gnus-group-use-permanent-levels', then a prefix to the `g' and `l' +commands will also set the default level. + +\quad [score] An article score. If no prefix is given, +`gnus-summary-default-score' is used. +%Some functions were not yet documented at the time of creating this +%\guide and are clearly indicated as such. +\\*[\baselineskip] +\begin{keys}{C-c C-i} +C-c C-i & Go to the Gnus online {\bf info}.\\ +C-c C-b & Send a Gnus {\bf bug} report.\\ +\end{keys} +}} + +\def\GroupLevels{ +\subsec{Group Subscribedness Levels} +The table below assumes that you use the default Gnus levels. +Fill your user-specific levels in the blank cells.\\[1\baselineskip] + +\begin{tabular}{|c|l|l|} +\hline +Level & Groups & Status \\ +\hline +1 & mail groups & \\ +2 & mail groups & \\ +3 & & subscribed \\ +4 & & \\ +5 & default list level & \\ +\hline +6 & & unsubscribed \\ +7 & & \\ +\hline +8 & & zombies \\ +\hline +9 & & killed \\ +\hline +\end{tabular} +} + +\def\Marks{ +\subsec{Mark Indication Characters} +{\samepage If a command directly sets a mark, it is shown in parentheses.\\* +\newlength{\markcolwidth} +\settowidth{\markcolwidth}{` '}% widest character +\addtolength{\markcolwidth}{4\tabcolsep} +\addtolength{\markcolwidth}{-\columnwidth} +\newlength{\markdblcolwidth} +\setlength{\markdblcolwidth}{\columnwidth} +\addtolength{\markdblcolwidth}{-2\tabcolsep} +\begin{tabular}{|c|p{-\markcolwidth}|} +\hline +\multicolumn{2}{|p{\markdblcolwidth}|}{{\bf ``Read'' Marks.} + All these marks appear in the first column of the summary line, and so + are mutually exclusive.}\\ +\hline +` ' & (M-u, M SPC, M c) Not read.\\ +! & (!, M !, M t) Ticked (interesting).\\ +? & (?, M ?) Dormant (only followups are interesting).\\ +C & (C, S c) {\bf Canceled} (only for your own articles).\\ +E & (E, M e, M x) {\bf Expirable}. Only has effect in mail groups.\\ +\hline\hline +\multicolumn{2}{|p{\markdblcolwidth}|}{The marks below mean that the article + is read (killed, uninteresting), and have more or less the same effect. + Some commands however explicitly differentiate between them (e.g.\ M + M-C-r, adaptive scoring).}\\ +\hline +r & (d, M d, M r) Deleted (marked as {\bf read}).\\ +C & (M C; M C-c; M H; c, Z c; Z n; Z C) Killed by {\bf catch-up}.\\ +O & {\bf Old} (marked read in a previous session).\\ +K & (k, M k; C-k, M K) {\bf Killed}.\\ +R & {\bf Read} (viewed in actuality).\\ +X & Killed by a kill file.\\ +Y & Killed due to low score.\\ +\hline\multicolumn{2}{c}{\vspace{1ex}}\\\hline +\multicolumn{2}{|p{\markdblcolwidth}|}{{\bf Other marks}}\\ +\hline +\# & (\#, M \#, M P p) Processable (will be affected by the next operation).\\ +A & {\bf Answered} (followed-up or replied).\\ ++ & Over default score.\\ +$-$ & Under default score.\\ += & Has children (thread underneath it). Add `\%e' to + `gnus-summary-line-format'.\\ +\hline +\end{tabular} +}} + +\def\GroupMode{ +\sec{Group Mode} +\begin{keys}{C-c M-C-x} +RET & (=) Select this group. [Prefix: how many (read) articles to fetch. +Positive: newest articles, negative: oldest ones.]\\ +SPC & Select this group and display the first unread article. [Same +prefix as above.]\\ +? & Give a very short help message.\\ +$<$ & Go to the beginning of the Group buffer.\\ +$>$ & Go to the end of the Group buffer.\\ +, & Jump to the lowest-level group with unread articles.\\ +. & Jump to the first group with unread articles.\\ +^ & Enter the Server buffer mode.\\ +a & Post an {\bf article} to a group.\\ +b & Find {\bf bogus} groups and delete them.\\ +c & Mark all unticked articles in this group as read ({\bf catch-up}). +[p/p]\\ +g & Check the server for new articles ({\bf get}). [level]\\ +j & {\bf Jump} to a group.\\ +m & {\bf Mail} a message to someone.\\ +n & Go to the {\bf next} group with unread articles. [distance]\\ +p & (DEL) Go to the {\bf previous} group with unread articles. +[distance]\\ +q & {\bf Quit} Gnus.\\ +r & Read the init file ({\bf reset}).\\ +s & {\bf Save} the `.newsrc.eld' file (and `.newsrc' if +`gnus-save-newsrc-file').\\ +z & Suspend (kill all buffers of) Gnus.\\ +B & {\bf Browse} a foreign server.\\ +C & Mark all articles in this group as read ({\bf Catch-up}). [p/p]\\ +F & {\bf Find} new groups and process them.\\ +N & Go to the {\bf next} group. [distance]\\ +P & Go to the {\bf previous} group. [distance]\\ +Q & {\bf Quit} Gnus without saving any startup (.newsrc) files.\\ +R & {\bf Restart} Gnus.\\ +V & Display the Gnus {\bf version} number.\\ +Z & Clear the dribble buffer.\\ +C-c C-d & Show the {\bf description} of this group. [Prefix: re-read it +from the server.]\\ +C-c C-s & {\bf Sort} the groups by name, number of unread articles, or level +(depending on `gnus-group-sort-function').\\ +C-c C-x & Run all expirable articles in this group through the {\bf expiry} +process.\\ +C-c M-C-x & Run all articles in all groups through the {\bf expiry} process.\\ +C-x C-t & {\bf Transpose} two groups.\\ +M-d & {\bf Describe} ALL groups. [Prefix: re-read the description from the +server.]\\ +M-f & Fetch this group's {\bf FAQ} (using ange-ftp).\\ +M-g & Check the server for new articles in this group ({\bf get}). [p/p]\\ +M-n & Go to the {\bf previous} unread group on the same or lower level. +[distance]\\ +M-p & Go to the {\bf next} unread group on the same or lower level. +[distance]\\ +\end{keys} +} + +\def\GroupCommands{ +\subsec{List Groups} +{\samepage +\begin{keys}{A m} +A a & (C-c C-a) List all groups whose names match a regexp ({\bf +apropos}).\\ +A d & List all groups whose names or {\bf descriptions} match a regexp.\\ +A k & (C-c C-l) List all {\bf killed} groups.\\ +A m & List groups that {\bf match} a regexp and have unread articles. +[level]\\ +A s & (l) List {\bf subscribed} groups with unread articles. [level]\\ +A u & (L) List all groups (including {\bf unsubscribed}). [If no prefix +is given, level 7 is the default]\\ +A z & List the {\bf zombie} groups.\\ +A M & List groups that {\bf match} a regexp.\\ +\end{keys} +} + +\subsec{Create/Edit Foreign Groups} +{\samepage +The select methods are indicated in parentheses.\\* +\begin{keys}{G m} +G a & Make the Gnus list {\bf archive} group. (nndir over ange-ftp)\\ +G d & Make a {\bf directory} group (every file must be a posting and files +must have numeric names). (nndir)\\ +G e & (M-e) {\bf Edit} this group's select method.\\ +G f & Make a group based on a {\bf file}. (nndoc)\\ +G h & Make the Gnus {\bf help} (documentation) group. (nndoc)\\ +G k & Make a {\bf kiboze} group. (nnkiboze)\\ +G m & {\bf Make} a new group.\\ +G p & Edit this group's {\bf parameters}.\\ +G v & Add this group to a {\bf virtual} group. [p/p]\\ +G D & Enter a {\bf directory} as a (temporary) group. (nneething without +recording articles read.)\\ +G E & {\bf Edit} this group's info (select method, articles read, etc).\\ +G V & Make a new empty {\bf virtual} group. (nnvirtual)\\ +\end{keys} +You can also create mail-groups and read your mail with Gnus (very useful +if you are subscribed to any mailing lists), using one of the methods +nnmbox, nnbabyl, nnml, nnmh, or nnfolder. Read about it in the online info +(C-c C-i g Reading Mail RET). +} + +%\subsubsec{Soup Commands} +%\begin{keys}{G s w} +%G s b & gnus-group-brew-soup: not documented.\\ +%G s p & gnus-soup-pack-packet: not documented.\\ +%G s r & nnsoup-pack-replies: not documented.\\ +%G s s & gnus-soup-send-replies: not documented.\\ +%G s w & gnus-soup-save-areas: not documented.\\ +%\end{keys} + +\subsec{Mark Groups} +\begin{keys}{M m} +M m & (\#) Set the process {\bf mark} on this group. [scope]\\ +M u & (M-\#) Remove the process mark from this group ({\bf unmark}). +[scope]\\ +M w & Mark all groups in the current region.\\ +\end{keys} + +\subsec{Unsubscribe, Kill and Yank Groups} +\begin{keys}{S w} +S k & (C-k) {\bf Kill} this group.\\ +S l & Set the {\bf level} of this group. [p/p]\\ +S s & (U) Prompt for a group and toggle its {\bf subscription}.\\ +S t & (u) {\bf Toggle} subscription to this group. [p/p]\\ +S w & (C-w) Kill all groups in the region.\\ +S y & (C-y) {\bf Yank} the last killed group.\\ +S z & Kill all {\bf zombie} groups.\\ +\end{keys} +} + +\def\SummaryMode{ +\sec{Summary Mode} %{Summary and Article Modes} +\begin{keys}{SPC} +SPC & (A SPC, A n) Select an article, scroll it one page, move to the +next one.\\ +DEL & (A DEL, A p, b) Scroll this article one page back. [distance]\\ +RET & Scroll this article one line forward. [distance]\\ += & Expand the Summary window. [Prefix: shrink it to display the +Article window]\\ +$<$ & (A $<$, A b) Scroll to the beginning of this article.\\ +$>$ & (A $>$, A e) Scroll to the end of this article.\\ +\& & Execute a command on all articles matching a regexp. +[Prefix: move backwards.]\\ +j & (G g) Ask for an article number and then {\bf jump} to that summary +line.\\ +C-t & Toggle {\bf truncation} of summary lines.\\ +M-\& & Execute a command on all articles having the process mark.\\ +M-k & Edit this group's {\bf kill} file.\\ +M-n & (G M-n) Go to the {\bf next} summary line of an unread article. +[distance]\\ +M-p & (G M-p) Go to the {\bf previous} summary line of an unread article. +[distance]\\ +M-r & Search through all previous articles for a regexp.\\ +M-s & {\bf Search} through all subsequent articles for a regexp.\\ +M-K & Edit the general {\bf kill} file.\\ +\end{keys} +} + +\def\SortSummary{ +\subsec{Sort the Summary Buffer} +\begin{keys}{C-c C-s C-a} +C-c C-s C-a & Sort the summary by {\bf author}.\\ +C-c C-s C-d & Sort the summary by {\bf date}.\\ +C-c C-s C-i & Sort the summary by article score.\\ +C-c C-s C-n & Sort the summary by article {\bf number}.\\ +C-c C-s C-s & Sort the summary by {\bf subject}.\\ +\end{keys} +} + +\def\Asubmap{ +\subsec{Article Buffer Commands} +\begin{keys}{A m} +A g & (g) (Re)fetch this article ({\bf get}). [Prefix: just show the +article.]\\ +A r & (^, A ^) Go to the parent of this article (the {\bf References} +header).\\ +M-^ & Fetch the article with a given Message-ID.\\ +A s & (s) Perform an i{\bf search} in the article buffer.\\ +A D & (C-d) Un{\bf digestify} this article into a separate group.\\ +\end{keys} +} + +\def\Bsubmap{ +\subsec{Mail-Group Commands} +{\samepage +These commands (except `B c') are only valid in a mail group.\\* +\begin{keys}{B M-C-e} +B DEL & {\bf Delete} the mail article from disk (!). [p/p]\\ +B c & {\bf Copy} this article from any group to a mail group. [p/p]\\ +B e & {\bf Expire} all expirable articles in this group. [p/p]\\ +B i & {\bf Import} a random file into this group.\\ +B m & {\bf Move} the article from one mail group to another. [p/p]\\ +B q & {\bf Query} where will the article go during fancy splitting\\ +B r & {\bf Respool} this mail article. [p/p]\\ +B w & (e) Edit this article.\\ +B M-C-e & {\bf Expunge} (delete from disk) all expirable articles in this group +(!). [p/p]\\ +\end{keys} +}} + +\def\Gsubmap{ +\subsec{Select Articles} +{\samepage +These commands select the target article. They do not understand the prefix.\\* +\begin{keys}{G C-n} +G b & (,) Go to the {\bf best} article (the one with highest score).\\ +G f & (.) Go to the {\bf first} unread article.\\ +G l & (l) Go to the {\bf last} article read.\\ +G n & (n) Go to the {\bf next} unread article.\\ +p & Go to the {\bf previous} unread article.\\ +G p & {\bf Pop} an article off the summary history and go to it.\\ +G N & (N) Go to {\bf the} next article.\\ +G P & (P) Go to the {\bf previous} article.\\ +G C-n & (M-C-n) Go to the {\bf next} article with the same subject.\\ +G C-p & (M-C-p) Go to the {\bf previous} article with the same subject.\\ +\end{keys} +}} + +\def\Hsubmap{ +\subsec{Help Commands} +\begin{keys}{H d} +H d & (C-c C-d) {\bf Describe} this group. [Prefix: re-read the description +from the server.]\\ +H f & Try to fetch the {\bf FAQ} for this group using ange-ftp.\\ +H h & Give a very short {\bf help} message.\\ +H i & (C-c C-i) Go to the Gnus online {\bf info}.\\ +H v & Display the Gnus {\bf version} number.\\ +\end{keys} +} + +\def\Msubmap{ +\subsec{Mark Articles} +\begin{keys}{M M-C-r} +d & (M d, M r) Mark this article as read and move to the next one. +[scope]\\ +D & Mark this article as read and move to the previous one. [scope]\\ +u & (!, M !, M t) Tick this article (mark it as interesting) and move +to the next one. [scope]\\ +U & Tick this article and move to the previous one. [scope]\\ +M-u & (M SPC, M c) Clear all marks from this article and move to the next +one. [scope]\\ +M-U & Clear all marks from this article and move to the previous one. +[scope]\\ +M ? & (?) Mark this article as dormant (only followups are +interesting). [scope]\\ +M b & Set a {\bf bookmark} in this article.\\ +M e & (E, M x) Mark this article as {\bf expirable}. [scope]\\ +M k & (k) {\bf Kill} all articles with the same subject then select the +next one.\\ +M B & Remove the {\bf bookmark} from this article.\\ +M C & {\bf Catch-up} the articles that are not ticked.\\ +M D & Show all {\bf dormant} articles (normally they are hidden unless they +have any followups).\\ +M H & Catch-up (mark read) this group to point ({\bf here}).\\ +M K & (C-k) {\bf Kill} all articles with the same subject as this one.\\ +C-w & Mark all articles between point and mark as read.\\ +M S & (C-c M-C-s) {\bf Show} all expunged articles.\\ +M C-c & {\bf Catch-up} all articles in this group.\\ +M M-r & (x) Expunge all {\bf read} articles from this group.\\ +M M-D & Hide all {\bf dormant} articles.\\ +M M-C-r & Expunge all articles having a given mark.\\ +\end{keys} + +\subsubsec{Mark Based on Score} +\begin{keys}{M s m} +M V c & {\bf Clear} all marks from all high-scored articles. [score]\\ +M V k & {\bf Kill} all low-scored articles. [score]\\ +M V m & Mark all high-scored articles with a given {\bf mark}. [score]\\ +M V u & Mark all high-scored articles as interesting (tick them). [score]\\ +\end{keys} + +\subsubsec{The Process Mark} +{\samepage +These commands set and remove the process mark \#. You only need to use +it if the set of articles you want to operate on is non-contiguous. Else +use a numeric prefix.\\* +\begin{keys}{M P R} +M P a & Mark {\bf all} articles (in series order).\\ +M P p & (\#, M \#) Mark this article.\\ +M P r & Mark all articles in the {\bf region}.\\ +M P s & Mark all articles in the current {\bf series}.\\ +M P t & Mark all articles in this (sub){\bf thread}.\\ +M P u & (M-\#, M M-\#) {\bf Unmark} this article.\\ +M P R & Mark all articles matching a {\bf regexp}.\\ +M P S & Mark all {\bf series} that already contain a marked article.\\ +M P U & {\bf Unmark} all articles.\\ +\end{keys} +}} + +\def\Osubmap{ +\subsec{Output Articles} +\begin{keys}{O m} +O f & Save this article in plain {\bf file} format. [p/p]\\ +O h & Save this article in {\bf mh} folder format. [p/p]\\ +O m & Save this article in {\bf mail} format. [p/p]\\ +O o & (o, C-o) Save this article using the default article saver. [p/p]\\ +O p & ($\mid$) Pipe this article to a shell command. [p/p]\\ +O r & Save this article in {\bf rmail} format. [p/p]\\ +O v & Save this article in {\bf vm} format. [p/p]\\ +\end{keys} +} + +\def\Ssubmap{ +\subsec{Post, Followup, Reply, Forward, Cancel} +{\samepage +These commands put you in a separate post or mail buffer. After +editing the article, send it by pressing C-c C-c. If you are in a +foreign group and want to post the article using the foreign server, give +a prefix to C-c C-c.\\* +\begin{keys}{S O m} +S b & {\bf Both} post a followup to this article, and send a reply.\\ +S c & (C) {\bf Cancel} this article (only works if it is your own).\\ +S f & (f) Post a {\bf followup} to this article.\\ +S m & (m) Send {\bf a} mail to some other person.\\ +S o m & (C-c C-f) Forward this article by {\bf mail} to a person.\\ +S o p & Forward this article as a {\bf post} to a newsgroup.\\ +S p & (a) {\bf Post} an article to this group.\\ +S r & (r) Mail a {\bf reply} to the author of this article.\\ +S s & {\bf Supersede} this article with a new one (only for own +articles).\\ +S u & {\bf Uuencode} a file and post it as a series.\\ +S B & {\bf Both} post a followup, send a reply, and include the +original. [p/p]\\ +S F & (F) Post a {\bf followup} and include the original. [p/p]\\ +S O m & Digest these series and forward by {\bf mail}. [p/p]\\ +S O p & Digest these series and forward as a {\bf post} to a newsgroup. +[p/p]\\ +S R & (R) Mail a {\bf reply} and include the original. [p/p]\\ +\end{keys} +If you want to cancel or supersede an article you just posted (before it +has appeared on the server), go to the *post-news* buffer, change +`Message-ID' to `Cancel' or `Supersedes' and send it again with C-c C-c. +}} + +\def\Tsubmap{ +\subsec{Thread Commands} +\begin{keys}{T \#} +T \# & Mark this thread with the process mark.\\ +T d & Move to the next article in this thread ({\bf down}). [distance]\\ +T h & {\bf Hide} this (sub)thread.\\ +T i & {\bf Increase} the score of this thread.\\ +T k & (M-C-k) {\bf Kill} the current (sub)thread. [Negative prefix: +tick it, positive prefix: unmark it.]\\ +T l & (M-C-l) {\bf Lower} the score of this thread.\\ +T n & (M-C-f) Go to the {\bf next} thread. [distance]\\ +T p & (M-C-b) Go to the {\bf previous} thread. [distance]\\ +T s & {\bf Show} the thread hidden under this article.\\ +T u & Move to the previous article in this thread ({\bf up}). [distance]\\ +T H & {\bf Hide} all threads.\\ +T S & {\bf Show} all hidden threads.\\ +T T & (M-C-t) {\bf Toggle} threading.\\ +\end{keys} +} + +\def\Vsubmap{ +\subsec{Score (Value) Commands} +{\samepage +Read about Adaptive Scoring in the online info.\\* +\begin{keys}{\bf A p m l} +V a & {\bf Add} a new score entry, specifying all elements.\\ +V c & Specify a new score file as {\bf current}.\\ +V e & {\bf Edit} the current score alist.\\ +V f & Edit a score {\bf file} and make it the current one.\\ +V m & {\bf Mark} all articles below a given score as read.\\ +V s & Set the {\bf score} of this article.\\ +V t & Display all score rules applied to this article ({\bf track}).\\ +V x & {\bf Expunge} all low-scored articles. [score]\\ +V C & {\bf Customize} the current score file through a user-friendly +interface.\\ +V S & Display the {\bf score} of this article.\\ +\bf A p m l& Make a scoring entry based on this article.\\ +\end{keys} + +The four letters stand for:\\* +\quad \B{A}ction: I)ncrease, L)ower;\\* +\quad \B{p}art: a)utor (from), s)ubject, x)refs (cross-posting), d)ate, l)ines, +message-i)d, t)references (parent), f)ollowup, b)ody, h)ead (all headers);\\* +\quad \B{m}atch type:\\* +\qquad string: s)ubstring, e)xact, r)egexp, f)uzzy,\\* +\qquad date: b)efore, a)t, n)this,\\* +\qquad number: $<$, =, $>$;\\* +\quad \B{l}ifetime: t)emporary, p)ermanent, i)mmediate. + +If you type the second letter in uppercase, the remaining two are assumed +to be s)ubstring and t)emporary. +If you type the third letter in uppercase, the last one is assumed to be +t)emporary. + +\quad Extra keys for manual editing of a score file:\\* +\begin{keys}{C-c C-c} +C-c C-c & Finish editing the score file.\\ +C-c C-d & Insert the current {\bf date} as number of days.\\ +\end{keys} +}} + +\def\Wsubmap{ +\subsec{Wash the Article Buffer} +\begin{keys}{W C-c} +W b & Make Message-IDs and URLs in the article to mouse-clickable {\bf + buttons}.\\ +W c & Remove extra {\bf CRs} (^M) from the article.\\ +W f & Look for and display any X-{\bf Face} headers.\\ +W l & (w) Remove page breaks ({\bf^L}) from the article.\\ +W m & Toggle {\bf MIME} processing.\\ +W o & Treat {\bf overstrike} or underline (^H\_) in the article.\\ +W q & Treat {\bf quoted}-printable in the article.\\ +W r & (C-c C-r) Do a Caesar {\bf rotate} (rot13) on the article.\\ +W t & (t) {\bf Toggle} the displaying of all headers.\\ +v & Toggle permanent {\bf verbose} displaying of all headers.\\ +W w & Do word {\bf wrap} in the article.\\ +W T e & Convert the article timestamp to time {\bf elapsed} since sent.\\ +W T l & Convert the article timestamp to the {\bf local} timezone.\\ +W T u & (W T z) Convert the article timestamp to {\bf UTC} ({\bf Zulu}, +GMT).\\ +\end{keys} + +\subsubsec{Hide/Highlight Parts of the Article} +\begin{keys}{W W C-c} +W W a & Hide {\bf all} unwanted parts. Calls W W h, W W s, W W C-c.\\ +W W c & Hide article {\bf citation}.\\ +W W h & Hide article {\bf headers}.\\ +W W s & Hide article {\bf signature}.\\ +W W C-c & Hide article {\bf citation} using a more intelligent algorithm.\\ +%\end{keys} +% +%\subsubsec{Highlight Parts of the Article} +%\begin{keys}{W H A} +W H a & Highlight {\bf all} parts. Calls W b, W H c, W H h, W H s.\\ +W H c & Highlight article {\bf citation}.\\ +W H h & Highlight article {\bf headers}.\\ +W H s & Highlight article {\bf signature}.\\ +\end{keys} +} + +\def\Xsubmap{ +\subsec{Extract Series (Uudecode etc)} +{\samepage +Gnus recognizes if the current article is part of a series (multipart +posting whose parts are identified by numbers in their subjects, e.g.{} +1/10\dots10/10) and processes the series accordingly. You can mark and +process more than one series at a time. If the posting contains any +archives, they are expanded and gathered in a new group.\\* +\begin{keys}{X p} +X b & Un-{\bf binhex} these series. [p/p]\\ +X o & Simply {\bf output} these series (no decoding). [p/p]\\ +X p & Unpack these {\bf postscript} series. [p/p]\\ +X s & Un-{\bf shar} these series. [p/p]\\ +X u & {\bf Uudecode} these series. [p/p]\\ +\end{keys} + +Each one of these commands has four variants:\\* +\begin{keys}{X v \bf Z} +X \bf z & Decode these series. [p/p]\\ +X \bf Z & Decode and save these series. [p/p]\\ +X v \bf z & Decode and view these series. [p/p]\\ +X v \bf Z & Decode, save and view these series. [p/p]\\ +\end{keys} +where {\bf z} or {\bf Z} identifies the decoding method (b, o, p, s, u). + +An alternative binding for the most-often used of these commands is\\* +\begin{keys}{C-c C-v C-v} +C-c C-v C-v & (X v u) Uudecode and view these series. [p/p]\\ +\end{keys} +}} + +\def\Zsubmap{ +\subsec{Exit the Current Group} +\begin{keys}{Z G} +Z c & (c) Mark all unticked articles as read ({\bf catch-up}) and exit.\\ +Z n & Mark all articles as read and go to the {\bf next} group.\\ +Z C & Mark all articles as read ({\bf catch-up}) and exit.\\ +Z E & (Q) {\bf Exit} without updating the group information.\\ +Z G & (M-g) Check for new articles in this group ({\bf get}).\\ +Z N & Exit and go to {\bf the} next group.\\ +Z P & Exit and go to the {\bf previous} group.\\ +Z R & Exit this group, and then enter it again ({\bf reenter}). +[Prefix: select all articles, read and unread.]\\ +Z Z & (q, Z Q) Exit this group.\\ +\end{keys} +} + +\def\ArticleMode{ +\sec{Article Mode} +{\samepage +% All keys for Summary mode also work in Article mode. +The normal navigation keys work in Article mode. +Some additional keys are:\\* +\begin{keys}{C-c C-m} +RET & (middle mouse button) Activate the button at point to follow +an URL or Message-ID.\\ +TAB & Move the point to the next button.\\ +h & (s) Go to the {\bf header} line of the article in the {\bf +summary} buffer.\\ +C-c ^ & Get the article with the Message-ID near point.\\ +C-c C-m & {\bf Mail} reply to the address near point (prefix: include the +original).\\ +\end{keys} +}} + +\def\ServerMode{ +\sec{Server Mode} +{\samepage +To enter this mode, press `^' while in Group mode.\\* +\begin{keys}{SPC} +SPC & (RET) Browse this server.\\ +a & {\bf Add} a new server.\\ +c & {\bf Copy} this server.\\ +e & {\bf Edit} a server.\\ +k & {\bf Kill} this server. [scope]\\ +l & {\bf List} all servers.\\ +q & Return to the group buffer ({\bf quit}).\\ +y & {\bf Yank} the previously killed server.\\ +\end{keys} +}} + +\def\BrowseServer{ +\sec{Browse Server Mode} +{\samepage +To enter this mode, press `B' while in Group mode.\\* +\begin{keys}{RET} +RET & Enter the current group.\\ +SPC & Enter the current group and display the first article.\\ +? & Give a very short help message.\\ +n & Go to the {\bf next} group. [distance]\\ +p & Go to the {\bf previous} group. [distance]\\ +q & (l) {\bf Quit} browse mode.\\ +u & Subscribe to the current group. [scope]\\ +\end{keys} +}} diff --git a/texi/message.texi b/texi/message.texi new file mode 100644 index 0000000..4371e49 --- /dev/null +++ b/texi/message.texi @@ -0,0 +1,1187 @@ +\input texinfo @c -*-texinfo-*- + +@setfilename message +@settitle Message 0.110 Manual +@synindex fn cp +@synindex vr cp +@synindex pg cp +@iftex +@finalout +@end iftex +@setchapternewpage odd + +@ifinfo + +This file documents Message, the Emacs message composition mode. + +Copyright (C) 1996 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through Tex and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided also that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions. +@end ifinfo + +@tex + +@titlepage +@title Message 0.110 Manual + +@author by Lars Magne Ingebrigtsen +@page + +@vskip 0pt plus 1filll +Copyright @copyright{} 1996 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions. + +@end titlepage +@page + +@end tex + +@node Top +@top Message + +All message composition (both mail and news) takes place in Message mode +buffers. + +@menu +* Interface:: Setting up message buffers. +* Commands:: Commands you can execute in message mode buffers. +* Variables:: Customizing the message buffers. +* Compatibility:: Making Message backwards compatible. +* Index:: Variable, function and concept index. +* Key Index:: List of Message mode keys. +@end menu + +This manual corresponds to Message 0.110. Message is distributed with +the Gnus distribution bearing the same version number as this manual +has. + + +@node Interface +@chapter Interface + +When a program (or a person) wants to respond to a message -- reply, +follow up, forward, cancel -- the program (or person) should just put +point in the buffer where the message is and call the required command. +@code{Message} will then pop up a new @code{message} mode buffer with +appropriate headers filled out, and the user can edit the message before +sending it. + +@menu +* New Mail Message:: Editing a brand new mail message. +* New News Message:: Editing a brand new news message. +* Reply:: Replying via mail. +* Wide Reply:: Responding to all people via mail. +* Followup:: Following up via news. +* Canceling News:: Canceling a news article. +* Superseding:: Superseding a message. +* Forwarding:: Forwarding a message via news or mail. +* Resending:: Resending a mail message. +* Bouncing:: Bouncing a mail message. +@end menu + + +@node New Mail Message +@section New Mail Message + +@findex message-mail +The @code{message-mail} command pops up a new message buffer. + +Two optional parameters are accepted: The first will be used as the +@code{To} header and the second as the @code{Subject} header. If these +aren't present, those two headers will be empty. + + +@node New News Message +@section New News Message + +@findex message-news +The @code{message-news} command pops up a new message buffer. + +This function accepts two optional parameters. The first will be used +as the @code{Newsgroups} header and the second as the @code{Subject} +header. If these aren't present, those two headers will be empty. + + +@node Reply +@section Reply + +@findex message-reply +The @code{message-reply} function pops up a message buffer that's a +reply to the message in the current buffer. + +@vindex message-reply-to-function +Message uses the normal methods to determine where replies are to go, +but you can change the behavior to suit your needs by fiddling with the +@code{message-reply-to-function} variable. + +If you want the replies to go to the @code{Sender} instead of the +@code{From}, you could do something like this: + +@lisp +(setq message-reply-to-function + (lambda () + (cond ((equal (mail-fetch-field "from") "somebody") + (mail-fetch-field "sender")) + (t + nil)))) +@end lisp + +This function will be called narrowed to the head of the article that is +being replied to. + +As you can see, this function should return a string if it has an +opinion as to what the To header should be. If it does not, it should +just return @code{nil}, and the normal methods for determining the To +header will be used. + +This function can also return a list. In that case, each list element +should be a cons, where the car should be the name of an header +(eg. @code{Cc}) and the cdr should be the header value +(eg. @samp{larsi@@ifi.uio.no}). All these headers will be inserted into +the head of the outgoing mail. + + +@node Wide Reply +@section Wide Reply + +@findex message-wide-reply +The @code{message-wide-reply} pops up a message buffer that's a wide +reply to the message in the current buffer. A @dfn{wide reply} is a +reply that goes out to all people listed in the @code{To}, @code{From} +(or @code{Reply-to}) and @code{Cc} headers. + +@vindex message-wide-reply-to-function +Message uses the normal methods to determine where wide replies are to go, +but you can change the behavior to suit your needs by fiddling with the +@code{message-wide-reply-to-function}. It is used in the same way as +@code{message-reply-to-function} (@pxref{Reply}). + +@findex rmail-dont-reply-to-names +Addresses that match the @code{rmail-dont-reply-to-names} regular +expression will be removed from the @code{Cc} header. + + +@node Followup +@section Followup + +@findex message-followup +The @code{message-followup} command pops up a message buffer that's a +followup to the message in the current buffer. + +@vindex message-followup-to-function +Message uses the normal methods to determine where followups are to go, +but you can change the behavior to suit your needs by fiddling with the +@code{message-followup-to-function}. It is used in the same way as +@code{message-reply-to-function} (@pxref{Reply}). + +@vindex message-use-followup-to +The @code{message-use-followup-to} variable says what to do about +@code{Followup-To} headers. If it is @code{use}, always use the value. +If it is @code{ask} (which is the default), ask whether to use the +value. If it is @code{t}, use the value unless it is @samp{poster}. If +it is @code{nil}, don't use the value. + + +@node Canceling News +@section Canceling News + +@findex message-cancel-news +The @code{message-cancel-news} command cancels the article in the +current buffer. + + +@node Superseding +@section Superseding + +@findex message-supersede +The @code{message-supersede} command pops up a message buffer that will +supersede the message in the current buffer. + +@vindex message-ignored-supersedes-headers +Headers matching the @code{message-ignored-supersedes-headers} are +removed before popping up the new message buffer. The default is@* +@samp{^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|@* +^Received:\\|^X-From-Line:\\|Return-Path:}. + + + +@node Forwarding +@section Forwarding + +@findex message-forward +The @code{message-forward} command pops up a message buffer to forward +the message in the current buffer. If given a prefix, forward using +news. + +@table @code +@item message-forward-start-separator +@vindex message-forward-start-separator +Delimiter inserted before forwarded messages. The default is@* +@samp{------- Start of forwarded message -------\n}. + +@vindex message-forward-end-separator +@item message-forward-end-separator +@vindex message-forward-end-separator +Delimiter inserted after forwarded messages. The default is@* +@samp{------- End of forwarded message -------\n}. + +@item message-signature-before-forwarded-message +@vindex message-signature-before-forwarded-message +If this variable is @code{t}, which it is by default, your personal +signature will be inserted before the forwarded message. If not, the +forwarded message will be inserted first in the new mail. + +@item message-included-forward-headers +@vindex message-included-forward-headers +Regexp matching header lines to be included in forwarded messages. + +@end table + + +@node Resending +@section Resending + +@findex message-resend +The @code{message-resend} command will prompt the user for an address +and resend the message in the current buffer to that address. + +@vindex message-ignored-resent-headers +Headers that match the @code{message-ignored-resent-headers} regexp will +be removed before sending the message. The default is +@samp{^Return-receipt}. + + +@node Bouncing +@section Bouncing + +@findex message-bounce +The @code{message-bounce} command will, if the current buffer contains a +bounced mail message, pop up a message buffer stripped of the bounce +information. A @dfn{bounced message} is typically a mail you've sent +out that has been returned by some @code{mailer-daemon} as +undeliverable. + +@vindex message-ignored-bounced-headers +Headers that match the @code{message-ignored-bounced-headers} regexp +will be removed before popping up the buffer. The default is +@samp{^Received:}. + + +@node Commands +@chapter Commands + +@menu +* Header Commands:: Commands for moving to headers. +* Movement:: Moving around in message buffers. +* Insertion:: Inserting things into message buffers. +* Various Commands:: Various things. +* Sending:: Actually sending the message. +* Mail Aliases:: How to use mail aliases. +@end menu + + +@node Header Commands +@section Header Commands + +All these commands move to the header in question. If it doesn't exist, +it will be inserted. + +@table @kbd + +@item C-c ? +@kindex C-c ? +@findex message-goto-to +Describe the message mode. + +@item C-c C-f C-t +@kindex C-c C-f C-t +@findex message-goto-to +Go to the @code{To} header (@code{message-goto-to}). + +@item C-c C-f C-b +@kindex C-c C-f C-b +@findex message-goto-bcc +Go to the @code{Bcc} header (@code{message-goto-bcc}). + +@item C-c C-f C-f +@kindex C-c C-f C-f +@findex message-goto-fcc +Go to the @code{Fcc} header (@code{message-goto-fcc}). + +@item C-c C-f C-c +@kindex C-c C-f C-c +@findex message-goto-cc +Go to the @code{Cc} header (@code{message-goto-cc}). + +@item C-c C-f C-s +@kindex C-c C-f C-s +@findex message-goto-subject +Go to the @code{Subject} header (@code{message-goto-subject}). + +@item C-c C-f C-r +@kindex C-c C-f C-r +@findex message-goto-reply-to +Go to the @code{Reply-To} header (@code{message-goto-reply-to}). + +@item C-c C-f C-n +@kindex C-c C-f C-n +@findex message-goto-newsgroups +Go to the @code{Newsgroups} header (@code{message-goto-newsgroups}). + +@item C-c C-f C-d +@kindex C-c C-f C-d +@findex message-goto-distribution +Go to the @code{Distribution} header (@code{message-goto-distribution}). + +@item C-c C-f C-o +@kindex C-c C-f C-o +@findex message-goto-followup-to +Go to the @code{Followup-To} header (@code{message-goto-followup-to}). + +@item C-c C-f C-k +@kindex C-c C-f C-k +@findex message-goto-keywords +Go to the @code{Keywords} header (@code{message-goto-keywords}). + +@item C-c C-f C-u +@kindex C-c C-f C-u +@findex message-goto-summary +Go to the @code{Summary} header (@code{message-goto-summary}). + +@end table + + +@node Movement +@section Movement + +@table @kbd +@item C-c C-b +@kindex C-c C-b +@findex message-goto-body +Move to the beginning of the body of the message +(@code{message-goto-body}). + +@item C-c C-i +@kindex C-c C-i +@findex message-goto-signature +Move to the signature of the message (@code{message-goto-signature}). + +@end table + + +@node Insertion +@section Insertion + +@table @kbd + +@item C-c C-y +@kindex C-c C-y +@findex message-yank-original +Yank the message that's being replied to into the message buffer +(@code{message-yank-original}). + +@item C-c C-q +@kindex C-c C-q +@findex message-fill-yanked-message +Fill the yanked message (@code{message-fill-yanked-message}). + +@item C-c C-w +@kindex C-c C-w +@findex message-insert-signature +Insert a signature at the end of the buffer +(@code{message-insert-signature}). + +@end table + +@table @code +@item message-ignored-cited-headers +@vindex message-ignored-cited-headers +All headers that match this regexp will be removed from yanked +messages. The default is @samp{.}, which means that all headers will be +removed. + +@item message-citation-line-function +@vindex message-citation-line-function +Function called to insert the citation line. The default is +@code{message-insert-citation-line}. + +@item message-yank-prefix +@vindex message-yank-prefix +@cindex yanking +@cindex quoting +When you are replying to or following up an article, you normally want +to quote the person you are answering. Inserting quoted text is done by +@dfn{yanking}, and each quoted line you yank will have +@code{message-yank-prefix} prepended to it. The default is @samp{> }. +If it is @code{nil}, just indent the message. + +@item message-indentation-spaces +@vindex message-indentation-spaces +Number of spaces to indent yanked messages. + +@item message-cite-function +@vindex message-cite-function +@findex message-cite-original +@findex sc-cite-original +@cindex Supercite +Function for citing an original message. The default is +@code{message-cite-original}. You can also set it to +@code{sc-cite-original} to use Supercite. + +@item message-indent-citation-function +@vindex message-indent-citation-function +Function for modifying a citation just inserted in the mail buffer. +This can also be a list of functions. Each function can find the +citation between @code{(point)} and @code{(mark t)}. And each function +should leave point and mark around the citation text as modified. + +@item message-signature +@vindex message-signature +String to be inserted at the end of the message buffer. If @code{t} +(which is the default), the @code{message-signature-file} file will be +inserted instead. If a function, the result from the function will be +used instead. If a form, the result from the form will be used instead. +If this variable is @code{nil}, no signature will be inserted at all. + +@item message-signature-file +@vindex message-signature-file +File containing the signature to be inserted at the end of the buffer. +The default is @samp{~/.signature}. + +@end table + +Note that RFC1036 says that a signature should be preceded by the three +characters @samp{-- } on a line by themselves. This is to make it +easier for the recipient to automatically recognize and process the +signature. So don't remove those characters, even though you might feel +that they ruin your beautiful design, like, totally. + +Also note that no signature should be more than four lines long. +Including ASCII graphics is an efficient way to get everybody to believe +that you are silly and have nothing important to say. + + + +@node Various Commands +@section Various Commands + +@table @kbd + +@item C-c C-r +@kindex C-c C-r +@findex message-caesar-buffer-body +Caesar rotate (aka. rot13) the current message +(@code{message-caesar-buffer-body}). If narrowing is in effect, just +rotate the visible portion of the buffer. A numerical prefix says how +many places to rotate the text. The default is 13. + +@item C-c C-e +@kindex C-c C-e +@findex message-elide-region +Elide the text between point and mark (@code{message-elide-region}). +The text is killed and an ellipsis (@samp{[...]}) will be inserted in +its place. + +@item C-c C-v +@kindex C-c C-v +@findex message-delete-not-region +Delete all text in the body of the message that is outside the region +(@code{message-delete-not-region}). + +@item M-RET +@kindex M-RET +@kindex message-newline-and-reformat +Insert four newlines, and then reformat if inside quoted text. + +Here's an example: + +@example +> This is some quoted text. And here's more quoted text. +@end example + +If point is before @samp{And} and you press @kbd{M-RET}, you'll get: + +@example +> This is some quoted text. + +* + +> And here's more quoted text. +@end example + +@samp{*} says where point will be placed. + +@item C-c C-t +@kindex C-c C-t +@findex message-insert-to +Insert a @code{To} header that contains the @code{Reply-To} or +@code{From} header of the message you're following up +(@code{message-insert-to}). + +@item C-c C-n +@kindex C-c C-n +@findex message-insert-newsgroups +Insert a @code{Newsgroups} header that reflects the @code{Followup-To} +or @code{Newsgroups} header of the article you're replying to +(@code{message-insert-newsgroups}). + +@item C-c M-r +@kindex C-c M-r +@findex message-rename-buffer +Rename the buffer (@code{message-rename-buffer}). If given a prefix, +prompt for a new buffer name. + +@end table + + +@node Sending +@section Sending + +@table @kbd +@item C-c C-c +@kindex C-c C-c +@findex message-send-and-exit +Send the message and bury the current buffer +(@code{message-send-and-exit}). + +@item C-c C-s +@kindex C-c C-s +@findex message-send +Send the message (@code{message-send}). + +@item C-c C-d +@kindex C-c C-d +@findex message-dont-send +Bury the message buffer and exit (@code{message-dont-send}). + +@item C-c C-k +@kindex C-c C-k +@findex message-kill-buffer +Kill the message buffer and exit (@code{message-kill-buffer}). + +@end table + + + +@node Mail Aliases +@section Mail Aliases +@cindex mail aliases +@cindex aliases + +@vindex message-mail-alias-type +The @code{message-mail-alias-type} variable controls what type of mail +alias expansion to use. Currently only one form is supported---Message +uses @code{mailabbrev} to handle mail aliases. If this variable is +@code{nil}, no mail alias expansion will be performed. + +@code{mailabbrev} works by parsing the @file{/etc/mailrc} and +@file{~/.mailrc} files. These files look like: + +@example +alias lmi "Lars Magne Ingebrigtsen " +alias ding "ding@@ifi.uio.no (ding mailing list)" +@end example + +After adding lines like this to your @file{~/.mailrc} file, you should +be able to just write @samp{lmi} in the @code{To} or @code{Cc} (and so +on) headers and press @kbd{SPC} to expand the alias. + +No expansion will be performed upon sending of the message---all +expansions have to be done explicitly. + + + +@node Variables +@chapter Variables + +@menu +* Message Headers:: General message header stuff. +* Mail Headers:: Customizing mail headers. +* Mail Variables:: Other mail variables. +* News Headers:: Customizing news headers. +* News Variables:: Other news variables. +* Various Message Variables:: Other message variables. +* Sending Variables:: Variables for sending. +* Message Buffers:: How Message names its buffers. +* Message Actions:: Actions to be performed when exiting. +@end menu + + +@node Message Headers +@section Message Headers + +Message is quite aggressive on the message generation front. It has +to be -- it's a combined news and mail agent. To be able to send +combined messages, it has to generate all headers itself to ensure that +mail and news copies of messages look sufficiently similar. + +@table @code + +@item message-generate-headers-first +@vindex message-generate-headers-first +If non-@code{nil}, generate all headers before starting to compose the +message. + +@item message-from-style +@vindex message-from-style +Specifies how @code{From} headers should look. There are four legal +values: + +@table @code +@item nil +Just the address -- @samp{king@@grassland.com}. + +@item parens +@samp{king@@grassland.com (Elvis Parsley)}. + +@item angles +@samp{Elvis Parsley }. + +@item default +Look like @code{angles} if that doesn't require quoting, and +@code{parens} if it does. If even @code{parens} requires quoting, use +@code{angles} anyway. + +@end table + +@item message-deletable-headers +@vindex message-deletable-headers +Headers in this list that were previously generated by Message will be +deleted before posting. Let's say you post an article. Then you decide +to post it again to some other group, you naughty boy, so you jump back +to the @code{*post-buf*} buffer, edit the @code{Newsgroups} line, and +ship it off again. By default, this variable makes sure that the old +generated @code{Message-ID} is deleted, and a new one generated. If +this isn't done, the entire empire would probably crumble, anarchy would +prevail, and cats would start walking on two legs and rule the world. +Allegedly. + +@item message-default-headers +@vindex message-default-headers +This string is inserted at the end of the headers in all message +buffers. + +@end table + + +@node Mail Headers +@section Mail Headers + +@table @code +@item message-required-mail-headers +@vindex message-required-mail-headers +@xref{News Headers}, for the syntax of this variable. It is +@code{(From Date Subject (optional . In-Reply-To) Message-ID Lines +(optional . X-Mailer))} by default. + +@item message-ignored-mail-headers +@vindex message-ignored-mail-headers +Regexp of headers to be removed before mailing. The default is +@samp{^Gcc:\\|^Fcc:}. + +@item message-default-mail-headers +@vindex message-default-mail-headers +This string is inserted at the end of the headers in all message +buffers that are initialized as mail. + +@end table + + +@node Mail Variables +@section Mail Variables + +@table @code +@item message-send-mail-function +@vindex message-send-mail-function +Function used to send the current buffer as mail. The default is +@code{message-send-mail-with-sendmail}. If you prefer using MH +instead, set this variable to @code{message-send-mail-with-mh}. + +@item message-mh-deletable-headers +@vindex message-mh-deletable-headers +Most versions of MH doesn't like being fed messages that contain the +headers in this variable. If this variable is non-@code{nil} (which is +the default), these headers will be removed before mailing. Set it to +@code{nil} if your MH can handle these headers. + +@end table + + +@node News Headers +@section News Headers + +@vindex message-required-news-headers +@code{message-required-news-headers} a list of header symbols. These +headers will either be automatically generated, or, if that's +impossible, they will be prompted for. The following symbols are legal: + +@table @code + +@item From +@cindex From +@findex user-full-name +@findex user-mail-address +This required header will be filled out with the result of the +@code{message-make-from} function, which depends on the +@code{message-from-style}, @code{user-full-name}, +@code{user-mail-address} variables. + +@item Subject +@cindex Subject +This required header will be prompted for if not present already. + +@item Newsgroups +@cindex Newsgroups +This required header says which newsgroups the article is to be posted +to. If it isn't present already, it will be prompted for. + +@item Organization +@cindex organization +This optional header will be filled out depending on the +@code{message-user-organization} variable. +@code{message-user-organization-file} will be used if this variable is +@code{t}. This variable can also be a string (in which case this string +will be used), or it can be a function (which will be called with no +parameters and should return a string to be used). + +@item Lines +@cindex Lines +This optional header will be computed by Message. + +@item Message-ID +@cindex Message-ID +@vindex mail-host-address +@findex system-name +@cindex Sun +This required header will be generated by Message. A unique ID will be +created based on the date, time, user name and system name. Message will +use @code{mail-host-address} as the fully qualified domain name (FQDN) +of the machine if that variable is defined. If not, it will use +@code{system-name}, which doesn't report a FQDN on some machines -- +notably Suns. + +@item X-Newsreader +@cindex X-Newsreader +This optional header will be filled out according to the +@code{message-newsreader} local variable. + +@item X-Mailer +This optional header will be filled out according to the +@code{message-mailer} local variable, unless there already is an +@code{X-Newsreader} header present. + +@item In-Reply-To +This optional header is filled out using the @code{Date} and @code{From} +header of the article being replied to. + +@item Expires +@cindex Expires +This extremely optional header will be inserted according to the +@code{message-expires} variable. It is highly deprecated and shouldn't +be used unless you know what you're doing. + +@item Distribution +@cindex Distribution +This optional header is filled out according to the +@code{message-distribution-function} variable. It is a deprecated and +much misunderstood header. + +@item Path +@cindex path +This extremely optional header should probably never be used. +However, some @emph{very} old servers require that this header is +present. @code{message-user-path} further controls how this +@code{Path} header is to look. If it is @code{nil}, use the server name +as the leaf node. If it is a string, use the string. If it is neither +a string nor @code{nil}, use the user name only. However, it is highly +unlikely that you should need to fiddle with this variable at all. +@end table + +@findex yow +@cindex Mime-Version +In addition, you can enter conses into this list. The car of this cons +should be a symbol. This symbol's name is the name of the header, and +the cdr can either be a string to be entered verbatim as the value of +this header, or it can be a function to be called. This function should +return a string to be inserted. For instance, if you want to insert +@code{Mime-Version: 1.0}, you should enter @code{(Mime-Version . "1.0")} +into the list. If you want to insert a funny quote, you could enter +something like @code{(X-Yow . yow)} into the list. The function +@code{yow} will then be called without any arguments. + +If the list contains a cons where the car of the cons is +@code{optional}, the cdr of this cons will only be inserted if it is +non-@code{nil}. + +Other variables for customizing outgoing news articles: + +@table @code + +@item message-syntax-checks +@vindex message-syntax-checks +If non-@code{nil}, Message will attempt to check the legality of the +headers, as well as some other stuff, before posting. You can control +the granularity of the check by adding or removing elements from this +list. Legal elements are: + +@table @code +@item subject-cmsg +Check the subject for commands. +@item sender +@cindex Sender +Insert a new @code{Sender} header if the @code{From} header looks odd. +@item multiple-headers +Check for the existence of multiple equal headers. +@item sendsys +@cindex sendsys +Check for the existence of version and sendsys commands. +@item message-id +Check whether the @code{Message-ID} looks ok. +@item from +Check whether the @code{From} header seems nice. +@item long-lines +@cindex long lines +Check for too long lines. +@item control-chars +Check for illegal characters. +@item size +Check for excessive size. +@item new-text +Check whether there is any new text in the messages. +@item signature +Check the length of the signature. +@item approved +@cindex approved +Check whether the article has an @code{Approved} header, which is +something only moderators should include. +@item empty +Check whether the article is empty. +@item empty-headers +Check whether any of the headers are empty. +@item existing-newsgroups +Check whether the newsgroups mentioned in the @code{Newsgroups} and +@code{Followup-To} headers exist. +@item valid-newsgroups +Check whether the @code{Newsgroups} and @code{Followup-to} headers +are valid syntactically. +@item repeated-newsgroups +Check whether the @code{Newsgroups} and @code{Followup-to} headers +contains repeated group names. +@item shorten-followup-to +Check whether to add a @code{Followup-to} header to shorten the number +of groups to post to. +@end table + +All these conditions are checked by default. + +@item message-ignored-news-headers +@vindex message-ignored-news-headers +Regexp of headers to be removed before posting. The default is@* +@samp{^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:}. + +@item message-default-news-headers +@vindex message-default-news-headers +This string is inserted at the end of the headers in all message +buffers that are initialized as news. + +@end table + + +@node News Variables +@section News Variables + +@table @code +@item message-send-news-function +@vindex message-send-news-function +Function used to send the current buffer as news. The default is +@code{message-send-news}. + +@item message-post-method +@vindex message-post-method +Method used for posting a prepared news message. + +@end table + + +@node Various Message Variables +@section Various Message Variables + +@table @code +@item message-signature-separator +@vindex message-signature-separator +Regexp matching the signature separator. It is @samp{^-- *$} by +default. + +@item mail-header-separator +@vindex mail-header-separator +String used to separate the headers from the body. It is @samp{--text +follows this line--} by default. + +@item message-directory +@vindex message-directory +Directory used by many mailey things. The default is @file{~/Mail/}. + +@item message-autosave-directory +@vindex message-autosave-directory +Directory where message buffers will be autosaved to. + +@item message-signature-setup-hook +@vindex message-signature-setup-hook +Hook run when initializing the message buffer. It is run after the +headers have been inserted but before the signature has been inserted. + +@item message-setup-hook +@vindex message-setup-hook +Hook run as the last thing when the message buffer has been initialized, +but before yanked text is inserted. + +@item message-header-setup-hook +@vindex message-header-setup-hook +Hook called narrowed to the headers after initializing the headers. + +For instance, if you're running Gnus and wish to insert a +@samp{Mail-Copies-To} header in all your news articles and all messages +you send to mailing lists, you could do something like the following: + +@lisp +(defun my-message-header-setup-hook () + (let ((group (or gnus-newsgroup-name ""))) + (when (or (message-fetch-field "newsgroups") + (gnus-group-find-parameter group 'to-address) + (gnus-group-find-parameter group 'to-list)) + (insert "Mail-Copies-To: never\n")))) + +(add-hook 'message-header-setup-hook 'my-message-header-setup-hook) +@end lisp + +@item message-send-hook +@vindex message-send-hook +Hook run before sending messages. + +If you want to add certain headers before sending, you can use the +@code{message-add-header} function in this hook. For instance: +@findex message-add-header + +@lisp +(add-hook 'message-send-hook 'my-message-add-content) +(defun my-message-add-content () + (message-add-header + "Mime-Version: 1.0" + "Content-Type: text/plain" + "Content-Transfer-Encoding: 7bit")) +@end lisp + +This function won't add the header if the header is already present. + +@item message-send-mail-hook +@vindex message-send-mail-hook +Hook run before sending mail messages. + +@item message-send-news-hook +@vindex message-send-news-hook +Hook run before sending news messages. + +@item message-sent-hook +@vindex message-sent-hook +Hook run after sending messages. + +@item message-mode-syntax-table +@vindex message-mode-syntax-table +Syntax table used in message mode buffers. + +@item message-send-method-alist +@vindex message-send-method-alist + +Alist of ways to send outgoing messages. Each element has the form + +@lisp +(TYPE PREDICATE FUNCTION) +@end lisp + +@table @var +@item type +A symbol that names the method. + +@item predicate +A function called without any parameters to determine whether the +message is a message of type @var{type}. + +@item function +A function to be called if @var{predicate} returns non-@code{nil}. +@var{function} is called with one parameter -- the prefix. +@end table + +@lisp +((news message-news-p message-send-via-news) + (mail message-mail-p message-send-via-mail)) +@end lisp + + + +@end table + + + +@node Sending Variables +@section Sending Variables + +@table @code + +@item message-fcc-handler-function +@vindex message-fcc-handler-function +A function called to save outgoing articles. This function will be +called with the name of the file to store the article in. The default +function is @code{rmail-output} which saves in Unix mailbox format. + +@item message-courtesy-message +@vindex message-courtesy-message +When sending combined messages, this string is inserted at the start of +the mailed copy. If the string contains the format spec @samp{%s}, the +newsgroups the article has been posted to will be inserted there. If +this variable is @code{nil}, no such courtesy message will be added. +The default value is @samp{"The following message is a courtesy copy of +an article\nthat has been posted to %s as well.\n\n"}. + +@end table + + +@node Message Buffers +@section Message Buffers + +Message will generate new buffers with unique buffer names when you +request a message buffer. When you send the message, the buffer isn't +normally killed off. Its name is changed and a certain number of old +message buffers are kept alive. + +@table @code +@item message-generate-new-buffers +@vindex message-generate-new-buffers +If non-@code{nil}, generate new buffers. The default is @code{t}. If +this is a function, call that function with three parameters: The type, +the to address and the group name. (Any of these may be @code{nil}.) +The function should return the new buffer name. + +@item message-max-buffers +@vindex message-max-buffers +This variable says how many old message buffers to keep. If there are +more message buffers than this, the oldest buffer will be killed. The +default is 10. If this variable is @code{nil}, no old message buffers +will ever be killed. + +@item message-send-rename-function +@vindex message-send-rename-function +After sending a message, the buffer is renamed from, for instance, +@samp{*reply to Lars*} to @samp{*sent reply to Lars*}. If you don't +like this, set this variable to a function that renames the buffer in a +manner you like. If you don't want to rename the buffer at all, you can +say: + +@lisp +(setq message-send-rename-function 'ignore) +@end lisp + +@item message-kill-buffer-on-exit +@findex message-kill-buffer-on-exit +If non-@code{nil}, kill the buffer immediately on exit. + +@end table + + +@node Message Actions +@section Message Actions + +When Message is being used from a news/mail reader, the reader is likely +to want to perform some task after the message has been sent. Perhaps +return to the previous window configuration or mark an article as +replied. + +@vindex message-kill-actions +@vindex message-postpone-actions +@vindex message-exit-actions +@vindex message-send-actions +The user may exit from the message buffer in various ways. The most +common is @kbd{C-c C-c}, which sends the message and exits. Other +possibilities are @kbd{C-c C-s} which just sends the message, @kbd{C-c +C-d} which postpones the message editing and buries the message buffer, +and @kbd{C-c C-k} which kills the message buffer. Each of these actions +have lists associated with them that contains actions to be executed: +@code{message-send-actions}, @code{message-exit-actions}, +@code{message-postpone-actions}, and @code{message-kill-actions}. + +Message provides a function to interface with these lists: +@code{message-add-action}. The first parameter is the action to be +added, and the rest of the arguments are which lists to add this action +to. Here's an example from Gnus: + +@lisp + (message-add-action + `(set-window-configuration ,(current-window-configuration)) + 'exit 'postpone 'kill) +@end lisp + +This restores the Gnus window configuration when the message buffer is +killed, postponed or exited. + +An @dfn{action} can be either: a normal function, or a list where the +@code{car} is a function and the @code{cdr} is the list of arguments, or +a form to be @code{eval}ed. + + +@node Compatibility +@chapter Compatibility +@cindex compatibility + +Message uses virtually only its own variables---older @code{mail-} +variables aren't consulted. To force Message to take those variables +into account, you can put the following in your @code{.emacs} file: + +@lisp +(require 'messcompat) +@end lisp + +This will initialize many Message variables from the values in the +corresponding mail variables. + + + +@node Index +@chapter Index +@printindex cp + +@node Key Index +@chapter Key Index +@printindex ky + +@summarycontents +@contents +@bye + +@c End: diff --git a/texi/postamble.tex b/texi/postamble.tex new file mode 100644 index 0000000..3b5f803 --- /dev/null +++ b/texi/postamble.tex @@ -0,0 +1,49 @@ +\gnuscleardoublepage + +\pagestyle{gnusindex} + +\renewcommand\indexname{Key Index} +\renewcommand{\gnuschaptername}{Key Index} +\input{gnus.kind} +\gnuscleardoublepage + +\renewcommand\indexname{Function and Variable Index} +\renewcommand{\gnuschaptername}{Function and Variable Index} +\input{gnus.gind} +\gnuscleardoublepage +\thispagestyle{empty} + +\renewcommand\indexname{Concept Index} +\renewcommand{\gnuschaptername}{Concept Index} +\input{gnus.cind} + +\mbox{} +%\thispagestyle{empty}\mbox{}\clearpage\thispagestyle{empty}\mbox{}\clearpage +\ifodd\count0\else\thispagestyle{empty}\clearpage\fi +\mbox{} +\thispagestyle{empty} +\vfill + +\begin{picture}(10,10) +\put(90,-10){\makebox(0,0)[tr]{\epsfig{figure=tmp/larsi.ps,height=3cm}}} +\end{picture} + +\hspace*{4cm}\parbox[t]{10cm}{ +This manual was written by Lars Magne Ingebrigtsen (b. 1968) who +resides in Oslo, Norway and poses as a student, but doesn't get much +studying done, for some strange reason or other. When not worshipping +at the altar of Emacs, he can often be found slouching on his couch +reading while bopping his head gently to some obscure music. He does +not have a cat. + +Graphics by Luis Fernandes. Set in Bembo and Futura. +} + +\clearpage +\mbox{} +\thispagestyle{empty} +\begin{picture}(500,500)(0,0) +\put(-35,325){\makebox(480,350)[tr]{\epsfig{figure=tmp/new-herd-section.ps}}} +\end{picture} + +\end{document} diff --git a/texi/refcard.tex b/texi/refcard.tex new file mode 100644 index 0000000..a701cd4 --- /dev/null +++ b/texi/refcard.tex @@ -0,0 +1,65 @@ +% Reference Card for (ding) Gnus, 3 twocolumn pages. +% To be processed with latex 2.09 +\def\Guide{Card}\def\guide{card} +\def\logoscale{0.25} +\def\sec{\section*} +\def\subsec{\subsection*} +\def\subsubsec{\subsubsection*} +\documentstyle{article} +\textwidth 7.26in \textheight 10in \topmargin -1.0in +% the same settings work for A4, although there is a bit of space at the +% top and bottom of the page. +\oddsidemargin -0.5in \evensidemargin -0.5in +\begin{document} +\twocolumn\scriptsize\pagestyle{empty} +\input{gnusref} + +% page 1, left column +\Title +\par +\vspace{0.5\baselineskip} +\Logo{refcard} +\vspace*{\fill} +\GroupLevels +\GroupMode +\pagebreak + +% page 1, right column +\Notes +\vspace*{\fill} +\GroupCommands +\pagebreak + +% page 2, left column +\SummaryMode +\Asubmap +\Bsubmap +\Gsubmap +\Hsubmap +\Tsubmap +\pagebreak + +% page 2, right column +\Msubmap +\Marks +\pagebreak + +% page 3 +\Osubmap +\Ssubmap +\Xsubmap +\Vsubmap +\SortSummary +\Wsubmap +\Zsubmap +\ArticleMode +\ServerMode + +% page 4 +\BrowseServer +\pagebreak +\onecolumn +\vspace*{\fill} +\CopyRight + +\end{document} diff --git a/texi/widget.texi b/texi/widget.texi new file mode 100644 index 0000000..b733a78 --- /dev/null +++ b/texi/widget.texi @@ -0,0 +1,1432 @@ +\input texinfo.tex + +@c %**start of header +@setfilename widget +@settitle The Emacs Widget Library +@iftex +@afourpaper +@headings double +@end iftex +@c %**end of header + +@node Top, Introduction, (dir), (dir) +@comment node-name, next, previous, up +@top The Emacs Widget Library + +Version: 1.82 + +@menu +* Introduction:: +* User Interface:: +* Programming Example:: +* Setting Up the Buffer:: +* Basic Types:: +* Sexp Types:: +* Widget Properties:: +* Defining New Widgets:: +* Widget Wishlist.:: +@end menu + +@node Introduction, User Interface, Top, Top +@comment node-name, next, previous, up +@section Introduction + +Most graphical user interface toolkits, such as Motif and XView, provide +a number of standard user interface controls (sometimes known as +`widgets' or `gadgets'). Emacs doesn't really support anything like +this, except for an incredible powerful text ``widget''. On the other +hand, Emacs does provide the necessary primitives to implement many +other widgets within a text buffer. The @code{widget} package +simplifies this task. + +The basic widgets are: + +@table @code +@item link +Areas of text with an associated action. Intended for hypertext links +embedded in text. +@item push-button +Like link, but intended for stand-alone buttons. +@item editable-field +An editable text field. It can be either variable or fixed length. +@item menu-choice +Allows the user to choose one of multiple options from a menu, each +option is itself a widget. Only the selected option will be visible in +the buffer. +@item radio-button-choice +Allows the user to choose one of multiple options by pushing radio +buttons. The options are implemented as widgets. All options will be +visible in the buffer. +@item item +A simple constant widget intended to be used in the @code{menu-choice} and +@code{radio-button-choice} widgets. +@item choice-item +An button item only intended for use in choices. When pushed, the user +will be asked to select another option from the choice widget. +@item toggle +A simple @samp{on}/@samp{off} switch. +@item checkbox +A checkbox (@samp{[ ]}/@samp{[X]}). +@item editable-list +Create an editable list. The user can insert or delete items in the +list. Each list item is itself a widget. +@end table + +Now of what possible use can support for widgets be in a text editor? +I'm glad you asked. The answer is that widgets are useful for +implementing forms. A @dfn{form} in emacs is a buffer where the user is +supposed to fill out a number of fields, each of which has a specific +meaning. The user is not supposed to change or delete any of the text +between the fields. Examples of forms in Emacs are the @file{forms} +package (of course), the customize buffers, the mail and news compose +modes, and the @sc{html} form support in the @file{w3} browser. + +The advantages for a programmer of using the @code{widget} package to +implement forms are: + +@enumerate +@item +More complex field than just editable text are supported. +@item +You can give the user immediate feedback if he enters invalid data in a +text field, and sometimes prevent entering invalid data. +@item +You can have fixed sized fields, thus allowing multiple field to be +lined up in columns. +@item +It is simple to query or set the value of a field. +@item +Editing happens in buffer, not in the mini-buffer. +@item +Packages using the library get a uniform look, making them easier for +the user to learn. +@item +As support for embedded graphics improve, the widget library will +extended to support it. This means that your code using the widget +library will also use the new graphic features by automatic. +@end enumerate + +In order to minimize the code that is loaded by users who does not +create any widgets, the code has been split in two files: + +@table @file +@item widget.el +This will declare the user variables, define the function +@code{widget-define}, and autoload the function @code{widget-create}. +@item wid-edit.el +Everything else is here, there is no reason to load it explicitly, as +it will be autoloaded when needed. +@end table + +@node User Interface, Programming Example, Introduction, Top +@comment node-name, next, previous, up +@section User Interface + +A form consist of read only text for documentation and some fields, +where each the fields contain two parts, as tag and a value. The tags +are used to identify the fields, so the documentation can refer to the +foo field, meaning the field tagged with @samp{Foo}. Here is an example +form: + +@example +Here is some documentation. + +Name: @i{My Name} @strong{Choose}: This option +Address: @i{Some Place +In some City +Some country.} + +See also @b{_other work_} for more information. + +Numbers: count to three below +@b{[INS]} @b{[DEL]} @i{One} +@b{[INS]} @b{[DEL]} @i{Eh, two?} +@b{[INS]} @b{[DEL]} @i{Five!} +@b{[INS]} + +Select multiple: + +@b{[X]} This +@b{[ ]} That +@b{[X]} Thus + +Select one: + +@b{(*)} One +@b{( )} Another One. +@b{( )} A Final One. + +@b{[Apply Form]} @b{[Reset Form]} +@end example + +The top level widgets in is example are tagged @samp{Name}, +@samp{Choose}, @samp{Address}, @samp{_other work_}, @samp{Numbers}, +@samp{Select multiple}, @samp{Select one}, @samp{[Apply Form]}, and +@samp{[Reset Form]}. There are basically two thing the user can do within +a form, namely editing the editable text fields and activating the +buttons. + +@subsection Editable Text Fields + +In the example, the value for the @samp{Name} is most likely displayed +in an editable text field, and so are values for each of the members of +the @samp{Numbers} list. All the normal Emacs editing operations are +available for editing these fields. The only restriction is that each +change you make must be contained within a single editable text field. +For example, capitalizing all text from the middle of one field to the +middle of another field is prohibited. + +Editing text fields are created by the @code{editable-field} widget. + +The editing text fields are highlighted with the +@code{widget-field-face} face, making them easy to find. + +@deffn Face widget-field-face +Face used for other editing fields. +@end deffn + +@subsection Buttons + +Some portions of the buffer have an associated @dfn{action}, which can +be @dfn{activated} by a standard key or mouse command. These portions +are called @dfn{buttons}. The default commands for activating a button +are: + +@table @kbd +@item @key{RET} +@deffn Command widget-button-press @var{pos} &optional @var{event} +Activate the button at @var{pos}, defaulting to point. +If point is not located on a button, activate the binding in +@code{widget-global-map} (by default the global map). +@end deffn + +@item mouse-2 +@deffn Command widget-button-click @var{event} +Activate the button at the location of the mouse pointer. If the mouse +pointer is located in an editable text field, activate the binding in +@code{widget-global-map} (by default the global map). +@end deffn +@end table + +There are several different kind of buttons, all of which are present in +the example: + +@table @emph +@item The Option Field Tags. +When you activate one of these buttons, you will be asked to choose +between a number of different options. This is how you edit an option +field. Option fields are created by the @code{menu-choice} widget. In +the example, @samp{@b{Choose}} is an option field tag. +@item The @samp{@b{[INS]}} and @samp{@b{[DEL]}} buttons. +Activating these will insert or delete elements from a editable list. +The list is created by the @code{editable-list} widget. +@item Embedded Buttons. +The @samp{@b{_other work_}} is an example of an embedded +button. Embedded buttons are not associated with a fields, but can serve +any purpose, such as implementing hypertext references. They are +usually created by the @code{link} widget. +@item The @samp{@b{[ ]}} and @samp{@b{[X]}} buttons. +Activating one of these will convert it to the other. This is useful +for implementing multiple-choice fields. You can create it wit +@item The @samp{@b{( )}} and @samp{@b{(*)}} buttons. +Only one radio button in a @code{radio-button-choice} widget can be selected at any +time. When you push one of the unselected radio buttons, it will be +selected and the previous selected radio button will become unselected. +@item The @samp{@b{[Apply Form]}} @samp{@b{[Reset Form]}} buttons. +These are explicit buttons made with the @code{push-button} widget. The main +difference from the @code{link} widget is that the buttons are will be +displayed as GUI buttons when possible. +enough. +@end table + +To make them easier to locate, buttons are emphasized in the buffer. + +@deffn Face widget-button-face +Face used for buttons. +@end deffn + +@defopt widget-mouse-face +Face used for buttons when the mouse pointer is above it. +@end defopt + +@subsection Navigation + +You can use all the normal Emacs commands to move around in a form +buffer, plus you will have these additional commands: + +@table @kbd +@item @key{TAB} +@deffn Command widget-forward &optional count +Move point @var{count} buttons or editing fields forward. +@end deffn +@item @key{M-TAB} +@deffn Command widget-backward &optional count +Move point @var{count} buttons or editing fields backward. +@end deffn +@end table + +@node Programming Example, Setting Up the Buffer, User Interface, Top +@comment node-name, next, previous, up +@section Programming Example + +Here is the code to implement the user interface example (see @ref{User +Interface}). + +@lisp +(require 'widget) + +(eval-when-compile + (require 'wid-edit)) + +(defvar widget-example-repeat) + +(defun widget-example () + "Create the widgets from the Widget manual." + (interactive) + (switch-to-buffer "*Widget Example*") + (kill-all-local-variables) + (make-local-variable 'widget-example-repeat) + (let ((inhibit-read-only t)) + (erase-buffer)) + (widget-insert "Here is some documentation.\n\nName: ") + (widget-create 'editable-field + :size 13 + "My Name") + (widget-create 'menu-choice + :tag "Choose" + :value "This" + :help-echo "Choose me, please!" + :notify (lambda (widget &rest ignore) + (message "%s is a good choice!" + (widget-value widget))) + '(item :tag "This option" :value "This") + '(choice-item "That option") + '(editable-field :menu-tag "No option" "Thus option")) + (widget-insert "Address: ") + (widget-create 'editable-field + "Some Place\nIn some City\nSome country.") + (widget-insert "\nSee also ") + (widget-create 'link + :notify (lambda (&rest ignore) + (widget-value-set widget-example-repeat + '("En" "To" "Tre")) + (widget-setup)) + "other work") + (widget-insert " for more information.\n\nNumbers: count to three below\n") + (setq widget-example-repeat + (widget-create 'editable-list + :entry-format "%i %d %v" + :notify (lambda (widget &rest ignore) + (let ((old (widget-get widget + ':example-length)) + (new (length (widget-value widget)))) + (unless (eq old new) + (widget-put widget ':example-length new) + (message "You can count to %d." new)))) + :value '("One" "Eh, two?" "Five!") + '(editable-field :value "three"))) + (widget-insert "\n\nSelect multiple:\n\n") + (widget-create 'checkbox t) + (widget-insert " This\n") + (widget-create 'checkbox nil) + (widget-insert " That\n") + (widget-create 'checkbox + :notify (lambda (&rest ignore) (message "Tickle")) + t) + (widget-insert " Thus\n\nSelect one:\n\n") + (widget-create 'radio-button-choice + :value "One" + :notify (lambda (widget &rest ignore) + (message "You selected %s" + (widget-value widget))) + '(item "One") '(item "Anthor One.") '(item "A Final One.")) + (widget-insert "\n") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (if (= (length (widget-value widget-example-repeat)) + 3) + (message "Congratulation!") + (error "Three was the count!"))) + "Apply Form") + (widget-insert " ") + (widget-create 'push-button + :notify (lambda (&rest ignore) + (widget-example)) + "Reset Form") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup)) +@end lisp + +@node Setting Up the Buffer, Basic Types, Programming Example, Top +@comment node-name, next, previous, up +@section Setting Up the Buffer + +Widgets are created with @code{widget-create}, which returns a +@dfn{widget} object. This object can be queried and manipulated by +other widget functions, until it is deleted with @code{widget-delete}. +After the widgets have been created, @code{widget-setup} must be called +to enable them. + +@defun widget-create type [ keyword argument ]@dots{} +Create and return a widget of type @var{type}. +The syntax for the @var{type} argument is described in @ref{Basic Types}. + +The keyword arguments can be used to overwrite the keyword arguments +that are part of @var{type}. +@end defun + +@defun widget-delete widget +Delete @var{widget} and remove it from the buffer. +@end defun + +@defun widget-setup +Setup a buffer to support widgets. + +This should be called after creating all the widgets and before allowing +the user to edit them. +@refill +@end defun + +If you want to insert text outside the widgets in the form, the +recommended way to do that is with @code{widget-insert}. + +@defun widget-insert +Insert the arguments, either strings or characters, at point. +The inserted text will be read only. +@end defun + +There is a standard widget keymap which you might find useful. + +@defvr Const widget-keymap +A keymap with the global keymap as its parent.@* +@key{TAB} and @kbd{C-@key{TAB}} are bound to @code{widget-forward} and +@code{widget-backward}, respectively. @kbd{@key{RET}} and @kbd{mouse-2} +are bound to @code{widget-button-press} and +@code{widget-button-}.@refill +@end defvr + +@defvar widget-global-map +Keymap used by @code{widget-button-press} and @code{widget-button-click} +when not on a button. By default this is @code{global-map}. +@end defvar + +@node Basic Types, Sexp Types, Setting Up the Buffer, Top +@comment node-name, next, previous, up +@section Basic Types + +The syntax of a type specification is given below: + +@example +NAME ::= (NAME [KEYWORD ARGUMENT]... ARGS) + | NAME +@end example + +Where, @var{name} is a widget name, @var{keyword} is the name of a +property, @var{argument} is the value of the property, and @var{args} +are interpreted in a widget specific way. + +There following keyword arguments that apply to all widgets: + +@table @code +@item :value +The initial value for widgets of this type. + +@item :format +This string will be inserted in the buffer when you create a widget. +The following @samp{%} escapes are available: + +@table @samp +@item %[ +@itemx %] +The text inside will be marked as a button. + +@item %@{ +@itemx %@} +The text inside will be displayed with the face specified by +@code{:sample-face}. + +@item %v +This will be replaces with the buffer representation of the widgets +value. What this is depends on the widget type. + +@item %d +Insert the string specified by @code{:doc} here. + +@item %h +Like @samp{%d}, with the following modifications: If the documentation +string is more than one line, it will add a button which will toggle +between showing only the first line, and showing the full text. +Furthermore, if there is no @code{:doc} property in the widget, it will +instead examine the @code{:documentation-property} property. If it is a +lambda expression, it will be called with the widget's value as an +argument, and the result will be used as the documentation text. + +@item %t +Insert the string specified by @code{:tag} here, or the @code{princ} +representation of the value if there is no tag. + +@item %% +Insert a literal @samp{%}. +@end table + +@item :button-face +Face used to highlight text inside %[ %] in the format. + +@item :doc +The string inserted by the @samp{%d} escape in the format +string. + +@item :tag +The string inserted by the @samp{%t} escape in the format +string. + +@item :tag-glyph +Name of image to use instead of the string specified by `:tag' on +Emacsen that supports it. + +@item :help-echo +Message displayed whenever you move to the widget with either +@code{widget-forward} or @code{widget-backward}. + +@item :indent +An integer indicating the absolute number of spaces to indent children +of this widget. + +@item :offset +An integer indicating how many extra spaces to add to the widget's +grandchildren compared to this widget. + +@item :extra-offset +An integer indicating how many extra spaces to add to the widget's +children compared to this widget. + +@item :notify +A function called each time the widget or a nested widget is changed. +The function is called with two or three arguments. The first argument +is the widget itself, the second argument is the widget that was +changed, and the third argument is the event leading to the change, if +any. + +@item :menu-tag +Tag used in the menu when the widget is used as an option in a +@code{menu-choice} widget. + +@item :menu-tag-get +Function used for finding the tag when the widget is used as an option +in a @code{menu-choice} widget. By default, the tag used will be either the +@code{:menu-tag} or @code{:tag} property if present, or the @code{princ} +representation of the @code{:value} property if not. + +@item :match +Should be a function called with two arguments, the widget and a value, +and returning non-nil if the widget can represent the specified value. + +@item :validate +A function which takes a widget as an argument, and return nil if the +widgets current value is valid for the widget. Otherwise, it should +return the widget containing the invalid data, and set that widgets +@code{:error} property to a string explaining the error. + +@item :tab-order +Specify the order in which widgets are traversed with +@code{widget-forward} or @code{widget-backward}. This is only partially +implemented. + +@enumerate a +@item +Widgets with tabbing order @code{-1} are ignored. + +@item +(Unimplemented) When on a widget with tabbing order @var{n}, go to the +next widget in the buffer with tabbing order @var{n+1} or @code{nil}, +whichever comes first. + +@item +When on a widget with no tabbing order specified, go to the next widget +in the buffer with a positive tabbing order, or @code{nil} +@end enumerate + +@item :parent +The parent of a nested widget (e.g. a @code{menu-choice} item or an +element of a @code{editable-list} widget). + +@item :sibling-args +This keyword is only used for members of a @code{radio-button-choice} or +@code{checklist}. The value should be a list of extra keyword +arguments, which will be used when creating the @code{radio-button} or +@code{checkbox} associated with this item. + +@end table + +@deffn {User Option} widget-glyph-directory +Directory where glyphs are found. +Widget will look here for a file with the same name as specified for the +image, with either a @samp{.xpm} (if supported) or @samp{.xbm} extension. +@end deffn + +@deffn{User Option} widget-glyph-enable +If non-nil, allow glyphs to appear on displayes where they are supported. +@end deffn + + +@menu +* link:: +* url-link:: +* info-link:: +* push-button:: +* editable-field:: +* text:: +* menu-choice:: +* radio-button-choice:: +* item:: +* choice-item:: +* toggle:: +* checkbox:: +* checklist:: +* editable-list:: +@end menu + +@node link, url-link, Basic Types, Basic Types +@comment node-name, next, previous, up +@subsection The @code{link} Widget + +Syntax: + +@example +TYPE ::= (link [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. + +@node url-link, info-link, link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{url-link} Widget + +Syntax: + +@example +TYPE ::= (url-link [KEYWORD ARGUMENT]... URL) +@end example + +When this link is activated, the @sc{www} browser specified by +@code{browse-url-browser-function} will be called with @var{url}. + +@node info-link, push-button, url-link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{info-link} Widget + +Syntax: + +@example +TYPE ::= (info-link [KEYWORD ARGUMENT]... ADDRESS) +@end example + +When this link is activated, the build-in info browser is started on +@var{address}. + +@node push-button, editable-field, info-link, Basic Types +@comment node-name, next, previous, up +@subsection The @code{push-button} Widget + +Syntax: + +@example +TYPE ::= (push-button [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. + +The following extra properties are recognized. + +@table @code +@item :text-format +The format string used when the push button cannot be displayed +graphically. There are two escapes, @code{%s}, which must be present +exactly once, will be substituted with the tag, and @code{%%} will be +substituted with a singe @samp{%}. +@end table + +By default the tag will be shown in brackets. + +@node editable-field, text, push-button, Basic Types +@comment node-name, next, previous, up +@subsection The @code{editable-field} Widget + +Syntax: + +@example +TYPE ::= (editable-field [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in +field. This widget will match all string values. + +The following extra properties are recognized. + +@table @code +@item :size +The width of the editable field.@* +By default the field will reach to the end of the line. + +@item :value-face +Face used for highlighting the editable field. Default is +@code{widget-field-face}. + +@item :secret +Character used to display the value. You can set this to e.g. @code{?*} +if the field contains a password or other secret information. By +default, the value is not secret. + +@item :valid-regexp +By default the @code{:validate} function will match the content of the +field with the value of this attribute. The default value is @code{""} +which matches everything. + +@item :keymap +Keymap used in the editable field. The default value is +@code{widget-field-keymap}, which allows you to use all the normal +editing commands, even if the buffers major mode supress some of them. +Pressing return activates the function specified by @code{:activate}. + +@item :hide-front-space +@itemx :hide-rear-space +In order to keep track of the editable field, emacs places an invisible +space character in front of the field, and for fixed sized fields also +in the rear end of the field. For fields that extent to the end of the +line, the terminating linefeed serves that purpose instead. + +Emacs will try to make the spaces intangible when it is safe to do so. +Intangible means that the cursor motion commands will skip over the +character as if it didn't exist. This is safe to do when the text +preceding or following the widget cannot possible change during the +lifetime of the @code{editable-field} widget. The preferred way to tell +Emacs this, is to add text to the @code{:format} property around the +value. For example @code{:format "Tag: %v "}. + +You can overwrite the internal safety check by setting the +@code{:hide-front-space} or @code{:hide-rear-space} properties to +non-nil. This is not recommended. For example, @emph{all} text that +belongs to a widget (i.e. is created from its @code{:format} string) will +change whenever the widget changes its value. + +@end table + +@node text, menu-choice, editable-field, Basic Types +@comment node-name, next, previous, up +@subsection The @code{text} Widget + +This is just like @code{editable-field}, but intended for multiline text +fields. The default @code{:keymap} is @code{widget-text-keymap}, which +does not rebind the return key. + +@node menu-choice, radio-button-choice, text, Basic Types +@comment node-name, next, previous, up +@subsection The @code{menu-choice} Widget + +Syntax: + +@example +TYPE ::= (menu-choice [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each possible choice. The widgets +value of will be the value of the chosen @var{type} argument. This +widget will match any value that matches at least one of the specified +@var{type} arguments. + +@table @code +@item :void +Widget type used as a fallback when the value does not match any of the +specified @var{type} arguments. + +@item :case-fold +Set this to nil if you don't want to ignore case when prompting for a +choice through the minibuffer. + +@item :children +A list whose car is the widget representing the currently chosen type in +the buffer. + +@item :choice +The current chosen type + +@item :args +The list of types. +@end table + +@node radio-button-choice, item, menu-choice, Basic Types +@comment node-name, next, previous, up +@subsection The @code{radio-button-choice} Widget + +Syntax: + +@example +TYPE ::= (radio-button-choice [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each possible choice. The widgets +value of will be the value of the chosen @var{type} argument. This +widget will match any value that matches at least one of the specified +@var{type} arguments. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +Replaced with the buffer representation of the @var{type} widget. +@item %b +Replace with the radio button. +@item %% +Insert a literal @samp{%}. +@end table + +@item button-args +A list of keywords to pass to the radio buttons. Useful for setting +e.g. the @samp{:help-echo} for each button. + +@item :buttons +The widgets representing the radio buttons. + +@item :children +The widgets representing each type. + +@item :choice +The current chosen type + +@item :args +The list of types. +@end table + +You can add extra radio button items to a @code{radio-button-choice} +widget after it has been created with the function +@code{widget-radio-add-item}. + +@defun widget-radio-add-item widget type +Add to @code{radio-button-choice} widget @var{widget} a new radio button item of type +@var{type}. +@end defun + +Please note that such items added after the @code{radio-button-choice} +widget has been created will @strong{not} be properly destructed when +you call @code{widget-delete}. + +@node item, choice-item, radio-button-choice, Basic Types +@comment node-name, next, previous, up +@subsection The @code{item} Widget + +Syntax: + +@example +ITEM ::= (item [KEYWORD ARGUMENT]... VALUE) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer. This widget will only match the specified value. + +@node choice-item, toggle, item, Basic Types +@comment node-name, next, previous, up +@subsection The @code{choice-item} Widget + +Syntax: + +@example +ITEM ::= (choice-item [KEYWORD ARGUMENT]... VALUE) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property. The value should be a string, which will be inserted in the +buffer as a button. Activating the button of a @code{choice-item} is +equivalent to activating the parent widget. This widget will only match +the specified value. + +@node toggle, checkbox, choice-item, Basic Types +@comment node-name, next, previous, up +@subsection The @code{toggle} Widget + +Syntax: + +@example +TYPE ::= (toggle [KEYWORD ARGUMENT]...) +@end example + +The widget has two possible states, `on' and `off', which corresponds to +a @code{t} or @code{nil} value. + +The following extra properties are recognized. + +@table @code +@item :on +String representing the `on' state. By default the string @samp{on}. +@item :off +String representing the `off' state. By default the string @samp{off}. +@item :on-glyph +Name of a glyph to be used instead of the `:on' text string, on emacsen +that supports it. +@item :off-glyph +Name of a glyph to be used instead of the `:off' text string, on emacsen +that supports it. +@end table + +@node checkbox, checklist, toggle, Basic Types +@comment node-name, next, previous, up +@subsection The @code{checkbox} Widget + +The widget has two possible states, `selected' and `unselected', which +corresponds to a @code{t} or @code{nil} value. + +Syntax: + +@example +TYPE ::= (checkbox [KEYWORD ARGUMENT]...) +@end example + +@node checklist, editable-list, checkbox, Basic Types +@comment node-name, next, previous, up +@subsection The @code{checklist} Widget + +Syntax: + +@example +TYPE ::= (checklist [KEYWORD ARGUMENT]... TYPE ... ) +@end example + +The @var{type} arguments represents each checklist item. The widgets +value of will be a list containing the value of each ticked @var{type} +argument. The checklist widget will match a list whose elements all +matches at least one of the specified @var{type} arguments. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +Replaced with the buffer representation of the @var{type} widget. +@item %b +Replace with the checkbox. +@item %% +Insert a literal @samp{%}. +@end table + +@item button-args +A list of keywords to pass to the checkboxes. Useful for setting +e.g. the @samp{:help-echo} for each checkbox. + +@item :buttons +The widgets representing the checkboxes. + +@item :children +The widgets representing each type. + +@item :args +The list of types. +@end table + +@node editable-list, , checklist, Basic Types +@comment node-name, next, previous, up +@subsection The @code{editable-list} Widget + +Syntax: + +@example +TYPE ::= (editable-list [KEYWORD ARGUMENT]... TYPE) +@end example + +The value is a list, where each member represent one widget of type +@var{type}. + +The following extra properties are recognized. + +@table @code +@item :entry-format +This string will be inserted for each entry in the list. +The following @samp{%} escapes are available: +@table @samp +@item %v +This will be replaced with the buffer representation of the @var{type} +widget. +@item %i +Insert the @b{[INS]} button. +@item %d +Insert the @b{[DEL]} button. +@item %% +Insert a literal @samp{%}. +@end table + +@item :insert-button-args +A list of keyword arguments to pass to the insert buttons. + +@item :delete-button-args +A list of keyword arguments to pass to the delete buttons. + +@item :append-button-args +A list of keyword arguments to pass to the trailing insert button. + + +@item :buttons +The widgets representing the insert and delete buttons. + +@item :children +The widgets representing the elements of the list. + +@item :args +List whose car is the type of the list elements. + +@end table + +@node Sexp Types, Widget Properties, Basic Types, Top +@comment +@section Sexp Types + +A number of widgets for editing s-expressions (lisp types) are also +available. These basically fall in three categories: @dfn{atoms}, +@dfn{composite types}, and @dfn{generic}. + +@menu +* generic:: +* atoms:: +* composite:: +@end menu + +@node generic, atoms, Sexp Types, Sexp Types +@comment node-name, next, previous, up +@subsection The Generic Widget. + +The @code{const} and @code{sexp} widgets can contain any lisp +expression. In the case of the @code{const} widget the user is +prohibited from editing edit it, which is mainly useful as a component +of one of the composite widgets. + +The syntax for the generic widgets is + +@example +TYPE ::= (const [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property and can be any s-expression. + +@deffn Widget const +This will display any valid s-expression in an immutable part of the +buffer. +@end deffn + +@deffn Widget sexp +This will allow you to edit any valid s-expression in an editable buffer +field. + +The @code{sexp} widget takes the same keyword arguments as the +@code{editable-field} widget. +@end deffn + +@node atoms, composite, generic, Sexp Types +@comment node-name, next, previous, up +@subsection Atomic Sexp Widgets. + +The atoms are s-expressions that does not consist of other +s-expressions. A string is an atom, while a list is a composite type. +You can edit the value of an atom with the following widgets. + +The syntax for all the atoms are + +@example +TYPE ::= (NAME [KEYWORD ARGUMENT]... [ VALUE ]) +@end example + +The @var{value}, if present, is used to initialize the @code{:value} +property and must be an expression of the same type as the widget. +I.e. the string widget can only be initialized with a string. + +All the atom widgets take the same keyword arguments as the @code{editable-field} +widget. + +@deffn Widget string +Allows you to edit a string in an editable field. +@end deffn + +@deffn Widget file +Allows you to edit a file name in an editable field. You you activate +the tag button, you can edit the file name in the mini-buffer with +completion. + +Keywords: +@table @code +@item :must-match +If this is set to non-nil, only existing file names will be allowed in +the minibuffer. +@end table +@end deffn + +@deffn Widget directory +Allows you to edit a directory name in an editable field. +Similar to the @code{file} widget. +@end deffn + +@deffn Widget symbol +Allows you to edit a lisp symbol in an editable field. +@end deffn + +@deffn Widget integer +Allows you to edit an integer in an editable field. +@end deffn + +@deffn Widget number +Allows you to edit a number in an editable field. +@end deffn + +@deffn Widget boolean +Allows you to edit a boolean. In lisp this means a variable which is +either nil meaning false, or non-nil meaning true. +@end deffn + + +@node composite, , atoms, Sexp Types +@comment node-name, next, previous, up +@subsection Composite Sexp Widgets. + +The syntax for the composite are + +@example +TYPE ::= (NAME [KEYWORD ARGUMENT]... COMPONENT...) +@end example + +Where each @var{component} must be a widget type. Each component widget +will be displayed in the buffer, and be editable to the user. + +@deffn Widget cons +The value of a @code{cons} widget is a cons-cell where the car is the +value of the first component and the cdr is the value of the second +component. There must be exactly two components. +@end deffn + +@deffn Widget lisp +The value of a @code{lisp} widget is a list containing the value of +each of its component. +@end deffn + +@deffn Widget vector +The value of a @code{vector} widget is a vector containing the value of +each of its component. +@end deffn + +The above suffice for specifying fixed size lists and vectors. To get +variable length lists and vectors, you can use a @code{choice}, +@code{set} or @code{repeat} widgets together with the @code{:inline} +keywords. If any component of a composite widget has the @code{:inline} +keyword set, its value must be a list which will then be spliced into +the composite. For example, to specify a list whose first element must +be a file name, and whose remaining arguments should either by the +symbol @code{t} or two files, you can use the following widget +specification: + +@example +(list file + (choice (const t) + (list :inline t + :value ("foo" "bar") + string string))) +@end example + +The value of a widget of this type will either have the form +@samp{(file t)} or @code{(file string string)}. + +This concept of inline is probably hard to understand. It was certainly +hard to implement so instead of confuse you more by trying to explain it +here, I'll just suggest you meditate over it for a while. + +@deffn Widget choice +Allows you to edit a sexp which may have one of fixed set of types. It +is currently implemented with the @code{choice-menu} basic widget, and +has a similar syntax. +@end deffn + +@deffn Widget set +Allows you to specify a type which must be a list whose elements all +belong to given set. The elements of the list is not significant. This +is implemented on top of the @code{checklist} basic widget, and has a +similar syntax. +@end deffn + +@deffn Widget repeat +Allows you to specify a variable length list whose members are all of +the same type. Implemented on top of the `editable-list' basic widget, +and has a similar syntax. +@end deffn + +@node Widget Properties, Defining New Widgets, Sexp Types, Top +@comment node-name, next, previous, up +@section Properties + +You can examine or set the value of a widget by using the widget object +that was returned by @code{widget-create}. + +@defun widget-value widget +Return the current value contained in @var{widget}. +It is an error to call this function on an uninitialized widget. +@end defun + +@defun widget-value-set widget value +Set the value contained in @var{widget} to @var{value}. +It is an error to call this function with an invalid @var{value}. +@end defun + +@strong{Important:} You @emph{must} call @code{widget-setup} after +modifying the value of a widget before the user is allowed to edit the +widget again. It is enough to call @code{widget-setup} once if you +modify multiple widgets. This is currently only necessary if the widget +contains an editing field, but may be necessary for other widgets in the +future. + +If your application needs to associate some information with the widget +objects, for example a reference to the item being edited, it can be +done with @code{widget-put} and @code{widget-get}. The property names +must begin with a @samp{:}. + +@defun widget-put widget property value +In @var{widget} set @var{property} to @var{value}. +@var{property} should be a symbol, while @var{value} can be anything. +@end defun + +@defun widget-get widget property +In @var{widget} return the value for @var{property}. +@var{property} should be a symbol, the value is what was last set by +@code{widget-put} for @var{property}. +@end defun + +@defun widget-member widget property +Non-nil if @var{widget} has a value (even nil) for property @var{property}. +@end defun + +Occasionally it can be useful to know which kind of widget you have, +i.e. the name of the widget type you gave when the widget was created. + +@defun widget-type widget +Return the name of @var{widget}, a symbol. +@end defun + +Widgets can be in two states: active, which means they are modifiable by +the user, or inactive, which means they cannot be modified by the user. +You can query or set the state with the following code: + +@lisp +;; Examine if @var{widget} is active or not. +(if (widget-apply @var{widget} :active) + (message "Widget is active.") + (message "Widget is inactive.") + +;; Make @var{widget} inactive. +(widget-apply @var{widget} :deactivate) + +;; Make @var{widget} active. +(widget-apply @var{widget} :activate) +@end lisp + +A widget is inactive if itself, or any of its ancestors (found by +following the @code{:parent} link) have been deactivated. To make sure +a widget is really active, you must therefore activate both itself, and +all its ancestors. + +@lisp +(while widget + (widget-apply widget :activate) + (setq widget (widget-get widget :parent))) +@end lisp + +You can check if a widget has been made inactive by examining the value +of @code{:inactive} keyword. If this is non-nil, the widget itself has +been deactivated. This is different from using the @code{:active} +keyword, in that the later tell you if the widget @strong{or} any of its +ancestors have been deactivated. Do not attempt to set the +@code{:inactive} keyword directly. Use the @code{:activate} +@code{:deactivated} keywords instead. + + +@node Defining New Widgets, Widget Wishlist., Widget Properties, Top +@comment node-name, next, previous, up +@section Defining New Widgets + +You can define specialized widgets with @code{define-widget}. It allows +you to create a shorthand for more complex widgets, including specifying +component widgets and default new default values for the keyword +arguments. + +@defun widget-define name class doc &rest args +Define a new widget type named @var{name} from @code{class}. + +@var{name} and class should both be symbols, @code{class} should be one +of the existing widget types. + +The third argument @var{DOC} is a documentation string for the widget. + +After the new widget has been defined, the following two calls will +create identical widgets: + +@itemize @bullet +@item +@lisp +(widget-create @var{name}) +@end lisp + +@item +@lisp +(apply widget-create @var{class} @var{args}) +@end lisp +@end itemize + +@end defun + +Using @code{widget-define} does just store the definition of the widget +type in the @code{widget-type} property of @var{name}, which is what +@code{widget-create} uses. + +If you just want to specify defaults for keywords with no complex +conversions, you can use @code{identity} as your conversion function. + +The following additional keyword arguments are useful when defining new +widgets: +@table @code +@item :convert-widget +Function to convert a widget type before creating a widget of that +type. It takes a widget type as an argument, and returns the converted +widget type. When a widget is created, this function is called for the +widget type and all the widgets parent types, most derived first. + +@item :value-to-internal +Function to convert the value to the internal format. The function +takes two arguments, a widget and an external value, and returns the +internal value. The function is called on the present @code{:value} +when the widget is created, and on any value set later with +@code{widget-value-set}. + +@item :value-to-external +Function to convert the value to the external format. The function +takes two arguments, a widget and an internal value, and returns the +internal value. The function is called on the present @code{:value} +when the widget is created, and on any value set later with +@code{widget-value-set}. + +@item :create +Function to create a widget from scratch. The function takes one +argument, a widget type, and create a widget of that type, insert it in +the buffer, and return a widget object. + +@item :delete +Function to delete a widget. The function takes one argument, a widget, +and should remove all traces of the widget from the buffer. + +@item :value-create +Function to expand the @samp{%v} escape in the format string. It will +be called with the widget as its argument. Should +insert a representation of the widgets value in the buffer. + +@item :value-delete +Should remove the representation of the widgets value from the buffer. +It will be called with the widget as its argument. It doesn't have to +remove the text, but it should release markers and delete nested widgets +if such has been used. + +@item :format-handler +Function to handle unknown @samp{%} escapes in the format string. It +will be called with the widget and the escape character as arguments. +You can set this to allow your widget to handle non-standard escapes. + +You should end up calling @code{widget-default-format-handler} to handle +unknown escape sequences, which will handle the @samp{%h} and any future +escape sequences, as well as give an error for unknown escapes. +@end table + +If you want to define a new widget from scratch, use the @code{default} +widget as its base. + +@deffn Widget default [ keyword argument ] +Widget used as a base for other widgets. + +It provides most of the functionality that is referred to as ``by +default'' in this text. +@end deffn + +@node Widget Wishlist., , Defining New Widgets, Top +@comment node-name, next, previous, up +@section Wishlist. + +@itemize @bullet +@item +It should be possible to add or remove items from a list with @kbd{C-k} +and @kbd{C-o} (suggested by @sc{rms}). + +@item +The @samp{[INS]} and @samp{[DEL]} buttons should be replaced by a single +dash (@samp{-}). The dash should be a button that, when activated, ask +whether you want to add or delete an item (@sc{rms} wanted to git rid of +the ugly buttons, the dash is my idea). + +@item +Widgets such as @code{file} and @code{symbol} should prompt with completion. + +@item +The @code{menu-choice} tag should be prettier, something like the abbreviated +menus in Open Look. + +@item +The functions used in many widgets, like +@code{widget-item-convert-widget}, should not have names that are +specific to the first widget where I happended to use them. + +@item +Flag to make @code{widget-move} skip a specified button. + +@item +Document `helper' functions for defining new widgets. + +@item +Activate the item this is below the mouse when the button is +released, not the item this is below the mouse when the button is +pressed. Dired and grep gets this right. Give feedback if possible. + +@item +Use @samp{@@deffn Widget} to document widgets. + +@item +Document global keywords in one place. + +Document keywords particular to a specific widget in the widget +definition. + +Document the `default' widget first. + +Split, when needed, keywords into those useful for normal +customization, those primarily useful when deriving, and those who +represent runtime information. + +@item +Figure out terminology and @sc{api} for the class/type/object/super +stuff. + +Perhaps the correct model is delegation? + +@item +Document @code{widget-browse}. + +@item +Make indentation work with glyphs and propertional fonts. + +@item +Add object and class hierarchies to the browser. + +@end itemize + +@contents +@bye