mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-26 07:33:47 +00:00
Code Issues Releases Activity

Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523

Browse Source 
Merge from emacs--gnus--5.10, gnus--rel--5.10

Patches applied:

 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0
   tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464

 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1
   Import from CVS branch gnus-5_10-branch

 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2
   Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0

 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3
   Merge from gnus--rel--5.10

 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4
   Merge from gnus--rel--5.10

 * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18
   Update from CVS

 * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19
   Remove autoconf-generated files from archive

 * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20
   Update from CVS
This commit is contained in:
Miles Bader 2004-09-04 13:13:48 +00:00
parent 2a223f35db
commit 23f87bede0
204 changed files with 83156 additions and 28873 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
ChangeLog
View File

@ -6,6 +6,12 @@
* config.bat: Update URLs in the comments.
2004-08-02 Reiner Steib <Reiner.Steib@gmx.de>
* Makefile.in (install-arch-indep): Added pgg and sieve.
* info/.cvsignore: Added pgg and sieve.
2004-07-05 Andreas Schwab <schwab@suse.de>
* Makefile.in (install-arch-indep): Remove .arch-inventory files.

4
Makefile.in
View File

@ -475,7 +475,7 @@ install-arch-indep: mkdir info
chmod a+r ${infodir}/dir); \
fi; \
cd ${srcdir}/info ; \
for f in ada-mode* autotype* calc* ccmode* cl* dired-x* ebrowse* ediff* efaq* eintr* elisp* emacs* emacs-xtra* eshell* eudc* flymake* forms* gnus* idlwave* info* message* mh-e* pcl-cvs* reftex* sc* ses* speedbar* tramp* vip* widget* woman* smtpmail*; do \
for f in ada-mode* autotype* calc* ccmode* cl* dired-x* ebrowse* ediff* efaq* eintr* elisp* emacs* emacs-mime* emacs-xtra* eshell* eudc* flymake* forms* gnus* idlwave* info* message* mh-e* pcl-cvs* pgg* reftex* sc* ses* sieve* speedbar* tramp* vip* widget* woman* smtpmail*; do \
(cd $${thisdir}; \
${INSTALL_DATA} ${srcdir}/info/$$f ${infodir}/$$f; \
chmod a+r ${infodir}/$$f); \
@ -485,7 +485,7 @@ install-arch-indep: mkdir info
thisdir=`/bin/pwd`; \
if [ `(cd ${srcdir}/info && /bin/pwd)` != `(cd ${infodir} && /bin/pwd)` ]; \
then \
for f in ada-mode autotype calc ccmode cl dired-x ebrowse ediff efaq elisp eintr emacs emacs-mime emacs-xtra eshell eudc flymake forms gnus idlwave info message mh-e pcl-cvs reftex sc ses speedbar tramp vip viper widget woman smtpmail; do \
for f in ada-mode autotype calc ccmode cl dired-x ebrowse ediff efaq elisp eintr emacs emacs-mime emacs-xtra eshell eudc flymake forms gnus idlwave info message mh-e pcl-cvs pgg reftex sc ses sieve speedbar tramp vip viper widget woman smtpmail; do \
(cd $${thisdir}; \
${INSTALL_INFO} --info-dir=${infodir} ${infodir}/$$f); \
done; \

12
etc/ChangeLog
View File

@ -46,6 +46,18 @@
* NEWS: Document all new tutorials.
2004-08-05 Reiner Steib <Reiner.Steib@gmx.de>
* GNUS-NEWS: Import from the v5_10 branch of the Gnus repository.
* NEWS (Gnus package): Gnus includes Sieve and PGG. Gnus changes
are described in GNUS-NEWS.
2004-08-02 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.xpm, gnus-pointer.xbm, gnus-pointer.xpm: Import from the
v5_10 branch of the Gnus repository.
2004-07-14 Luc Teirlinck <teirllm@auburn.edu>
* MORE.STUFF: Tramp is now distributed with Emacs.

545
etc/GNUS-NEWS Normal file
View File

@ -0,0 +1,545 @@
GNUS NEWS -- history of user-visible changes.
Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
See the end for copying conditions.
Please send Gnus bug reports to bugs@gnus.org.
For older news, see Gnus info node "New Features".
* Changes in Oort Gnus
** `F' (`gnus-article-followup-with-original') and `R'
(`gnus-article-reply-with-original') only yank the text in the region if the
region is active.
** `gnus-group-read-ephemeral-group' can be called interactively, using `G M'.
** In draft groups, `e' is now bound to `gnus-draft-edit-message'.
Use `B w' for `gnus-summary-edit-article' instead.
** The revised Gnus FAQ is included in the manual.
See the info node "Frequently Asked Questions".
** Upgrading from previous (stable) version if you have used Oort.
If you have tried Oort (the unstable Gnus branch leading to this
release) but went back to a stable version, be careful when upgrading
to this version. In particular, you will probably want to remove all
.marks (nnml) and .mrk (nnfolder) files, so that flags are read from
your ~/.newsrc.eld instead of from the .marks/.mrk file where this
release store flags. See a later entry for more information about
marks. Note that downgrading isn't safe in general.
** Article Buttons
More buttons for URLs, mail addresses, Message-IDs, Info links, man pages and
Emacs or Gnus related references, see the info node "Article Buttons". The
variables `gnus-button-*-level' can be used to control the appearance of all
article buttons, see the info node "Article Button Levels".
** Dired integration
`gnus-dired-minor-mode' installs key bindings in dired buffers to send a file
as an attachment (`C-c C-m C-a'), open a file using the approriate mailcap
entry (`C-c C-m C-l'), and print a file using the mailcap entry (`C-c C-m
C-p'). See the info node "Other modes".
** Gnus can display RSS newsfeeds as a newsgroup. To get started do `B
nnrss RET RET' in the Group buffer.
** Single-part yenc encoded attachments can be decoded.
** Picons
The picons code has been reimplemented to work in Emacs 21 -- some of
the previous options have been removed or renamed.
Picons are small "personal icons" representing users, domain and
newsgroups, which can be displayed in the Article buffer. To enable
picons, install the picons database from
http://www.cs.indiana.edu/picons/ftp/index.html
and point `gnus-picon-databases' to that location.
** If the new option `gnus-treat-body-boundary' is `head', a boundary
line is drawn at the end of the headers.
** Retrieval of charters and control messages
There are new commands for fetching newsgroup charters (`H c') and
control messages (`H C').
** Delayed articles
You can delay the sending of a message with `C-c C-j' in the Message
buffer. The messages are delivered at specified time. This is useful
for sending yourself reminders. Setup with (gnus-delay-initialize).
** If `auto-compression-mode' is enabled, attachments are automatically
decompressed when activated.
** If the new option `nnml-use-compressed-files' is non-nil,
the nnml back end allows compressed message files.
** Signed article headers (X-PGP-Sig) can be verified with `W p'.
** The Summary Buffer uses an arrow in the fringe to indicate the
current article in Emacs 21 running on a graphical display. Customize
`gnus-summary-display-arrow' to disable it.
** Warn about email replies to news
Do you often find yourself replying to news by email by mistake? Then
the new option `gnus-confirm-mail-reply-to-news' is just the thing for
you.
** If the new option `gnus-summary-display-while-building' is non-nil,
the summary buffer is shown and updated as it's being built.
** The new `recent' mark "." indicates newly arrived messages (as
opposed to old but unread messages).
** The new option `gnus-gcc-mark-as-read' automatically marks
Gcc articles as read.
** The nndoc back end now supports mailman digests and exim bounces.
** Gnus supports RFC 2369 mailing list headers, and adds a number of
related commands in mailing list groups.
** The Date header can be displayed in a format that can be read aloud
in English, see `gnus-treat-date-english'.
** The envelope sender address can be customized when using Sendmail, see
`message-sendmail-envelope-from'.
** diffs are automatically highlighted in groups matching
`mm-uu-diff-groups-regexp'
** TLS wrapper shipped with Gnus
TLS/SSL is now supported in IMAP and NNTP via tls.el and GNUTLS. The
old TLS/SSL support via (external third party) ssl.el and OpenSSL
still works.
** New make.bat for compiling and installing Gnus under MS Windows
Use make.bat if you want to install Gnus under MS Windows, the first
argument to the batch-program should be the directory where xemacs.exe
respectively emacs.exe is located, iff you want to install Gnus after
compiling it, give make.bat /copy as the second parameter.
`make.bat' has been rewritten from scratch, it now features automatic
recognition of XEmacs and GNU Emacs, generates gnus-load.el, checks if
errors occur while compilation and generation of info files and reports
them at the end of the build process. It now uses makeinfo if it is
available and falls back to infohack.el otherwise. `make.bat' should now
install all files which are necessary to run Gnus and be generally a
complete replacement for the "configure; make; make install" cycle used
under Unix systems.
The new make.bat makes make-x.bat superfluous, so it has been removed.
** Support for non-ASCII domain names
Message supports non-ASCII domain names in From:, To: and Cc: and will
query you whether to perform encoding when you try to send a message.
The variable `message-use-idna' controls this. Gnus will also decode
non-ASCII domain names in From:, To: and Cc: when you view a message.
The variable `gnus-use-idna' controls this.
** Better handling of Microsoft citation styles
Gnus now tries to recognize the mangled header block that some Microsoft
mailers use to indicate that the rest of the message is a citation, even
though it is not quoted in any way. The variable
`gnus-cite-unsightly-citation-regexp' matches the start of these
citations.
** gnus-article-skip-boring
If you set `gnus-article-skip-boring' to t, then Gnus will not scroll
down to show you a page that contains only boring text, which by
default means cited text and signature. You can customize what is
skippable using `gnus-article-boring-faces'.
This feature is especially useful if you read many articles that
consist of a little new content at the top with a long, untrimmed
message cited below.
** The format spec %C for positioning point has changed to %*.
** The new variable `gnus-parameters' can be used to set group parameters.
Earlier this was done only via `G p' (or `G c'), which stored the
parameters in ~/.newsrc.eld, but via this variable you can enjoy the
powers of customize, and simplified backups since you set the variable
in ~/.emacs instead of ~/.newsrc.eld. The variable maps regular
expressions matching group names to group parameters, a'la:
(setq gnus-parameters
'(("mail\\..*"
(gnus-show-threads nil)
(gnus-use-scoring nil))
("^nnimap:\\(foo.bar\\)$"
(to-group . "\\1"))))
** Smileys (":-)", ";-)" etc) are now iconized for Emacs too.
Customize `gnus-treat-display-smileys' to disable it.
** Gnus no longer generates the Sender: header automatically.
Earlier it was generated iff the user configurable email address was
different from the Gnus guessed default user address. As the guessing
algorithm is rarely correct these days, and (more controversially) the
only use of the Sender: header was to check if you are entitled to
cancel/supersede news (which is now solved by Cancel Locks instead,
see another entry), generation of the header has been disabled by
default. See the variables `message-required-headers',
`message-required-news-headers', and `message-required-mail-headers'.
** Features from third party message-utils.el added to message.el.
Message now asks if you wish to remove "(was: <old subject>)" from
subject lines (see `message-subject-trailing-was-query'). C-c M-m and
C-c M-f inserts markers indicating included text. C-c C-f a adds a
X-No-Archive: header. C-c C-f x inserts appropriate headers and a
note in the body for cross-postings and followups (see the variables
`message-cross-post-*').
** References and X-Draft-Headers are no longer generated when you
start composing messages and `message-generate-headers-first' is nil.
** Improved anti-spam features.
Gnus is now able to take out spam from your mail and news streams
using a wide variety of programs and filter rules. Among the supported
methods are RBL blocklists, bogofilter and white/blacklists. Hooks
for easy use of external packages such as SpamAssassin and Hashcash
are also new.
** Easy inclusion of X-Faces headers.
** In the summary buffer, the new command / N inserts new messages and
/ o inserts old messages.
** Gnus decodes morse encoded messages if you press W m.
** Unread count correct in nnimap groups.
The estimated number of unread articles in the group buffer should now
be correct for nnimap groups. This is achieved by calling
`nnimap-fixup-unread-after-getting-new-news' from the
`gnus-setup-news-hook' (called on startup) and
`gnus-after-getting-new-news-hook' (called after getting new mail).
If you have modified those variables from the default, you may want to
add n-f-u-a-g-n-n again. If you were happy with the estimate and want
to save some (minimal) time when getting new mail, remove the
function.
** Group Carbon Copy (GCC) quoting
To support groups that contains SPC and other weird characters, groups
are quoted before they are placed in the Gcc: header. This means
variables such as `gnus-message-archive-group' should no longer
contain quote characters to make groups containing SPC work. Also, if
you are using the string "nnml:foo, nnml:bar" (indicating Gcc into two
groups) you must change it to return the list ("nnml:foo" "nnml:bar"),
otherwise the Gcc: line will be quoted incorrectly. Note that
returning the string "nnml:foo, nnml:bar" was incorrect earlier, it
just didn't generate any problems since it was inserted directly.
** ~/News/overview/ not used.
As a result of the following change, the ~/News/overview/ directory is
not used any more. You can safely delete the entire hierarchy.
** gnus-agent
The Gnus Agent has seen a major update. It is now enabled by default,
and all nntp and nnimap servers from `gnus-select-method' and
`gnus-secondary-select-method' are agentized by default. Earlier only
the server in `gnus-select-method' was agentized by the default, and the
agent was disabled by default. When the agent is enabled, headers are
now also retrieved from the Agent cache instead of the backends when
possible. Earlier this only happened in the unplugged state. You can
enroll or remove servers with `J a' and `J r' in the server buffer.
Gnus will not download articles into the Agent cache, unless you
instruct it to do so, though, by using `J u' or `J s' from the Group
buffer. You revert to the old behaviour of having the Agent disabled
by customizing `gnus-agent'. Note that putting `(gnus-agentize)' in
~/.gnus is not needed any more.
** gnus-summary-line-format
The default value changed to "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n".
Moreover `gnus-extra-headers', `nnmail-extra-headers' and
`gnus-ignored-from-addresses' changed their default so that the users
name will be replaced by the recipient's name or the group name
posting to for NNTP groups.
** deuglify.el (gnus-article-outlook-deuglify-article)
A new file from Raymond Scholz <rscholz@zonix.de> for deuglifying
broken Outlook (Express) articles.
** (require 'gnus-load)
If you use a stand-alone Gnus distribution, you'd better add
"(require 'gnus-load)" to your ~/.emacs after adding the Gnus
lisp directory into load-path.
File gnus-load.el contains autoload commands, functions and variables,
some of which may not be included in distributions of Emacsen.
** gnus-slave-unplugged
A new command which starts gnus offline in slave mode.
** message-insinuate-rmail
Adding (message-insinuate-rmail) in .emacs and customizing
`mail-user-agent' to `gnus-user-agent' convinces Rmail to compose,
reply and forward messages in Message mode, where you can enjoy the
power of MML.
** message-minibuffer-local-map
The line below enables BBDB in resending a message:
(define-key message-minibuffer-local-map [?\t] 'bbdb-complete-name)
** Externalizing and deleting of attachments.
If `gnus-gcc-externalize-attachments' (or
`message-fcc-externalize-attachments') is non-nil, attach local files
as external parts.
The command `gnus-mime-save-part-and-strip' (bound to `C-o' on MIME
buttons) saves a part and replaces the part with an external one.
`gnus-mime-delete-part' (bound to `d' on MIME buttons) removes a part.
It works only on back ends that support editing.
** gnus-default-charset
The default value now guesses on the basis of your environment instead
of using Latin-1. Also the ".*" item in gnus-group-charset-alist is
removed.
** gnus-posting-styles
Add a new format of match like
((header "to" "larsi.*org")
(Organization "Somewhere, Inc."))
The old format like the lines below is obsolete, but still accepted.
(header "to" "larsi.*org"
(Organization "Somewhere, Inc."))
** message-ignored-news-headers and message-ignored-mail-headers
X-Draft-From and X-Gnus-Agent-Meta-Information have been added into
these two variables. If you customized those, perhaps you need add
those two headers too.
** Gnus reads the NOV and articles in the Agent if plugged.
If one reads an article while plugged, and the article already exists
in the Agent, it won't get downloaded once more. Customize
`gnus-agent-cache' to revert to the old behavior.
** Gnus supports the "format=flowed" (RFC 2646) parameter.
On composing messages, it is enabled by `use-hard-newlines'. Decoding
format=flowed was present but not documented in earlier versions.
** Gnus supports the generation of RFC 2298 Disposition Notification requests.
This is invoked with the C-c M-n key binding from message mode.
** Gnus supports Maildir groups.
Gnus includes a new backend nnmaildir.el.
** Printing capabilities are enhanced.
Gnus supports Muttprint natively with O P from the Summary and Article
buffers. Also, each individual MIME part can be printed using p on
the MIME button.
** Message supports the Importance: (RFC 2156) header.
In the message buffer, `C-c C-f C-i' or `C-c C-u' cycles through the
valid values.
** Gnus supports Cancel Locks in News.
This means a header "Cancel-Lock" is inserted in news posting. It is
used to determine if you wrote a article or not (for cancelling and
superseding). Gnus generates a random password string the first time
you post a message, and saves it using the Custom system. While the
variable is called `canlock-password', it is not security sensitive
data. Publishing your canlock string on the web will not allow anyone
to be able to anything she could not already do. The behaviour can be
changed by customizing `message-insert-canlock'.
** Gnus supports server-side mail filtering using Sieve.
Sieve rules can be added as Group Parameters for groups, and the
complete Sieve script is generated using `D g' from the Group buffer,
and then uploaded to the server using `C-c C-l' in the generated Sieve
buffer. Search the online Gnus manual for "sieve", and see the new
Sieve manual, for more information.
** Extended format specs.
Format spec "%&user-date;" is added into
`gnus-summary-line-format-alist'. Also, user defined extended format
specs are supported. The extended format specs look like "%u&foo;",
which invokes function `gnus-user-format-function-foo'. Because "&" is
used as the escape character, old user defined format "%u&" is no
longer supported.
** `/ *' (gnus-summary-limit-include-cached) is rewritten.
It was aliased to `Y c' (gnus-summary-insert-cached-articles). The new
function filters out other articles.
** Some limiting commands accept a C-u prefix to negate the match.
If C-u is used on subject, author or extra headers, i.e., `/ s', `/
a', and `/ x' (gnus-summary-limit-to-{subject,author,extra})
respectively, the result will be to display all articles that do not
match the expression.
** Group names are treated as UTF-8 by default.
This is supposedly what USEFOR wanted to migrate to. See
`gnus-group-name-charset-group-alist' and
`gnus-group-name-charset-method-alist' for customization.
** The nnml and nnfolder backends store marks for each group.
This makes it possible to take backup of nnml/nnfolder servers/groups
separately of ~/.newsrc.eld, while preserving marks. It also makes it
possible to share articles and marks between users (without sharing
the ~/.newsrc.eld file) within e.g. a department. It works by storing
the marks stored in ~/.newsrc.eld in a per-group file ".marks" (for
nnml) and "groupname.mrk" (for nnfolder, named "groupname"). If the
nnml/nnfolder is moved to another machine, Gnus will automatically use
the .marks or .mrk file instead of the information in ~/.newsrc.eld.
The new server variables `nnml-marks-is-evil' and
`nnfolder-marks-is-evil' can be used to disable this feature.
** The menu bar item (in Group and Summary buffer) named "Misc" has
been renamed to "Gnus".
** The menu bar item (in Message mode) named "MML" has been renamed to
"Attachments". Note that this menu also contains security related
stuff, like signing and encryption.
** gnus-group-charset-alist and gnus-group-ignored-charsets-alist.
The regexps in these variables are compared with full group names
instead of real group names in 5.8. Users who customize these
variables should change those regexps accordingly. For example:
("^han\\>" euc-kr) -> ("\\(^\\|:\\)han\\>" euc-kr)
** Gnus supports PGP (RFC 1991/2440), PGP/MIME (RFC 2015/3156) and
S/MIME (RFC 2630-2633).
It needs an external S/MIME and OpenPGP implementation, but no
additional lisp libraries. This add several menu items to the
Attachments menu, and C-c RET key bindings, when composing messages.
This also obsoletes `gnus-article-hide-pgp-hook'.
** Gnus inlines external parts (message/external).
** MML (Mime compose) prefix changed from `M-m' to `C-c C-m'.
This change was made to avoid conflict with the standard binding of
`back-to-indentation', which is also useful in message mode.
** The default for message-forward-show-mml changed to symbol best.
The behaviour for the `best' value is to show MML (i.e., convert MIME
to MML) when appropriate. MML will not be used when forwarding signed
or encrypted messages, as the conversion invalidate the digital
signature.
** Bug fixes.
* Changes in Pterodactyl Gnus (5.8/5.9)
The Gnus NEWS entries are short, but they reflect sweeping changes in
four areas: Article display treatment, MIME treatment,
internationalization and mail-fetching.
** The mail-fetching functions have changed. See the manual for the
many details. In particular, all procmail fetching variables are gone.
If you used procmail like in
(setq nnmail-use-procmail t)
(setq nnmail-spool-file 'procmail)
(setq nnmail-procmail-directory "~/mail/incoming/")
(setq nnmail-procmail-suffix "\\.in")
this now has changed to
(setq mail-sources
'((directory :path "~/mail/incoming/"
:suffix ".in")))
More information is available in the info doc at Select Methods ->
Getting Mail -> Mail Sources
** Gnus is now a MIME-capable reader. This affects many parts of
Gnus, and adds a slew of new commands. See the manual for details.
** Gnus has also been multilingualized. This also affects too
many parts of Gnus to summarize here, and adds many new variables.
** gnus-auto-select-first can now be a function to be
called to position point.
** The user can now decide which extra headers should be included in
summary buffers and NOV files.
** `gnus-article-display-hook' has been removed. Instead, a number
of variables starting with `gnus-treat-' have been added.
** The Gnus posting styles have been redone again and now works in a
subtly different manner.
** New web-based backends have been added: nnslashdot, nnwarchive
and nnultimate. nnweb has been revamped, again, to keep up with
ever-changing layouts.
** Gnus can now read IMAP mail via nnimap.
* For older news, see Gnus info node "New Features".
----------------------------------------------------------------------
Copyright information:
Copyright (C) 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
Permission is granted to anyone to make or distribute verbatim copies
of this document as received, in any medium, provided that the
copyright notice and this permission notice are preserved,
thus giving the recipient permission to redistribute in turn.
Permission is granted to distribute modified versions
of this document, or of portions of it,
under the above conditions, provided also that they
carry prominent notices stating who last changed them.
Local variables:
mode: outline
paragraph-separate: "[ ]*$"
end:

9
etc/NEWS
View File

@ -264,6 +264,15 @@ This is like `strokes-global-set-stroke', but it allows you to bind
the stroke directly to a string to insert. This is convenient for
using strokes as an input method.
** Gnus package
*** Gnus now includes Sieve and PGG
Sieve is a library for managing Sieve scripts. PGG is a library to handle
PGP/MIME.
*** There are many news features, bug fixes and improvements.
See the file GNUS-NEWS or the node "Oort Gnus" in the Gnus manual for details.
+++
** Desktop package

10
lisp/ChangeLog
View File

@ -773,6 +773,16 @@
* ps-print.el (ps-begin-file): Improve the DSC compliance of the
generated PostScript.
2004-08-17 Reiner Steib <Reiner.Steib@gmx.de>
* net/tls.el (tls-process-connection-type): Fix docstring. (Sync
with Gnus v5_10 branch.)
2004-08-16 Reiner Steib <Reiner.Steib@gmx.de>
* calendar/time-date.el (time-to-number-of-days): New function.
Imported from from Gnus.
2004-07-22 Kim F. Storm <storm@cua.dk>
* progmodes/make-mode.el: Fix comments.

9
lisp/calendar/time-date.el
View File

@ -1,5 +1,5 @@
;;; time-date.el --- date and time handling functions
;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1998, 1999, 2000, 2004 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu Umeda <umerin@mse.kyutech.ac.jp>
@ -38,7 +38,7 @@
(parse-time-string
;; `parse-time-string' isn't sufficiently general or
;; robust. It fails to grok some of the formats that
;; timzeone does (e.g. dodgy post-2000 stuff from some
;; timezone does (e.g. dodgy post-2000 stuff from some
;; Elms) and either fails or returns bogus values. Lars
;; reverted this change, but that loses non-trivially
;; often for me. -- fx
@ -177,6 +177,11 @@ The Gregorian date Sunday, December 31, 1bce is imaginary."
(- (/ (1- year) 100)) ; - century years
(/ (1- year) 400)))) ; + Gregorian leap years
(defun time-to-number-of-days (time)
"Return the number of days represented by TIME.
The number of days will be returned as a floating point number."
(/ (+ (* 1.0 65536 (car time)) (cadr time)) (* 60 60 24)))
;;;###autoload
(defun safe-date-to-time (date)
"Parse a string that represents a date-time and return a time value.

11498
lisp/gnus/ChangeLog
View File

File diff suppressed because it is too large Load Diff

18924
lisp/gnus/ChangeLog.2 Normal file
View File

File diff suppressed because it is too large Load Diff

193
lisp/gnus/TODO Normal file
View File

@ -0,0 +1,193 @@
2004-08-22 Reiner Steib <Reiner.Steib@gmx.de>
* Disclaimer: This is *temporary* file to keep track of the changes
in the trunk, that have or have not made it into the Gnus branch.
2004--08-22 Reiner Steib <Reiner.Steib@gmx.de>
* Add `:version "21.4"' to all new defcustoms. Grep ChangeLog and
ChangeLog.1 for "new variable". Also check if the `:version
"21.1"' and `:version "21.3"' entries are correct.
2002-10-02 Karl Berry <karl@gnu.org>
* In directory ./man:
* emacs-mime.texi, gnus-faq.texi, gnus.texi, message.texi,
pgg.texi, sieve.texi: Per rms, update all manuals to use @copying
instead of @ifinfo. Also use @ifnottex instead of @ifinfo around
the top node, where needed for the sake of the HTML output.
(The Gnus manual is not fixed since it's not clear to me how it
works; and the Tramp manual already uses @copying, although in an
unusual way. All others were changed.)
==> Done. Not yet in Gnus repository.
2004-06-29 Kim F. Storm <storm@cua.dk>
* nntp.el (nntp-authinfo-file): Add :group 'nntp.
* nnimap.el (nnimap-authinfo-file, nnimap-prune-cache):
Add :group 'nnimap.
==> applied, here and in Gnus repository.
2004-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
* mm-view.el (mm-insert-inline): Make it work in read-only buffer.
* gnus-win.el (gnus-all-windows-visible-p): Don't consider
non-visible windows.
2004-05-07 Stefan Monnier <monnier@iro.umontreal.ca>
* rfc2047.el (rfc2047-encode-message-header): Don't encode non-address
headers as address headers (which breaks if subject has a single ").
==> already in Gnus
2004-05-06 Stefan Monnier <monnier@iro.umontreal.ca>
* nnimap.el (nnimap-demule): Avoid string-as-multibyte.
==> applied, here and in Gnus repository.
2004-04-21 Richard M. Stallman <rms@gnu.org>
* mailcap.el (mailcap-mime-data): Mark as risky.
==> applied, here and in Gnus repository.
2004-03-27 Juanma Barranquero <lektu@terra.es>
* gnus-srvr.el (gnus-server-prepare): Remove spurious call to `cdr'.
==> already in Gnus
2004-03-22 Stefan Monnier <monnier@iro.umontreal.ca>
* gnus-art.el: Use inhibit-read-only instead of buffer-read-only.
(gnus-narrow-to-page): Don't assume point-min == 1.
(gnus-article-edit-mode): Derive from message-mode.
(gnus-button-alist): Add buttons to (info "(emacs)Keymaps").
* gnus-score.el (gnus-score-find-bnews): Simplify and don't assume
point-min == 1.
* imap.el (imap-parse-address-list, imap-parse-body-ext):
Disable incorrect use of `assert'.
==> applied / modified
2004-03-05 Stefan Monnier <monnier@iro.umontreal.ca>
* message.el (message-mode): Fix last change.
==> applied
2004-03-04 Stefan Monnier <monnier@iro.umontreal.ca>
* message.el (message-mode): Set comment-start-skip.
==> applied
2004-02-08 Andreas Schwab <schwab@suse.de>
* nnlistserv.el (nnlistserv-kk-wash-article): Fix paren nesting.
* gnus-score.el (gnus-summary-increase-score): Fix format string.
==> applied; here and in Gnus v5-10. Already fixed in No Gnus.
2003-06-25 Sam Steingold <sds@gnu.org>
* gnus-group.el (gnus-group-suspend): Avoid some consing.
==> hunk FAILED / not very important / skip
2003-06-11 Sam Steingold <sds@gnu.org>
* pop3.el (pop3-leave-mail-on-server): New user variable.
(pop3-movemail): Delete mail only when it is nil.
==> applied / Was not documented in the Gnus manual, added it.
2003-05-10 Juanma Barranquero <lektu@terra.es>
* message.el (message-buffer-naming-style): Fix typo.
==> variable has been removed.
2003-05-07 Dave Love <fx@gnu.org>
[Partial sync with Gnus.]
* rfc2047.el (rfc2047-header-encoding-alist): Add Followup-To.
(rfc2047-encode-message-header): Fold when encoding not necessary.
(rfc2047-encode-region): Skip \n as whitespace.
(rfc2047-fold-region): Fix whitespace regexps. Don't break just
after the header name.
(rfc2047-unfold-region): Fix regexp and whitespace-skipping.
2003-05-06 Jesper Harder <harder@ifa.au.dk>
* gnus-cus.el (gnus-group-customize, gnus-score-parameters):
Don't quote nil and t in docstrings.
* gnus-score.el (gnus-score-lower-thread): Likewise.
* gnus-art.el (gnus-article-mime-match-handle-function): Likewise.
==> already in Gnus
2003-02-28 ShengHuo ZHU <zsh@cs.rochester.edu>
* nnfolder.el (nnfolder-request-accept-article): Don't use
mail-header-unfold-field.
* imap.el (imap-ssl-open): Don't depend on ssl.el.
* nntp.el (nntp-open-ssl-stream): Don't depend on ssl.el.
2003-02-18 Juanma Barranquero <lektu@terra.es>
* ietf-drums.el (ietf-drums-remove-whitespace): Fix character constant.
2003-02-14 Juanma Barranquero <lektu@terra.es>
* mm-uu.el (mm-uu-dissect): Fix use of character constant.
==> already done. [2003-02-14 ShengHuo ZHU synced stuff to Gnus]
2003-02-11 Stefan Monnier <monnier@cs.yale.edu>
* nntp.el (nntp-accept-process-output): Don't use point-max to get
the buffer's size.
==> already done. [2003-02-14 ShengHuo ZHU synced stuff to Gnus]
2003-01-31 Joe Buehler <jhpb@draco.hekimian.com>
* nnheader.el: Added cygwin to system-type comparisons.
==> already done.
2004-08-22 Reiner Steib <Reiner.Steib@gmx.de>
* It seems that the last few changes and all older changes have
already been applied in Gnus repository, e.g. by ShengHuo ZHU
<zsh@cs.rochester.edu>.
# Local Variables:
# coding: iso-2022-7bit
# mode: change-log
# End:
# arch-tag: e6e5d695-4d00-46b1-a49d-508a2418a483

7
lisp/gnus/bar.xbm Normal file
View File

@ -0,0 +1,7 @@
#define noname_width 6
#define noname_height 48
static char noname_bits[] = {
0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,
0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,
0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,
0x0c,0x0c,0x0c};

54
lisp/gnus/bar.xpm Normal file
View File

@ -0,0 +1,54 @@
/* XPM */
static char * picon-bar_xpm[] = {
"6 48 2 1",
" c white s background",
". c black",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. ",
" .. "};

68
lisp/gnus/binhex.el
View File

@ -1,8 +1,7 @@
;;; binhex.el --- elisp native binhex decode
;; Copyright (c) 1998 Free Software Foundation, Inc.
;; Copyright (c) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Create Date: Oct 1, 1998
;; Keywords: binhex news
;; This file is part of GNU Emacs.
@ -26,20 +25,33 @@
;;; Code:
(autoload 'executable-find "executable")
(eval-when-compile (require 'cl))
(defalias 'binhex-char-int
(if (fboundp 'char-int)
'char-int
'identity))
(eval-and-compile
(defalias 'binhex-char-int
(if (fboundp 'char-int)
'char-int
'identity)))
(defvar binhex-decoder-program "hexbin"
"*Non-nil value should be a string that names a uu decoder.
(defcustom binhex-decoder-program "hexbin"
"*Non-nil value should be a string that names a binhex decoder.
The program should expect to read binhex data on its standard
input and write the converted data to its standard output.")
input and write the converted data to its standard output."
:type 'string
:group 'gnus-extract)
(defvar binhex-decoder-switches '("-d")
"*List of command line flags passed to the command `binhex-decoder-program'.")
(defcustom binhex-decoder-switches '("-d")
"*List of command line flags passed to the command `binhex-decoder-program'."
:group 'gnus-extract
:type '(repeat string))
(defcustom binhex-use-external
(executable-find binhex-decoder-program)
"*Use external binhex program."
:group 'gnus-extract
:type 'boolean)
(defconst binhex-alphabet-decoding-alist
'(( ?\! . 0) ( ?\" . 1) ( ?\# . 2) ( ?\$ . 3) ( ?\% . 4) ( ?\& . 5)
@ -69,13 +81,16 @@ input and write the converted data to its standard output.")
((boundp 'temporary-file-directory) temporary-file-directory)
("/tmp/")))
(if (featurep 'xemacs)
(defalias 'binhex-insert-char 'insert-char)
(defun binhex-insert-char (char &optional count ignored buffer)
(if (or (null buffer) (eq buffer (current-buffer)))
(insert-char char count)
(with-current-buffer buffer
(insert-char char count)))))
(eval-and-compile
(defalias 'binhex-insert-char
(if (featurep 'xemacs)
'insert-char
(lambda (char &optional count ignored buffer)
"Insert COUNT copies of CHARACTER into BUFFER."
(if (or (null buffer) (eq buffer (current-buffer)))
(insert-char char count)
(with-current-buffer buffer
(insert-char char count)))))))
(defvar binhex-crc-table
[0 4129 8258 12387 16516 20645 24774 28903
@ -184,8 +199,9 @@ input and write the converted data to its standard output.")
(t
(binhex-insert-char (setq binhex-last-char char) 1 ignored buffer))))
(defun binhex-decode-region (start end &optional header-only)
"Binhex decode region between START and END.
;;;###autoload
(defun binhex-decode-region-internal (start end &optional header-only)
"Binhex decode region between START and END without using an external program.
If HEADER-ONLY is non-nil only decode header and return filename."
(interactive "r")
(let ((work-buffer nil)
@ -258,12 +274,14 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(and work-buffer (kill-buffer work-buffer)))
(if header (aref header 1))))
;;;###autoload
(defun binhex-decode-region-external (start end)
"Binhex decode region between START and END using external decoder."
(interactive "r")
(let ((cbuf (current-buffer)) firstline work-buffer status
(file-name (expand-file-name
(concat (binhex-decode-region start end t) ".data")
(concat (binhex-decode-region-internal start end t)
".data")
binhex-temporary-file-directory)))
(save-excursion
(goto-char start)
@ -296,6 +314,14 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(ignore-errors
(if file-name (delete-file file-name))))))
;;;###autoload
(defun binhex-decode-region (start end)
"Binhex decode region between START and END."
(interactive "r")
(if binhex-use-external
(binhex-decode-region-external start end)
(binhex-decode-region-internal start end)))
(provide 'binhex)
;;; arch-tag: 8476badd-1e76-4f1d-a640-f9a38c72eed8

BIN
lisp/gnus/blink.pbm Normal file
View File

Binary file not shown.

20
lisp/gnus/blink.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * blink_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".+++++++++++.",
".+++++++..++.",
".+++++++..++.",
".++...++++++.",
".+++++++++++.",
".++++++++.++.",
".++.+++++.++.",
".+++.....+++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

20
lisp/gnus/braindamaged.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * mad_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".++...++++++.",
".++.+.+...++.",
".++...+.+.++.",
".++++++...++.",
".+.+++++++.+.",
".+.+++++++.+.",
".++.+++++.++.",
".+++.....+++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

251
lisp/gnus/canlock.el Normal file
View File

@ -0,0 +1,251 @@
;;; canlock.el --- functions for Cancel-Lock feature
;; Copyright (C) 1998, 1999, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: news, cancel-lock, hmac, sha1, rfc2104
;; This program 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.
;; This program 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 this program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Canlock is a library for generating and verifying Cancel-Lock and/or
;; Cancel-Key header in news articles. This is used to protect articles
;; from rogue cancel, supersede or replace attacks. The method is based
;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November
;; 3rd 1998. For instance, you can add Cancel-Lock (and possibly Cancel-
;; Key) header in a news article by using a hook which will be evaluated
;; just before sending an article as follows:
;;
;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t)
;;
;; Verifying Cancel-Lock is mainly a function of news servers, however,
;; you can verify your own article using the command `canlock-verify' in
;; the (raw) article buffer. You will be prompted for the password for
;; each time if the option `canlock-password' or `canlock-password-for-
;; verify' is nil. Note that setting these options is a bit unsafe.
;;; Code:
(eval-when-compile
(require 'cl))
(require 'sha1)
(defvar mail-header-separator)
(defgroup canlock nil
"The Cancel-Lock feature."
:group 'applications)
(defcustom canlock-password nil
"Password to use when signing a Cancel-Lock or a Cancel-Key header."
:type '(radio (const :format "Not specified " nil)
(string :tag "Password" :size 0))
:group 'canlock)
(defcustom canlock-password-for-verify canlock-password
"Password to use when verifying a Cancel-Lock or a Cancel-Key header."
:type '(radio (const :format "Not specified " nil)
(string :tag "Password" :size 0))
:group 'canlock)
(defcustom canlock-force-insert-header nil
"If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the
buffer does not look like a news message."
:type 'boolean
:group 'canlock)
(eval-when-compile
(defmacro canlock-string-as-unibyte (string)
"Return a unibyte string with the same individual bytes as STRING."
(if (fboundp 'string-as-unibyte)
(list 'string-as-unibyte string)
string)))
(defun canlock-sha1 (message)
"Make a SHA-1 digest of MESSAGE as a unibyte string of length 20 bytes."
(let (sha1-maximum-internal-length)
(sha1 message nil nil 'binary)))
(defun canlock-make-cancel-key (message-id password)
"Make a Cancel-Key header."
(when (> (length password) 20)
(setq password (canlock-sha1 password)))
(setq password (concat password (make-string (- 64 (length password)) 0)))
(let ((ipad (mapconcat (lambda (byte)
(char-to-string (logxor 54 byte)))
password ""))
(opad (mapconcat (lambda (byte)
(char-to-string (logxor 92 byte)))
password "")))
(base64-encode-string
(canlock-sha1
(concat opad
(canlock-sha1
(concat ipad (canlock-string-as-unibyte message-id))))))))
(defun canlock-narrow-to-header ()
"Narrow the buffer to the head of the message."
(let (case-fold-search)
(narrow-to-region
(goto-char (point-min))
(goto-char (if (re-search-forward
(format "^$\\|^%s$"
(regexp-quote mail-header-separator))
nil t)
(match-beginning 0)
(point-max))))))
(defun canlock-delete-headers ()
"Delete Cancel-Key or Cancel-Lock headers in the narrowed buffer."
(let ((case-fold-search t))
(goto-char (point-min))
(while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t)
(delete-region (match-beginning 0)
(if (re-search-forward "^[^\t ]" nil t)
(goto-char (match-beginning 0))
(point-max))))))
(defun canlock-fetch-fields (&optional key)
"Return a list of the values of Cancel-Lock header.
If KEY is non-nil, look for a Cancel-Key header instead. The buffer
is expected to be narrowed to just the headers of the message."
(let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
fields rest
(case-fold-search t))
(when field
(setq fields (split-string field "[\t\n\r ,]+"))
(while fields
(when (string-match "^sha1:" (setq field (pop fields)))
(push (substring field 5) rest)))
(nreverse rest))))
(defun canlock-fetch-id-for-key ()
"Return a Message-ID in Cancel, Supersedes or Replaces header.
The buffer is expected to be narrowed to just the headers of the
message."
(or (let ((cancel (mail-fetch-field "Control")))
(and cancel
(string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
cancel)
(match-string 1 cancel)))
(mail-fetch-field "Supersedes")
(mail-fetch-field "Replaces")))
;;;###autoload
(defun canlock-insert-header (&optional id-for-key id-for-lock password)
"Insert a Cancel-Key and/or a Cancel-Lock header if possible."
(let (news control key-for-key key-for-lock)
(save-excursion
(save-restriction
(canlock-narrow-to-header)
(when (setq news (or canlock-force-insert-header
(mail-fetch-field "Newsgroups")))
(unless id-for-key
(setq id-for-key (canlock-fetch-id-for-key)))
(if (and (setq control (mail-fetch-field "Control"))
(string-match "^cancel[\t ]+<[^\t\n @<>]+@[^\t\n @<>]+>"
control))
(setq id-for-lock nil)
(unless id-for-lock
(setq id-for-lock (mail-fetch-field "Message-ID"))))
(canlock-delete-headers)
(goto-char (point-max))))
(when news
(if (not (or id-for-key id-for-lock))
(message "There are no Message-ID(s)")
(unless password
(setq password (or canlock-password
(read-passwd
"Password for Canlock: "))))
(if (or (not (stringp password)) (zerop (length password)))
(message "Password for Canlock is bad")
(setq key-for-key (when id-for-key
(canlock-make-cancel-key
id-for-key password))
key-for-lock (when id-for-lock
(canlock-make-cancel-key
id-for-lock password)))
(if (not (or key-for-key key-for-lock))
(message "Couldn't insert Canlock header")
(when key-for-key
(insert "Cancel-Key: sha1:" key-for-key "\n"))
(when key-for-lock
(insert "Cancel-Lock: sha1:"
(base64-encode-string (canlock-sha1 key-for-lock))
"\n")))))))))
;;;###autoload
(defun canlock-verify (&optional buffer)
"Verify Cancel-Lock or Cancel-Key in BUFFER.
If BUFFER is nil, the current buffer is assumed. Signal an error if
it fails."
(interactive)
(let (keys locks errmsg id-for-key id-for-lock password
key-for-key key-for-lock match)
(save-excursion
(when buffer
(set-buffer buffer))
(save-restriction
(widen)
(canlock-narrow-to-header)
(setq keys (canlock-fetch-fields 'key)
locks (canlock-fetch-fields))
(if (not (or keys locks))
(setq errmsg
"There are neither Cancel-Lock nor Cancel-Key headers")
(setq id-for-key (canlock-fetch-id-for-key)
id-for-lock (mail-fetch-field "Message-ID"))
(or id-for-key id-for-lock
(setq errmsg "There are no Message-ID(s)")))))
(if errmsg
(error "%s" errmsg)
(setq password (or canlock-password-for-verify
(read-passwd "Password for Canlock: ")))
(if (or (not (stringp password)) (zerop (length password)))
(error "Password for Canlock is bad")
(when keys
(when id-for-key
(setq key-for-key (canlock-make-cancel-key id-for-key password))
(while (and keys (not match))
(setq match (string-equal key-for-key (pop keys)))))
(setq keys (if match "good" "bad")))
(setq match nil)
(when locks
(when id-for-lock
(setq key-for-lock
(base64-encode-string
(canlock-sha1 (canlock-make-cancel-key id-for-lock
password))))
(when (and locks (not match))
(setq match (string-equal key-for-lock (pop locks)))))
(setq locks (if match "good" "bad")))
(prog1
(when (member "bad" (list keys locks))
"bad")
(cond ((and keys locks)
(message "Cancel-Key is %s, Cancel-Lock is %s" keys locks))
(locks
(message "Cancel-Lock is %s" locks))
(keys
(message "Cancel-Key is %s" keys))))))))
(provide 'canlock)
;;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78
;;; canlock.el ends here

104
lisp/gnus/catchup.xpm
View File

@ -1,73 +1,33 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 43 1",
" c Gray0",
". c #099909990999",
"X c Gray6",
"o c #133313331333",
"O c Gray9",
"+ c Gray11",
"@ c Gray12",
"# c #23f323f323f3",
"$ c Gray15",
"% c #2ff12ff12ff1",
"& c #3fff3fff3fff",
"* c Gray25",
"= c #4ccc4ccc4ccc",
"- c #519151915191",
"; c #53ed53ed53ed",
": c #565b565b565b",
"> c Gray35",
", c #5b1a5b1a5b1a",
"< c #5fe95fe95fe9",
"1 c #626262626262",
"2 c Gray40",
"3 c #67e767e767e7",
"4 c Gray42",
"5 c #6fff6fff6fff",
"6 c Gray45",
"7 c Gray46",
"8 c #77e977e977e9",
"9 c #7bdb7bdb7bdb",
"0 c #7ccc7ccc7ccc",
"q c Gray50",
"w c #866586658665",
"e c Gray56",
"r c Gray60",
"t c #9bcb9bcb9bcb",
"y c #9fff9fff9fff",
"u c #a7c7a7c7a7c7",
"i c #af0eaf0eaf0e",
"p c Gray70",
"a c Gray75",
"s c Gray81",
"d c #dfffdfffdfff",
"f c #efffefffefff",
"g c Gray100",
/* pixels */
"aaaaaaaaaaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaaaaaaaaaa",
"aaaaaa7$$*uaaaaaaaaareep",
"aaaaaa$rr6<aaaaaaaae;==>",
"aaaaaa7<r6<aaaaaaaa<6rr$",
"9&&&&&&>6;aaaareeeee#rw*",
"&aqqagga@<<<7e7qqqqqq=:u",
"33e4qgggsaa%1Oa&&&ggge<a",
"17a9ygf7%%%%#=$aa%ggga<a",
"7aa&gga<aaaae$>ae7ggya<a",
"aa;sgg;uaaaapepa<agg&a<a",
"au;&&&%aaaaaaaae<aaa;a6.",
"a<aggg%aaaaaaaa3qqq&e<:o",
"r7<5gg%aaaaaaaaXyggqeaue",
"6gs$6fa=re6666=s@egy3rrr",
"ga>r=aa=r6 <qqdd3=yg&rrr",
"&>er=aa=r6 aggg=wr&g&rrr",
"rrrrr$a<:6 @$$$rri=d5qrr",
"rrrrr<===6$wrrrrrr6&qo6r",
"rrrrrrrrrewrrrrrrr6 oq",
"rrrrrrrrrrrrrrrrrrrrrrrr",
"rrrrrrrrrrrrrrrrrrrrrrrr",
"rrrrrrrrrrrrrrrrrrrrrrrr"
};
static char * catchup_xpm[] = {
"24 24 6 1",
" c None",
". c #FFFFFFFFFFFF",
"X c #E1E1E0E0E0E0",
"o c #A5A5A5A59595",
"O c #999999999999",
"+ c #000000000000",
" ",
" ",
" ",
" ",
" ",
" ",
" ",
" . ",
" . .X ",
" ... .oX . ",
" ..oooX.oXo .X ",
" .oooXXXX..oXXoXX ",
" .oXXXX.XoX.oXooX ",
" X...X.X.XX.XoXX ",
" Xo..X.XXX.XXXX ",
" . Xo.oXX..XXXXXX ",
"OOOOXoXXXXXo.XXXXX++OOOO",
"OOOOOX..X.XXXXXXXX++OOOO",
"OOOOOX..XXXXXXXXX++OOOOO",
"OOOOOOXXXXXXXXX+++OOOOOO",
"OOOOOOOOOXXXX++++OOOOOOO",
"OOOOOOOOO+++++OOOOOOOOOO",
"OOOOOOOOOO+OOOOOOOOOOOOO",
"OOOOOOOOOOOOOOOOOOOOOOOO"};

58
lisp/gnus/compface.el Normal file
View File

@ -0,0 +1,58 @@
;;; compface.el --- functions for converting X-Face headers
;; Copyright (C) 2002 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; 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 uncompface (face)
"Convert FACE to pbm.
Requires the external programs `uncompface', and `icontopbm'. On a
GNU/Linux system these might be in packages with names like `compface'
or `faces-xface' and `netpbm' or `libgr-progs', for instance."
(with-temp-buffer
(insert face)
(and (eq 0 (apply 'call-process-region (point-min) (point-max)
"uncompface"
'delete '(t nil) nil))
(progn
(goto-char (point-min))
(insert "/* Width=48, Height=48 */\n")
;; I just can't get "icontopbm" to work correctly on its
;; own in XEmacs. And Emacs doesn't understand un-raw pbm
;; files.
(if (not (featurep 'xemacs))
(eq 0 (call-process-region (point-min) (point-max)
"icontopbm"
'delete '(t nil)))
(shell-command-on-region (point-min) (point-max)
"icontopbm | pnmnoraw"
(current-buffer) t)
t))
(buffer-string))))
(provide 'compface)
;;; arch-tag: f9c78e84-98c0-4142-9682-8ba4cf4c3441
;;; compface.el ends here

20
lisp/gnus/cry.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * cry_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".+++++++++++.",
".++..+++..++.",
".++++++++.++.",
".+++++++.+.+.",
".+++++++.+.+.",
".++++++++..+.",
".+++.....+++.",
".++.+++++.++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

93
lisp/gnus/cu-exit.xpm
View File

@ -1,64 +1,31 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 34 1",
" c Gray0",
". c #0bfb0bfb0bfb",
"X c Gray6",
"o c Gray9",
"O c Gray11",
"+ c Gray12",
"@ c #23f323f323f3",
"# c Gray15",
"$ c #2ff52ff52ff5",
"% c #3fff3fff3fff",
"& c Gray25",
"* c Gray28",
"= c #4ccc4ccc4ccc",
"- c #53e853e853e8",
"; c #5b1a5b1a5b1a",
": c #5fef5fef5fef",
"> c #67e767e767e7",
", c Gray42",
"< c #6ff76ff76ff7",
"1 c #77dc77dc77dc",
"2 c Gray50",
"3 c #866586658665",
"4 c #88a888a888a8",
"5 c Gray56",
"6 c Gray60",
"7 c #9bcb9bcb9bcb",
"8 c #9fff9fff9fff",
"9 c #a7d7a7d7a7d7",
"0 c Gray70",
"q c #b635b635b635",
"w c Gray75",
"e c Gray78",
"r c #dfffdfffdfff",
"t c Gray100",
/* pixels */
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwww-$$$-wwwwwwww",
"wwwwwww9-$w$ttt$wwwwwwww",
"wwwwww:<ro:1ttto::wwwwww",
"wwww1$wrt5 wttt$w$$1wwww",
"wwww1.ttt5 5ww$ttt.1wwww",
"wwwww$8tt+222% 222$wwwww",
"wwwww$%tt%ttt2 ww$6wwwww",
"wwwww$52t%ttt2wtt%wwwwww",
"wwwww1 %r%ttt2w22>wwwwww",
"wwwwww,::X%%%+$w:5wwwwww",
"qqqqqq4*5%t%t255;qqqqqqq",
"6666663#*+2+2%**=6666666",
"6666666=0$w$0*0&36666666",
"6666666=,$9@5*,#66666666",
"6666666= +% 2% #66666666",
"6666666= %e@<2 #66666666",
"6666666:# +666666666",
"666666666=====3666666666",
"666666666666666666666666"
};
static char * cu_exit_xpm[] = {
"24 24 4 1",
" c None",
". c #000000000000",
"X c #FFFFFFFFFFFF",
"o c #999999999999",
" ",
" ",
" ",
" ",
" ",
" ..... ",
" .. .XXX. ",
" ..X..XXXX... ",
" .XXXX.XXXX.X... ",
" ..XXXX.XXX.XXX.. ",
" .XXX.......... ",
" .XXX.XXX.XXX.. ",
" .XX.XXX.XXX. ",
" .XX.XXX.XX.. ",
" ............ ",
" .X.X.X.X.. ",
"ooooooo..........ooooooo",
"ooooooo.X.X.X.X.oooooooo",
"ooooooo.........oooooooo",
"ooooooo..X...X..oooooooo",
"ooooooo...X.X...oooooooo",
"ooooooo........ooooooooo",
"ooooooooo.....oooooooooo",
"oooooooooooooooooooooooo"};

20
lisp/gnus/dead.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * dead_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".+++++++++++.",
".++.+.+.+.++.",
".+++.+++.+++.",
".++.+.+.+.++.",
".+++++++++++.",
".+++++++++++.",
".+.+++++++.+.",
".++.......++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

102
lisp/gnus/describe-group.xpm
View File

@ -1,72 +1,32 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 42 1",
" c Gray0",
". c #099909990999",
"X c #0bfb0bfb0bfb",
"o c #133313331333",
"O c Gray9",
"+ c Gray11",
"@ c #23f323f323f3",
"# c Gray15",
"$ c #2d8d2d8d2d8d",
"% c #399939993999",
"& c #433243324332",
"* c #4ccc4ccc4ccc",
"= c #519151915191",
"- c #53e353e353e3",
"; c #565656565656",
": c Gray36",
"> c #5fdf5fdf5fdf",
", c Gray42",
"< c #6fff6fff6fff",
"1 c Gray45",
"2 c #77f777f777f7",
"3 c #7ccc7ccc7ccc",
"4 c Gray50",
"5 c #865a865a865a",
"6 c Gray58",
"7 c Gray60",
"8 c #9bfb9bfb9bfb",
"9 c Gray62",
"0 c #9fff9fff9fff",
"q c #a0c0a0c0a0c0",
"w c Gray64",
"e c Gray65",
"r c Gray70",
"t c #b635b635b635",
"y c Gray73",
"u c Gray75",
"i c #d332d332d332",
"p c Gray85",
"a c #e665e665e665",
"s c #eccbeccbeccb",
"d c #f998f998f998",
"f c Gray100",
/* pixels */
"&77&77&77&77&77&77&77&77",
"777777777777777777777777",
"77777777777777777iaaa777",
"&77&77&77&77&77<ff<fffp0",
"77777777777777uffffffffp",
"7777777777777udfffffffff",
"&77&77&77&77<ff<ff<ff<ff",
"777777777777ffffffffffff",
"777777777777ffffffffffff",
"&77&77&77&77<ff<ff<ff<ff",
"777777777777ffffffffffff",
"777777777777ffffffffffff",
"&77&77&77&77:ff<ff<ff<ff",
"777777777777rfffffffffff",
"77777&##37770pffffffffff",
"&77%-6ty-#77&7i<ff<ff<fs",
"777*5w7wy*17777pffffffae",
"777$13&7w+*77770rsfffre7",
"&73X:@3*1 *7&77&77&77&77",
"71o2;o***o17777777777777",
"3o,**X%*X377777777777777",
"XO, +##3&77&77&77&77&77",
":;o #50w7777777777777777",
"@oX+57707777777777777777"
};
static char * describe_group_xpm[] = {
"24 24 5 1",
". c None",
" c #000000000000",
"o c #FFFFF5F5ACAC",
"+ c #E1E1E0E0E0E0",
"@ c #C7C7C6C6C6C6",
"........................",
"........................",
".................oooo...",
" .. .. .. .. .. oo oo o.",
"..............oooooooooo",
".............ooooooooooo",
" .. .. .. .. oo oo oo oo",
"............oooooooooooo",
"............oooooooooooo",
" .. .. .. .. oo oo oo oo",
"............oooooooooooo",
"............oooooooooooo",
" .. .. .. .. oo oo oo oo",
"............oooooooooooo",
"..... ...oooooooooooo",
" .. ++ .. .o oo oo oo",
"... @@@+ ....ooooooooo",
"... @ ....oooooooo.",
" . . .. .. .. ..",
". ..............",
" ................",
" .. .. .. .. .. ..",
" ..................",
" ...................."};

472
lisp/gnus/deuglify.el Normal file
View File

@ -0,0 +1,472 @@
;;; deuglify.el --- deuglify broken Outlook (Express) articles
;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2002 Raymond Scholz
;; Author: Raymond Scholz <rscholz@zonix.de>
;; Thomas Steffen (unwrapping algorithm,
;; based on an idea of Stefan Monnier)
;; 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 enables Gnus to repair broken citations produced by
;; common user agents like MS Outlook (Express). It may repair
;; articles of other user agents too.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Outlook sometimes wraps cited lines before sending a message as
;; seen in this example:
;;
;; Example #1
;; ----------
;;
;; John Doe wrote:
;;
;; > This sentence no verb. This sentence no verb. This sentence
;; no
;; > verb. This sentence no verb. This sentence no verb. This
;; > sentence no verb.
;;
;; The function `gnus-article-outlook-unwrap-lines' tries to recognize those
;; erroneously wrapped lines and will unwrap them. I.e. putting the
;; wrapped parts ("no" in this example) back where they belong (at the
;; end of the cited line above).
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Note that some people not only use broken user agents but also
;; practice a bad citation style by omitting blank lines between the
;; cited text and their own text.
;:
;; Example #2
;; ----------
;;
;; John Doe wrote:
;;
;; > This sentence no verb. This sentence no verb. This sentence no
;; You forgot in all your sentences.
;; > verb. This sentence no verb. This sentence no verb. This
;; > sentence no verb.
;;
;; Unwrapping "You forgot in all your sentences." would be illegal as
;; this part wasn't intended to be cited text.
;; `gnus-article-outlook-unwrap-lines' will only unwrap lines if the resulting
;; citation line will be of a certain maximum length. You can control
;; this by adjusting `gnus-outlook-deuglify-unwrap-max'. Also
;; unwrapping will only be done if the line above the (possibly)
;; wrapped line has a minimum length of `gnus-outlook-deuglify-unwrap-min'.
;;
;; Furthermore no unwrapping will be undertaken if the last character
;; is one of the chars specified in
;; `gnus-outlook-deuglify-unwrap-stop-chars'. Setting this to ".?!"
;; inhibits unwrapping if the cited line ends with a full stop,
;; question mark or exclamation mark. Note that this variable
;; defaults to `nil', triggering a few false positives but generally
;; giving you better results.
;;
;; Unwrapping works on every level of citation. Thus you will be able
;; repair broken citations of broken user agents citing broken
;; citations of broken user agents citing broken citations...
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Citations are commonly introduced with an attribution line
;; indicating who wrote the cited text. Outlook adds superfluous
;; information that can be found in the header of the message to this
;; line and often wraps it.
;;
;; If that weren't enough, lots of people write their own text above
;; the cited text and cite the complete original article below.
;;
;; Example #3
;; ----------
;;
;; Hey, John. There's no in all your sentences!
;;
;; John Doe <john.doe@some.domain> wrote in message
;; news:a87usw8$dklsssa$2@some.news.server...
;; > This sentence no verb. This sentence no verb. This sentence
;; no
;; > verb. This sentence no verb. This sentence no verb. This
;; > sentence no verb.
;; >
;; > Bye, John
;;
;; Repairing the attribution line will be done by function
;; `gnus-article-outlook-repair-attribution which calls other function that
;; try to recognize and repair broken attribution lines. See variable
;; `gnus-outlook-deuglify-attrib-cut-regexp' for stuff that should be
;; cut off from the beginning of an attribution line and variable
;; `gnus-outlook-deuglify-attrib-verb-regexp' for the verbs that are
;; required to be found in an attribution line. These function return
;; the point where the repaired attribution line starts.
;;
;; Rearranging the article so that the cited text appears above the
;; new text will be done by function
;; `gnus-article-outlook-rearrange-citation'. This function calls
;; `gnus-article-outlook-repair-attribution to find and repair an attribution
;; line.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Well, and that's what the message will look like after applying
;; deuglification:
;;
;; Example #3 (deuglified)
;; -----------------------
;;
;; John Doe <john.doe@some.domain> wrote:
;;
;; > This sentence no verb. This sentence no verb. This sentence no
;; > verb. This sentence no verb. This sentence no verb. This
;; > sentence no verb.
;; >
;; > Bye, John
;;
;; Hey, John. There's no in all your sentences!
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Usage
;; -----
;;
;; Press `W k' in the Summary Buffer.
;;
;; Non recommended usage :-)
;; ---------------------
;;
;; To automatically invoke deuglification on every article you read,
;; put something like that in your .gnus:
;;
;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-unwrap-lines)
;;
;; or _one_ of the following lines:
;;
;; ;; repair broken attribution lines
;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-repair-attribution)
;;
;; ;; repair broken attribution lines and citations
;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-rearrange-citation)
;;
;; Note that there always may be some false positives, so I suggest
;; using the manual invocation. After deuglification you may want to
;; refill the whole article using `W w'.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Limitations
;; -----------
;;
;; As I said before there may (or will) be a few false positives on
;; unwrapping cited lines with `gnus-article-outlook-unwrap-lines'.
;;
;; `gnus-article-outlook-repair-attribution will only fix the first
;; attribution line found in the article. Furthermore it fixed to
;; certain kinds of attributions. And there may be horribly many
;; false positives, vanishing lines and so on -- so don't trust your
;; eyes. Again I recommend manual invocation.
;;
;; `gnus-article-outlook-rearrange-citation' carries all the limitations of
;; `gnus-article-outlook-repair-attribution.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; See ChangeLog for other changes.
;;
;; Revision 1.5 2002/01/27 14:39:17 rscholz
;; * New variable `gnus-outlook-deuglify-no-wrap-chars' to inhibit
;; unwrapping if one these chars is first in the possibly wrapped line.
;; * Improved rearranging of the article.
;; * New function `gnus-outlook-repair-attribution-block' for repairing
;; those big "Original Message (following some headers)" attributions.
;;
;; Revision 1.4 2002/01/03 14:05:00 rscholz
;; Renamed `gnus-outlook-deuglify-article' to
;; `gnus-article-outlook-deuglify-article'.
;; Made it easier to deuglify the article while being in Gnus' Article
;; Edit Mode. (suggested by Phil Nitschke)
;;
;;
;; Revision 1.3 2002/01/02 23:35:54 rscholz
;; Fix a bug that caused succeeding long attribution lines to be
;; unwrapped. Minor doc fixes and regular expression tuning.
;;
;; Revision 1.2 2001/12/30 20:14:34 rscholz
;; Clean up source.
;;
;; Revision 1.1 2001/12/30 20:13:32 rscholz
;; Initial revision
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Code:
(require 'gnus-art)
(require 'gnus-sum)
(defconst gnus-outlook-deuglify-version "1.5 Gnus version"
"Version of gnus-outlook-deuglify.")
;;; User Customizable Variables:
(defgroup gnus-outlook-deuglify nil
"Deuglify articles generated by broken user agents like MS Outlook (Express).")
;;;###autoload
(defcustom gnus-outlook-deuglify-unwrap-min 45
"Minimum length of the cited line above the (possibly) wrapped line."
:type 'integer
:group 'gnus-outlook-deuglify)
;;;###autoload
(defcustom gnus-outlook-deuglify-unwrap-max 95
"Maximum length of the cited line after unwrapping."
:type 'integer
:group 'gnus-outlook-deuglify)
(defcustom gnus-outlook-deuglify-cite-marks ">|#%"
"Characters that indicate cited lines."
:type 'string
:group 'gnus-outlook-deuglify)
(defcustom gnus-outlook-deuglify-unwrap-stop-chars nil ;; ".?!" or nil
"Characters that inhibit unwrapping if they are the last one on the cited line above the possible wrapped line."
:type '(radio (const :format "None " nil)
(string :size 0 :value ".?!"))
:group 'gnus-outlook-deuglify)
(defcustom gnus-outlook-deuglify-no-wrap-chars "`"
"Characters that inhibit unwrapping if they are the first one in the possibly wrapped line."
:type 'string
:group 'gnus-outlook-deuglify)
(defcustom gnus-outlook-deuglify-attrib-cut-regexp
"\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, "
"Regular expression matching the beginning of an attribution line that should be cut off."
:type 'string
:group 'gnus-outlook-deuglify)
(defcustom gnus-outlook-deuglify-attrib-verb-regexp
"wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió"
"Regular expression matching the verb used in an attribution line."
:type 'string
:group 'gnus-outlook-deuglify)
(defcustom gnus-outlook-deuglify-attrib-end-regexp
": *\\|\\.\\.\\."
"Regular expression matching the end of an attribution line."
:type 'string
:group 'gnus-outlook-deuglify)
;;;###autoload
(defcustom gnus-outlook-display-hook nil
"A hook called after an deuglified article has been prepared.
It is run after `gnus-article-prepare-hook'."
:type 'hook
:group 'gnus-outlook-deuglify)
;; Functions
(defun gnus-outlook-display-article-buffer ()
"Redisplay current buffer or article buffer."
(with-current-buffer (or gnus-article-buffer (current-buffer))
;; "Emulate" `gnus-article-prepare-display' without calling
;; it. Calling `gnus-article-prepare-display' on an already
;; prepared article removes all MIME parts. I'm unsure whether
;; this is a bug or not.
(gnus-article-highlight t)
(gnus-treat-article nil)
(gnus-run-hooks 'gnus-article-prepare-hook
'gnus-outlook-display-hook)))
;;;###autoload
(defun gnus-article-outlook-unwrap-lines (&optional nodisplay)
"Unwrap lines that appear to be wrapped citation lines.
You can control what lines will be unwrapped by frobbing
`gnus-outlook-deuglify-unwrap-min' and `gnus-outlook-deuglify-unwrap-max',
indicating the minimum and maximum length of an unwrapped citation line. If
NODISPLAY is non-nil, don't redisplay the article buffer."
(interactive "P")
(save-excursion
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks)
(no-wrap gnus-outlook-deuglify-no-wrap-chars)
(stop-chars gnus-outlook-deuglify-unwrap-stop-chars))
(gnus-with-article-buffer
(article-goto-body)
(while (re-search-forward
(concat
"^\\([ \t" cite-marks "]*\\)"
"\\([" cite-marks "].*[^\n " stop-chars "]\\)[ \t]?\n"
"\\1\\([^\n " cite-marks no-wrap "]+.*\\)$")
nil t)
(let ((len12 (- (match-end 2) (match-beginning 1)))
(len3 (- (match-end 3) (match-beginning 3))))
(if (and (> len12 gnus-outlook-deuglify-unwrap-min)
(< (+ len12 len3) gnus-outlook-deuglify-unwrap-max))
(progn
(replace-match "\\1\\2 \\3")
(goto-char (match-beginning 0)))))))))
(unless nodisplay (gnus-outlook-display-article-buffer)))
(defun gnus-outlook-rearrange-article (attr-start)
"Put the text from ATTR-START to the end of buffer at the top of the article buffer."
(save-excursion
(let ((inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
;; article does not start with attribution
(unless (= (point) attr-start)
(gnus-kill-all-overlays)
(let ((cur (point))
;; before signature or end of buffer
(to (if (gnus-article-search-signature)
(point)
(point-max))))
;; handle the case where the full quote is below the
;; signature
(if (< to attr-start)
(setq to (point-max)))
(transpose-regions cur attr-start attr-start to)))))))
;; John Doe <john.doe@some.domain> wrote in message
;; news:a87usw8$dklsssa$2@some.news.server...
(defun gnus-outlook-repair-attribution-outlook ()
"Repair a broken attribution line (Outlook)."
(save-excursion
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
(if (re-search-forward
(concat "^\\([^" cite-marks "].+\\)"
"\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\)"
"\\(.*\n?[^\n" cite-marks "].*\\)?"
"\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$")
nil t)
(progn
(gnus-kill-all-overlays)
(replace-match "\\1\\2\\4")
(match-beginning 0)))))))
;; ----- Original Message -----
;; From: "John Doe" <john.doe@some.domain>
;; To: "Doe Foundation" <info@doefnd.org>
;; Sent: Monday, November 19, 2001 12:13 PM
;; Subject: More Doenuts
(defun gnus-outlook-repair-attribution-block ()
"Repair a big broken attribution block."
(save-excursion
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
(if (re-search-forward
(concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n"
"[^\n:]+:[ \t]*\\([^\n]+\\)\n"
"\\([^\n:]+:[ \t]*[^\n]+\n\\)+")
nil t)
(progn
(gnus-kill-all-overlays)
(replace-match "\\1 wrote:\n")
(match-beginning 0)))))))
;; On Wed, 16 Jan 2002 23:23:30 +0100, John Doe <john.doe@some.domain> wrote:
(defun gnus-outlook-repair-attribution-other ()
"Repair a broken attribution line (other user agents than Outlook)."
(save-excursion
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
(if (re-search-forward
(concat "^\\("gnus-outlook-deuglify-attrib-cut-regexp"\\)?"
"\\([^" cite-marks "].+\\)\n\\([^\n" cite-marks "].*\\)?"
"\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\).*"
"\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$")
nil t)
(progn
(gnus-kill-all-overlays)
(replace-match "\\4 \\5\\6\\7")
(match-beginning 0)))))))
;;;###autoload
(defun gnus-article-outlook-repair-attribution (&optional nodisplay)
"Repair a broken attribution line.
If NODISPLAY is non-nil, don't redisplay the article buffer."
(interactive "P")
(let ((attrib-start
(or
(gnus-outlook-repair-attribution-other)
(gnus-outlook-repair-attribution-block)
(gnus-outlook-repair-attribution-outlook))))
(unless nodisplay (gnus-outlook-display-article-buffer))
attrib-start))
(defun gnus-article-outlook-rearrange-citation (&optional nodisplay)
"Repair broken citations.
If NODISPLAY is non-nil, don't redisplay the article buffer."
(interactive "P")
(let ((attrib-start (gnus-article-outlook-repair-attribution 'nodisplay)))
;; rearrange citations if an attribution line has been recognized
(if attrib-start
(gnus-outlook-rearrange-article attrib-start)))
(unless nodisplay (gnus-outlook-display-article-buffer)))
;;;###autoload
(defun gnus-outlook-deuglify-article (&optional nodisplay)
"Full deuglify of broken Outlook (Express) articles.
Treat dumbquotes, unwrap lines, repair attribution and rearrange citation. If
NODISPLAY is non-nil, don't redisplay the article buffer."
(interactive "P")
;; apply treatment of dumb quotes
(gnus-article-treat-dumbquotes)
;; repair wrapped cited lines
(gnus-article-outlook-unwrap-lines 'nodisplay)
;; repair attribution line and rearrange citation.
(gnus-article-outlook-rearrange-citation 'nodisplay)
(unless nodisplay (gnus-outlook-display-article-buffer)))
;;;###autoload
(defun gnus-article-outlook-deuglify-article ()
"Deuglify broken Outlook (Express) articles and redisplay."
(interactive)
(gnus-outlook-deuglify-article nil))
(provide 'deuglify)
;; Local Variables:
;; coding: iso-8859-1
;; End:
;;; arch-tag: 5f895cc9-51a9-487c-b42e-28844d79eb73
;;; deuglify.el ends here

189
lisp/gnus/dig.el Normal file
View File

@ -0,0 +1,189 @@
;;; dig.el --- Domain Name System dig interface
;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: DNS BIND dig
;; 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 provide an interface for "dig".
;;
;; For interactive use, try M-x dig and type a hostname. Use `q' to quit
;; dig buffer.
;;
;; For use in elisp programs, call `dig-invoke' and use
;; `dig-extract-rr' to extract resource records.
;;; Release history:
;; 2000-10-28 posted on gnu.emacs.sources
;;; Code:
(eval-when-compile (require 'cl))
(defgroup dig nil
"Dig configuration.")
(defcustom dig-program "dig"
"Name of dig (domain information groper) binary."
:type 'file
:group 'dig)
(defcustom dig-dns-server nil
"DNS server to query.
If nil, use system defaults."
:type '(choice (const :tag "System defaults")
string)
:group 'dig)
(defcustom dig-font-lock-keywords
'(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face)
("^;;.*" 0 font-lock-comment-face)
("^; <<>>.*" 0 font-lock-type-face)
("^;.*" 0 font-lock-function-name-face))
"Default expressions to highlight in dig mode."
:type 'sexp
:group 'dig)
(defun dig-invoke (domain &optional
query-type query-class query-option
dig-option server)
"Call dig with given arguments and return buffer containing output.
DOMAIN is a string with a DNS domain. QUERY-TYPE is an optional string
with a DNS type. QUERY-CLASS is an optional string with a DNS class.
QUERY-OPTION is an optional string with dig \"query options\".
DIG-OPTIONS is an optional string with parameters for the dig program.
SERVER is an optional string with a domain name server to query.
Dig is an external program found in the BIND name server distribution,
and is a commonly available debugging tool."
(let (buf cmdline)
(setq buf (generate-new-buffer "*dig output*"))
(if dig-option (push dig-option cmdline))
(if query-option (push query-option cmdline))
(if query-class (push query-class cmdline))
(if query-type (push query-type cmdline))
(push domain cmdline)
(if server (push (concat "@" server) cmdline)
(if dig-dns-server (push (concat "@" dig-dns-server) cmdline)))
(apply 'call-process dig-program nil buf nil cmdline)
buf))
(defun dig-extract-rr (domain &optional type class)
"Extract resource records for DOMAIN, TYPE and CLASS from buffer.
Buffer should contain output generated by `dig-invoke'."
(save-excursion
(goto-char (point-min))
(if (re-search-forward
(concat domain "\\.?[\t ]+[0-9wWdDhHmMsS]+[\t ]+"
(upcase (or class "IN")) "[\t ]+" (upcase (or type "A")))
nil t)
(let (b e)
(end-of-line)
(setq e (point))
(beginning-of-line)
(setq b (point))
(when (search-forward " (" e t)
(search-forward " )"))
(end-of-line)
(setq e (point))
(buffer-substring b e))
(and (re-search-forward (concat domain "\\.?[\t ]+[0-9wWdDhHmMsS]+[\t ]+"
(upcase (or class "IN"))
"[\t ]+CNAME[\t ]+\\(.*\\)$") nil t)
(dig-extract-rr (match-string 1) type class)))))
(defun dig-rr-get-pkix-cert (rr)
(let (b e str)
(string-match "[^\t ]+[\t ]+[0-9wWdDhHmMsS]+[\t ]+IN[\t ]+CERT[\t ]+\\(1\\|PKIX\\)[\t ]+[0-9]+[\t ]+[0-9]+[\t ]+(?" rr)
(setq b (match-end 0))
(string-match ")" rr)
(setq e (match-beginning 0))
(setq str (substring rr b e))
(while (string-match "[\t \n\r]" str)
(setq str (replace-match "" nil nil str)))
str))
;; XEmacs does it like this. For Emacs, we have to set the
;; `font-lock-defaults' buffer-local variable.
(put 'dig-mode 'font-lock-defaults '(dig-font-lock-keywords t))
(put 'dig-mode 'mode-class 'special)
(defvar dig-mode-map nil)
(unless dig-mode-map
(setq dig-mode-map (make-sparse-keymap))
(suppress-keymap dig-mode-map)
(define-key dig-mode-map "q" 'dig-exit))
(defun dig-mode ()
"Major mode for displaying dig output."
(interactive)
(kill-all-local-variables)
(setq mode-name "dig")
(setq major-mode 'dig-mode)
(use-local-map dig-mode-map)
(buffer-disable-undo)
(unless (featurep 'xemacs)
(set (make-local-variable 'font-lock-defaults)
'(dig-font-lock-keywords t)))
(when (featurep 'font-lock)
(font-lock-set-defaults)))
(defun dig-exit ()
"Quit dig output buffer."
(interactive)
(kill-buffer (current-buffer)))
(defun dig (domain &optional
query-type query-class query-option dig-option server)
"Query addresses of a DOMAIN using dig, by calling `dig-invoke'.
Optional arguments are passed to `dig-invoke'."
(interactive "sHost: ")
(switch-to-buffer
(dig-invoke domain query-type query-class query-option dig-option server))
(goto-char (point-min))
(and (search-forward ";; ANSWER SECTION:" nil t)
(forward-line))
(dig-mode)
(setq buffer-read-only t)
(set-buffer-modified-p nil))
;; named for consistency with query-dns in dns.el
(defun query-dig (domain &optional
query-type query-class query-option dig-option server)
"Query addresses of a DOMAIN using dig.
It works by calling `dig-invoke' and `dig-extract-rr'. Optional
arguments are passed to `dig-invoke' and `dig-extract-rr'. Returns
nil for domain/class/type queries that results in no data."
(let ((buffer (dig-invoke domain query-type query-class
query-option dig-option server)))
(when buffer
(switch-to-buffer buffer)
(let ((digger (dig-extract-rr domain query-type query-class)))
(kill-buffer buffer)
digger))))
(provide 'dig)
;;; arch-tag: 1d61726e-9400-4013-9ae7-4035e0c7f7d6
;;; dig.el ends here

359
lisp/gnus/dns.el Normal file
View File

@ -0,0 +1,359 @@
;;; dns.el --- Domain Name Service lookups
;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: network
;; 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 'mm-util)
(defvar dns-timeout 5
"How many seconds to wait when doing DNS queries.")
(defvar dns-servers nil
"Which DNS servers to query.
If nil, /etc/resolv.conf will be consulted.")
;;; Internal code:
(defvar dns-query-types
'((A 1)
(NS 2)
(MD 3)
(MF 4)
(CNAME 5)
(SOA 6)
(MB 7)
(MG 8)
(MR 9)
(NULL 10)
(WKS 11)
(PRT 12)
(HINFO 13)
(MINFO 14)
(MX 15)
(TXT 16)
(AXFR 252)
(MAILB 253)
(MAILA 254)
(* 255))
"Names of query types and their values.")
(defvar dns-classes
'((IN 1)
(CS 2)
(CH 3)
(HS 4))
"Classes of queries.")
(defun dns-write-bytes (value &optional length)
(let (bytes)
(dotimes (i (or length 1))
(push (% value 256) bytes)
(setq value (/ value 256)))
(dolist (byte bytes)
(insert byte))))
(defun dns-read-bytes (length)
(let ((value 0))
(dotimes (i length)
(setq value (logior (* value 256) (following-char)))
(forward-char 1))
value))
(defun dns-get (type spec)
(cadr (assq type spec)))
(defun dns-inverse-get (value spec)
(let ((found nil))
(while (and (not found)
spec)
(if (eq value (cadr (car spec)))
(setq found (caar spec))
(pop spec)))
found))
(defun dns-write-name (name)
(dolist (part (split-string name "\\."))
(dns-write-bytes (length part))
(insert part))
(dns-write-bytes 0))
(defun dns-read-string-name (string buffer)
(mm-with-unibyte-buffer
(insert string)
(goto-char (point-min))
(dns-read-name buffer)))
(defun dns-read-name (&optional buffer)
(let ((ended nil)
(name nil)
length)
(while (not ended)
(setq length (dns-read-bytes 1))
(if (= 192 (logand length (lsh 3 6)))
(let ((offset (+ (* (logand 63 length) 256)
(dns-read-bytes 1))))
(save-excursion
(when buffer
(set-buffer buffer))
(goto-char (1+ offset))
(setq ended (dns-read-name buffer))))
(if (zerop length)
(setq ended t)
(push (buffer-substring (point)
(progn (forward-char length) (point)))
name))))
(if (stringp ended)
(if (null name)
ended
(concat (mapconcat 'identity (nreverse name) ".") "." ended))
(mapconcat 'identity (nreverse name) "."))))
(defun dns-write (spec &optional tcp-p)
"Write a DNS packet according to SPEC.
If TCP-P, the first two bytes of the package with be the length field."
(with-temp-buffer
(dns-write-bytes (dns-get 'id spec) 2)
(dns-write-bytes
(logior
(lsh (if (dns-get 'response-p spec) 1 0) -7)
(lsh
(cond
((eq (dns-get 'opcode spec) 'query) 0)
((eq (dns-get 'opcode spec) 'inverse-query) 1)
((eq (dns-get 'opcode spec) 'status) 2)
(t (error "No such opcode: %s" (dns-get 'opcode spec))))
-3)
(lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
(lsh (if (dns-get 'truncated-p spec) 1 0) -1)
(lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
(dns-write-bytes
(cond
((eq (dns-get 'response-code spec) 'no-error) 0)
((eq (dns-get 'response-code spec) 'format-error) 1)
((eq (dns-get 'response-code spec) 'server-failure) 2)
((eq (dns-get 'response-code spec) 'name-error) 3)
((eq (dns-get 'response-code spec) 'not-implemented) 4)
((eq (dns-get 'response-code spec) 'refused) 5)
(t 0)))
(dns-write-bytes (length (dns-get 'queries spec)) 2)
(dns-write-bytes (length (dns-get 'answers spec)) 2)
(dns-write-bytes (length (dns-get 'authorities spec)) 2)
(dns-write-bytes (length (dns-get 'additionals spec)) 2)
(dolist (query (dns-get 'queries spec))
(dns-write-name (car query))
(dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
dns-query-types)) 2)
(dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
dns-classes)) 2))
(dolist (slot '(answers authorities additionals))
(dolist (resource (dns-get slot spec))
(dns-write-name (car resource))
(dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
2)
(dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
2)
(dns-write-bytes (dns-get 'ttl resource) 4)
(dns-write-bytes (length (dns-get 'data resource)) 2)
(insert (dns-get 'data resource))))
(when tcp-p
(goto-char (point-min))
(dns-write-bytes (buffer-size) 2))
(buffer-string)))
(defun dns-read (packet)
(mm-with-unibyte-buffer
(let ((spec nil)
queries answers authorities additionals)
(insert packet)
(goto-char (point-min))
(push (list 'id (dns-read-bytes 2)) spec)
(let ((byte (dns-read-bytes 1)))
(push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
spec)
(let ((opcode (logand byte (lsh 7 3))))
(push (list 'opcode
(cond ((eq opcode 0) 'query)
((eq opcode 1) 'inverse-query)
((eq opcode 2) 'status)))
spec))
(push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
nil t)) spec)
(push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
spec)
(push (list 'recursion-desired-p
(if (zerop (logand byte (lsh 1 0))) nil t)) spec))
(let ((rc (logand (dns-read-bytes 1) 15)))
(push (list 'response-code
(cond
((eq rc 0) 'no-error)
((eq rc 1) 'format-error)
((eq rc 2) 'server-failure)
((eq rc 3) 'name-error)
((eq rc 4) 'not-implemented)
((eq rc 5) 'refused)))
spec))
(setq queries (dns-read-bytes 2))
(setq answers (dns-read-bytes 2))
(setq authorities (dns-read-bytes 2))
(setq additionals (dns-read-bytes 2))
(let ((qs nil))
(dotimes (i queries)
(push (list (dns-read-name)
(list 'type (dns-inverse-get (dns-read-bytes 2)
dns-query-types))
(list 'class (dns-inverse-get (dns-read-bytes 2)
dns-classes)))
qs))
(push (list 'queries qs) spec))
(dolist (slot '(answers authorities additionals))
(let ((qs nil)
type)
(dotimes (i (symbol-value slot))
(push (list (dns-read-name)
(list 'type
(setq type (dns-inverse-get (dns-read-bytes 2)
dns-query-types)))
(list 'class (dns-inverse-get (dns-read-bytes 2)
dns-classes))
(list 'ttl (dns-read-bytes 4))
(let ((length (dns-read-bytes 2)))
(list 'data
(dns-read-type
(buffer-substring
(point)
(progn (forward-char length) (point)))
type))))
qs))
(push (list slot qs) spec)))
(nreverse spec))))
(defun dns-read-type (string type)
(let ((buffer (current-buffer))
(point (point)))
(prog1
(mm-with-unibyte-buffer
(insert string)
(goto-char (point-min))
(cond
((eq type 'A)
(let ((bytes nil))
(dotimes (i 4)
(push (dns-read-bytes 1) bytes))
(mapconcat 'number-to-string (nreverse bytes) ".")))
((eq type 'NS)
(dns-read-string-name string buffer))
((eq type 'CNAME)
(dns-read-string-name string buffer))
(t string)))
(goto-char point))))
(defun dns-parse-resolv-conf ()
(when (file-exists-p "/etc/resolv.conf")
(with-temp-buffer
(insert-file-contents "/etc/resolv.conf")
(goto-char (point-min))
(while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
(push (match-string 1) dns-servers))
(setq dns-servers (nreverse dns-servers)))))
;;; Interface functions.
(eval-when-compile
(when (featurep 'xemacs)
(require 'gnus-xmas)))
(defmacro dns-make-network-process (server)
(if (featurep 'xemacs)
`(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(gnus-xmas-open-network-stream "dns" (current-buffer)
,server "domain" 'udp))
`(let ((server ,server)
(coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(if (fboundp 'make-network-process)
(make-network-process
:name "dns"
:coding 'binary
:buffer (current-buffer)
:host server
:service "domain"
:type 'datagram)
;; Older versions of Emacs doesn't have
;; `make-network-process', so we fall back on opening a TCP
;; connection to the DNS server.
(open-network-stream "dns" (current-buffer) server "domain")))))
(defun query-dns (name &optional type fullp)
"Query a DNS server for NAME of TYPE.
If FULLP, return the entire record returned."
(setq type (or type 'A))
(unless dns-servers
(dns-parse-resolv-conf))
(if (not dns-servers)
(message "No DNS server configuration found")
(mm-with-unibyte-buffer
(let ((process (condition-case ()
(dns-make-network-process (car dns-servers))
(error
(message "dns: Got an error while trying to talk to %s"
(car dns-servers))
nil)))
(tcp-p (and (not (fboundp 'make-network-process))
(not (featurep 'xemacs))))
(step 100)
(times (* dns-timeout 1000))
(id (random 65000)))
(when process
(process-send-string
process
(dns-write `((id ,id)
(opcode query)
(queries ((,name (type ,type))))
(recursion-desired-p t))
tcp-p))
(while (and (zerop (buffer-size))
(> times 0))
(accept-process-output process 0 step)
(decf times step))
(ignore-errors
(delete-process process))
(when tcp-p
(goto-char (point-min))
(delete-region (point) (+ (point) 2)))
(unless (zerop (buffer-size))
(let ((result (dns-read (buffer-string))))
(if fullp
result
(let ((answer (car (dns-get 'answers result))))
(when (eq type (dns-get 'type answer))
(dns-get 'data answer)))))))))))
(provide 'dns)
;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
;;; dns.el ends here

10
lisp/gnus/earcon.el
View File

@ -1,6 +1,6 @@
;;; earcon.el --- sound effects for messages
;;; earcon.el --- Sound effects for messages
;; Copyright (C) 1996, 2000, 2001 Free Software Foundation
;; Copyright (C) 1996, 2000, 2001, 2003 Free Software Foundation
;; Author: Steven L. Baur <steve@miranova.com>
@ -20,10 +20,8 @@
;; 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.
;; This file is part of GNU Emacs.
;;; Commentary:
;; This file provides access to sound effects in Gnus.
;;; Code:
@ -52,7 +50,7 @@
("evil[ \t]+laugh" 1 "Evil_Laugh.au")
("gag\\|puke" 1 "Puke.au")
("snicker" 1 "Snicker.au")
("meow" 1 "catmeow.au")
("meow" 1 "catmeow.wav")
("sob\\|boohoo" 1 "cry.wav")
("drum[ \t]*roll" 1 "drumroll.au")
("blast" 1 "explosion.au")
@ -80,7 +78,7 @@ 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))
(data (get-text-property pos 'earcon-data))
(fun (get-text-property pos 'earcon-callback)))
(if fun (funcall fun data))))

20
lisp/gnus/evil.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * diabolic_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".++.+++++.++.",
".++..+++..++.",
".++...+...++.",
".+++++++++++.",
".+.+++++++.+.",
".++.+++++.++.",
".+++.+++.+++.",
".++++...++++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

107
lisp/gnus/exit-gnus.xpm
View File

@ -1,76 +1,33 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 46 1",
" c Gray0",
". c Gray6",
"X c #133313331333",
"o c Gray11",
"O c Gray12",
"+ c Gray15",
"@ c #2ff82ff82ff8",
"# c Gray20",
"$ c #399939993999",
"% c #3fff3fff3fff",
"& c Gray25",
"* c Gray28",
"= c #4ccc4ccc4ccc",
"- c #53e353e353e3",
"; c #565e565e565e",
": c #5b1a5b1a5b1a",
"> c #5ff55ff55ff5",
", c #626262626262",
"< c Gray40",
"1 c #67e767e767e7",
"2 c Gray42",
"3 c #6ff96ff96ff9",
"4 c Gray45",
"5 c #77d777d777d7",
"6 c #7ccc7ccc7ccc",
"7 c Gray50",
"8 c Gray56",
"9 c #97f797f797f7",
"0 c Gray60",
"q c #9bd19bd19bd1",
"w c #9ff29ff29ff2",
"e c #a7cba7cba7cb",
"r c Gray67",
"t c #afd5afd5afd5",
"y c Gray70",
"u c Gray75",
"i c #c3c3c3c3c3c3",
"p c Gray78",
"a c #cbcbcbcbcbcb",
"s c Gray81",
"d c #d7d8d7d8d7d8",
"f c #dff2dff2dff2",
"g c Gray89",
"h c #e7e7e7e7e7e7",
"j c #eff8eff8eff8",
"k c Gray100",
/* pixels */
"kkkkkkkkkufkkkku7skkkkkk",
"kkkkkkkkw>%fkkw 7kkkkkkk",
"kk3%wkkksu ukk%u7skkkkkk",
"kww>>@@uu3f@8 @@7.@Owskk",
"kkwf777%>77O> >>%7777wkk",
"kkkkkss7j8O.@ 8jujsfjkkk",
"kkkjuuwO @> @>@@ujkkkkkk",
"kkk>%O77O$ > %f >kkkkkk",
"kkk87sj7<=u>@7s8>@%wkkkk",
"kkkkkkq==u>>u ukk3u7kkkk",
"7uwfuw+=>u u> >fuw7uwwuf",
"8twut#>:8q q8* uprwswwtu",
"ipuge&,5uq5uau-@uuuuuadu",
"psuu>4@uuuuuduu5uuduuuuu",
"uugu>4@uuguuuuuuuuauuuuu",
"uuuy:>-uuuuuuugguaaugguu",
"psu8=+uuuuspuuuuudduuuuu",
"ipu8=+uuujfhguuuuuudauuu",
"ue82=+8euuuuishspujdgguu",
"e@$$+X=;>uu5ttp9sduuuuuu",
"&4$8$ 7=4@@5y>qejdjduuuu",
";$4O4444444O@eye5@uuusfd",
">>>>3<>@*<3>@wp9f7uuufsd",
"uuujfhgedhfjqpswsiuuuuuu"
};
static char * exit_gnus_xpm[] = {
"24 24 6 1",
" c None",
". c #8686ADAD7D7D",
"X c #919187876969",
"o c #C2C2B9B99C9C",
"O c #A8A8F0F0ECEC",
"+ c #EFEFEFEFEFEF",
" ",
" .... . ",
" .. .. . ",
" ............. ",
" . . . .... ",
" ............. ",
" .............. .. ",
" . . .......... . ",
" .XXXX... .. ",
" o.XXX. . .. ",
" oo.X. .. ... ",
" ooX. . ... ",
" oXo. .. ",
" ooX . . ",
" ooX ",
"OOOOoXXOOOOOOOOOOOOOOOOO",
"OOOoXoXOOOOOOOOOOOOOOOOO",
"OOOooXXOOOO+OOOOOOOOOOOO",
"O+OoooXOO+OOO+OO+OOO+OOO",
"OXXoXoXoXOO++O++OO++OO+O",
"XXXXXXXXXXXX+OOOOOOOOOOO",
"XXXXXXXXXXXXXX+O++OO++OO",
"XXXXXXXXXXXXXXXXOOOOOOOO",
"O++O++++O+OO++OOOO++OOO+"};

73
lisp/gnus/exit-summ.xpm
View File

@ -1,45 +1,30 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 15 1",
" c Gray0",
". c #0bfb0bfb0bfb",
"X c Gray9",
"o c #23f323f323f3",
"O c #2fef2fef2fef",
"+ c Gray28",
"@ c #53e353e353e3",
"# c #5fdf5fdf5fdf",
"$ c Gray42",
"% c #77d777d777d7",
"& c Gray56",
"* c #9bcb9bcb9bcb",
"= c #a7c7a7c7a7c7",
"- c Gray70",
"; c Gray75",
/* pixels */
"@;;@;;@;;@;;@;;@;;@;;@;;",
";;;;;;;;;;;;;;;;;;;;;;;;",
";;;;;;;;;;;;;;;;;;;;;;;;",
"@;;@;;&=@OOOo O;;@;;",
";;;;;;X&;;;;=## O;;;;;",
";;;;;;.%;;;;;;; O;;;;;",
"@;;@;;@;;@;;*;; O;;@;;",
";;;;;;;;;;;;%;; O;;;;;",
";;;;;;O%;;;;;;; O;;;;;",
"@;;@;;o=;@;;-&- O;;@;;",
";;;;;;X&;;;;+ & O;;;;;",
";;;;;;.%;;;;$ & O;;;;;",
"@;;@;;o=;@;;;;; O;;@;;",
";;;;;;X&;;;;;;; O;;;;;",
";;;;;;*;;;;;@;; O;;;;;",
"@;;@;;&=;@;;;;; O;;@;;",
";;;;;; #;;;;;&#XO+O;;;;;",
";;;;;;o=;*OO*#o%#+*;;;;;",
"@;;@;@;%OOOO@%*@%*@;;@;;",
";;;;;;;;;;;;;;;;;;;;;;;;",
";;;;;;;;;;;;;;;;;;;;;;;;",
"@;;@;;@;;@;;@;;@;;@;;@;;",
";;;;;;;;;;;;;;;;;;;;;;;;",
";;;;;;;;;;;;;;;;;;;;;;;;"
};
static char * exit_summ_xpm[] = {
"24 24 3 1",
". c None",
" c #000000000000",
"X c #E1E1E0E0E0E0",
" .. .. .. .. .. .. .. ..",
"........................",
"........................",
" .. .. .. ..",
"...... XXXX .....",
"...... XXXXXXX .....",
" .. .. XX XX XX .. ..",
"...... XXXXXXXX .....",
"...... XXXXXXX .....",
" .. .. X XX .. ..",
"...... XXXX .....",
"...... XXXX .....",
" .. .. X XXXXX .. ..",
"...... XXXXXXX .....",
"...... XXXXX XX .....",
" .. .. X XXXXX .. ..",
"...... XXXXX .....",
"...... X .....",
" .. . . .. ..",
"........................",
"........................",
" .. .. .. .. .. .. .. ..",
"........................",
"........................"};

135
lisp/gnus/flow-fill.el
View File

@ -1,6 +1,6 @@
;;; flow-fill.el --- interprete RFC2646 "flowed" text
;; Copyright (C) 2000, 2002 Free Software Foundation, Inc.
;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: mail
@ -35,10 +35,10 @@
;; paragraph and we let `fill-region' fill the long line into several
;; lines with the quote prefix as `fill-prefix'.
;; Todo: encoding, implement basic `fill-region' (Emacs and XEmacs
;; Todo: implement basic `fill-region' (Emacs and XEmacs
;; implementations differ..)
;; History:
;;; History:
;; 2000-02-17 posted on ding mailing list
;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs
@ -46,11 +46,30 @@
;; 2000-03-26 committed to gnus cvs
;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule
;; work when first line is at level 0.
;; 2002-01-12 probably incomplete encoding support
;; 2003-12-08 started working on test harness.
;;; Code:
(eval-when-compile (require 'cl))
(defcustom fill-flowed-display-column 'fill-column
"Column beyond which format=flowed lines are wrapped, when displayed.
This can be a Lisp expression or an integer."
:type '(choice (const :tag "Standard `fill-column'" fill-column)
(const :tag "Fit Window" (- (window-width) 5))
(sexp)
(integer)))
(defcustom fill-flowed-encode-column 66
"Column beyond which format=flowed lines are wrapped, in outgoing messages.
This can be a Lisp expression or an integer.
RFC 2646 suggests 66 characters for readability."
:type '(choice (const :tag "Standard fill-column" fill-column)
(const :tag "RFC 2646 default (66)" 66)
(sexp)
(integer)))
(eval-and-compile
(defalias 'fill-flowed-point-at-bol
(if (fboundp 'point-at-bol)
@ -62,6 +81,29 @@
'point-at-eol
'line-end-position)))
;;;###autoload
(defun fill-flowed-encode (&optional buffer)
(with-current-buffer (or buffer (current-buffer))
;; No point in doing this unless hard newlines is used.
(when use-hard-newlines
(let ((start (point-min)) end)
;; Go through each paragraph, filling it and adding SPC
;; as the last character on each line.
(while (setq end (text-property-any start (point-max) 'hard 't))
(let ((fill-column (eval fill-flowed-encode-column)))
(fill-region start end t 'nosqueeze 'to-eop))
(goto-char start)
;; `fill-region' probably distorted end.
(setq end (text-property-any start (point-max) 'hard 't))
(while (and (< (point) end)
(re-search-forward "$" (1- end) t))
(insert " ")
(setq end (1+ end))
(forward-char))
(goto-char (setq start (1+ end)))))
t)))
;;;###autoload
(defun fill-flowed (&optional buffer)
(save-excursion
(set-buffer (or (current-buffer) buffer))
@ -70,7 +112,8 @@
(when (save-excursion
(beginning-of-line)
(looking-at "^\\(>*\\)\\( ?\\)"))
(let ((quote (match-string 1)) sig)
(let ((quote (match-string 1))
sig)
(if (string= quote "")
(setq quote nil))
(when (and quote (string= (match-string 2) ""))
@ -79,6 +122,7 @@
(beginning-of-line)
(when (> (skip-chars-forward ">") 0)
(insert " "))))
;; XXX slightly buggy handling of "-- "
(while (and (save-excursion
(ignore-errors (backward-char 3))
(setq sig (looking-at "-- "))
@ -86,17 +130,90 @@
(save-excursion
(unless (eobp)
(forward-char 1)
(looking-at (format "^\\(%s\\)\\([^>]\\)" (or quote " ?"))))))
(looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
(or quote " ?"))))))
(save-excursion
(replace-match (if (string= (match-string 2) " ")
"" "\\2")))
(backward-delete-char -1)
(end-of-line))
(unless sig
(let ((fill-prefix (when quote (concat quote " "))))
(fill-region (fill-flowed-point-at-bol)
(fill-flowed-point-at-eol)
'left 'nosqueeze))))))))
(condition-case nil
(let ((fill-prefix (when quote (concat quote " ")))
(fill-column (eval fill-flowed-display-column))
filladapt-mode)
(fill-region (fill-flowed-point-at-bol)
(min (1+ (fill-flowed-point-at-eol))
(point-max))
'left 'nosqueeze))
(error
(forward-line 1)
nil))))))))
;; Test vectors.
(eval-when-compile
(defvar show-trailing-whitespace))
(defvar fill-flowed-encode-tests
'(
;; The syntax of each list element is:
;; (INPUT . EXPECTED-OUTPUT)
("> Thou villainous ill-breeding spongy dizzy-eyed
> reeky elf-skinned pigeon-egg!
>> Thou artless swag-bellied milk-livered
>> dismal-dreaming idle-headed scut!
>>> Thou errant folly-fallen spleeny reeling-ripe
>>> unmuzzled ratsbane!
>>>> Henceforth, the coding style is to be strictly
>>>> enforced, including the use of only upper case.
>>>>> I've noticed a lack of adherence to the coding
>>>>> styles, of late.
>>>>>> Any complaints?
" . "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned
> pigeon-egg!
>> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed
>> scut!
>>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!
>>>> Henceforth, the coding style is to be strictly enforced,
>>>> including the use of only upper case.
>>>>> I've noticed a lack of adherence to the coding styles, of late.
>>>>>> Any complaints?
")
; ("
;> foo
;>
;>
;> bar
;" . "
;> foo bar
;")
))
(defun fill-flowed-test ()
(interactive "")
(switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
(erase-buffer)
(setq show-trailing-whitespace t)
(dolist (test fill-flowed-encode-tests)
(let (start output)
(insert "***** BEGIN TEST INPUT *****\n")
(insert (car test))
(insert "***** END TEST INPUT *****\n\n")
(insert "***** BEGIN TEST OUTPUT *****\n")
(setq start (point))
(insert (car test))
(save-restriction
(narrow-to-region start (point))
(fill-flowed))
(setq output (buffer-substring start (point-max)))
(insert "***** END TEST OUTPUT *****\n")
(unless (string= output (cdr test))
(insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
(insert (cdr test))
(insert "***** END TEST EXPECTED OUTPUT *****\n"))
(insert "\n\n")))
(goto-char (point-max)))
(provide 'flow-fill)

83
lisp/gnus/followup.xpm
View File

@ -1,54 +1,31 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 24 1",
" c Gray0",
". c Gray6",
"X c Gray9",
"o c Gray12",
"O c #2ff22ff22ff2",
"+ c #3fff3fff3fff",
"@ c Gray28",
"# c #53ed53ed53ed",
"$ c #5fee5fee5fee",
"% c #67e767e767e7",
"& c #6fff6fff6fff",
"* c #77f077f077f0",
"= c #7bdb7bdb7bdb",
"- c Gray50",
"; c Gray56",
": c #9bd79bd79bd7",
"> c #9fff9fff9fff",
", c #a7c7a7c7a7c7",
"< c Gray70",
"1 c Gray75",
"2 c Gray81",
"3 c #dfffdfffdfff",
"4 c #efffefffefff",
"5 c Gray100",
/* pixels */
"<,1<,1<,1<,1<,1<,1<,1<,1",
",;1,;1,;1,;1,;1,;1,;1,;1",
"111111111111111111111111",
"<,1<,1<,1<,:=+.<,1<,1<,1",
",;1,;1,;1;O*>5+$;1,;1,;1",
"11111111##142+>O11111111",
"<,1<,:=+2555 o2#,1<,1<,1",
",;1;O*>5555>-151$1,;1,;1",
"111<@15555525554*:111111",
"<,1<$:5555555555>=<,1<,1",
",;1,;*>553--55555+,;1,;1",
"111111=>&$1O555552#11111",
"<,111:=+241$+55555#,1<,1",
",;1,$*>55$ 1+555551$1,;1",
"11##14555 $4>>55554*:111",
"<@155555&5551-55555>=<,1",
",O15555555553-355551o,;1",
"1,#55555555553$555+%;111",
"<,#25555555555&1*O<,1<,1",
",;1+55555555555X;1,;1,;1",
"111=>5555555555:*1111111",
"<,1:*45555555552%<<,1<,1",
",;11$15555555555-;,;1,;1",
"1111,#55555555553#111111"
};
static char * followup_xpm[] = {
"24 24 4 1",
" c None",
". c #A5A5A5A59595",
"X c #C7C7C6C6C6C6",
"o c #E1E1E0E0E0E0",
" ",
" . ",
" ..X. ",
" ..XXX. ",
" ..XXXXXo. ",
" ...XXXXXXooo. . ",
" .o.XXXXXooooo..X. ",
" .oo.XXXoooo..XXX. ",
" .oo..Xooo..XXXXXo. ",
" .oo.XX...XXXXXXooo. ",
" .o.Xoo.o.XXXXXoooo. ",
" .XXoo.oo.XXXoooooo. ",
" .Xooo.oo..XXooooooo. ",
" .ooo.oo.XXooooooooo. ",
" .ooo.o.XoooooooooooX.",
" .ooo.XXoooooooooooo.",
" .ooo.Xoooooooooooo. ",
" .ooo.ooooooooooo. ",
" .oo..oooooooooo. ",
" .. .ooooooo.. ",
" .oooooo. ",
" .ooo.. ",
" .oo. ",
" .. "};

20
lisp/gnus/forced.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * forced_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".+++++++++++.",
".++..+++..++.",
".++..+++..++.",
".+++++++++++.",
".+++++++++++.",
".+.+++++++.+.",
".+.+++++++.+.",
".+.........+.",
".+++++++++++.",
" ...+++++... ",
" ....... "};

20
lisp/gnus/frown.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * frown_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".++..+++..++.",
".++++.+.++++.",
".+...+++...+.",
".+...+++...+.",
".+++++++++++.",
".+++.....+++.",
".++.+++++.++.",
".++.+++++.++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

82
lisp/gnus/fuwo.xpm
View File

@ -1,53 +1,31 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 23 1",
" c Gray0",
". c Gray6",
"X c Gray9",
"o c Gray12",
"O c #2fef2fef2fef",
"+ c #3fff3fff3fff",
"@ c #53ee53ee53ee",
"# c #5fe85fe85fe8",
"$ c #67e767e767e7",
"% c #6fff6fff6fff",
"& c #77ea77ea77ea",
"* c #7bdb7bdb7bdb",
"= c Gray50",
"- c Gray56",
"; c #9bd69bd69bd6",
": c #9fff9fff9fff",
"> c #a7c7a7c7a7c7",
", c Gray70",
"< c Gray75",
"1 c Gray81",
"2 c #dfffdfffdfff",
"3 c #efffefffefff",
"4 c Gray100",
/* pixels */
",><,><,><,><,><,><,><,><",
">-<>-<>-<>-<>-<>-<>-<>-<",
"<<<<<<<<<<<<<<<<<<<<<<<<",
",><,><,><,><,><,><,><,><",
">-<>-<>-<>-<>-<>-<>-<>-<",
"<<<<<<<<<<<<;O;<<<<<<<<<",
",><,><,><,>< X;,><,><,><",
">-<>-<>-<>-&#-<>-<>-<>-<",
"<<<<<<<<<<<;<<<<<<<<<<<<",
",><,><,><,><,><,><,><,><",
">-<>-<>-<-O>>-<>-<>-<>-<",
"<<<<<<<<@@<@<<<<<<<<<<<<",
",><<<;*+1<<#;<<,><,><,><",
">-<>#&:<==+#&-<>-<>-<>-<",
"<<@@<3+=<1o <#<<<<<<<<<<",
",>O<=+444:+.4=-,><,><,><",
">-O=<4444:4::<$>-<>-<>-<",
"<&;444444444+4+<<<<<<<<<",
",#;444444444<=4O<<,><,><",
">-O4444444442=2&-<>-<>-<",
"<<;%444444444=<<#<<<<<<<",
",><@2444444444+4=-,><,><",
">-<-=444444444::<$>-<>-<",
"<<<,$1444444444+4+<<<<<<"
};
static char * fuwo_xpm[] = {
"24 24 4 1",
" c None",
". c #A5A5A5A59595",
"X c #C7C7C6C6C6C6",
"o c #E1E1E0E0E0E0",
" ",
" . ",
" .. . ",
" .. . ",
" .. . ",
" ... . . ",
" . . ..X. ",
" . . ..XXX. ",
" . .. ..XXXXXo. ",
" . . ...XXXXXXooo. ",
" . .X .o.XXXXXoooo. ",
" .XX .oo.XXXoooooo. ",
" .X .oo..XXooooooo. ",
" . .oo.XXooooooooo. ",
" . .o.XoooooooooooX.",
" . .XXoooooooooooo.",
" . .Xoooooooooooo. ",
" . .ooooooooooo. ",
" . ..oooooooooo. ",
" .. .ooooooo.. ",
" .oooooo. ",
" .ooo.. ",
" .oo. ",
" .. "};

97
lisp/gnus/get-news.xpm
View File

@ -1,68 +1,31 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 38 1",
" c Gray0",
". c #0bfb0bfb0bfb",
"X c Gray6",
"o c #133313331333",
"O c Gray9",
"+ c Gray11",
"@ c Gray12",
"# c #23f323f323f3",
"$ c Gray15",
"% c #2ff32ff32ff3",
"& c #399939993999",
"* c #3fff3fff3fff",
"= c Gray25",
"- c #433243324332",
"; c Gray28",
": c #4ccc4ccc4ccc",
"> c #519151915191",
", c #53e753e753e7",
"< c #565a565a565a",
"1 c Gray35",
"2 c #5b1a5b1a5b1a",
"3 c #5fe55fe55fe5",
"4 c Gray45",
"5 c Gray46",
"6 c #77d777d777d7",
"7 c #7ccc7ccc7ccc",
"8 c Gray50",
"9 c #866586658665",
"0 c Gray56",
"q c Gray60",
"w c #9bcb9bcb9bcb",
"e c #9fff9fff9fff",
"r c #a7c7a7c7a7c7",
"t c Gray70",
"y c Gray75",
"u c Gray81",
"i c #dfffdfffdfff",
"p c Gray100",
/* pixels */
"0000000ryyyyyyyyyyyyyyyy",
"@8888833yyyyyyyyyyyyyyyy",
"*pppppy3yyyyyyyyyyyyyyyy",
"*pppppy3yyyyyr=$$6yyyyyy",
"*ppppp3%3yyyr<9qq36yyyyy",
"*ppppp ;0>yy0:qqqq%yyyyy",
"*pppppy @82tq>0qq8>yyyyy",
"*pppppy%>q42y0>q42yyyyyy",
"*pppppy3q=q8%%.=:#%6yyyy",
"%yyyyy03y0:qqqqqqqq:0yyy",
"33333330yr<9qqqqqqq42yyy",
"yyyyyyyyyyr=qqqqqqqq$yyy",
"yyyyyyyyyyyy$:%***$q$**X",
"yyyyyyyyyyyy$:yppe3q$pp*",
"yyyyyyyyyyyy$:ypp*q3qpp*",
"yyyyyyyyyyyy$:yp8402upp*",
"yyyyyyyyyyyyo$yi*&48ppp*",
"yyyyyyyyyyy>4&u>00:ippp*",
"yyyyyyyyyyy%q:00Oq%yyyy%",
"yyyyyyyyyyy%q4:o<3&%3333",
"yyyyyyyyyyy%qqq$9443yyyy",
"yyyyyyyyyyy%44@0&4<3yyyy",
"yyyyyyyyyyy6o$;r%&O0yyyy",
"yyyyyyyyyyyy$:0y34%yyyyy"
};
static char * get_news_xpm[] = {
"24 24 4 1",
". c None",
"X c #A5A5A5A59595",
"o c #E1E1E0E0E0E0",
"O c #C7C7C6C6C6C6",
"........................",
"........................",
"........................",
".....XXX................",
"...XXoooXXXXX...........",
"XXXoooooXXoooX.XXX......",
"XoXooXXXooooXXXoooX.....",
"XooXoXoXooXXXoooooX.....",
"XooXXXooXoXoXooooooX....",
"XooXOXooXXXooXooooooX...",
"XoXOOXooXOXooXXooooooX..",
"OXOOOXoXOOXooXoooooooX..",
"OXOooOXOOOXoXOooooooooX.",
".OXooOXOooOXOOooooooooX.",
".OXoooOXooOXOooooooooooX",
"..OXooOXoooOXooooooooooX",
"..OXooOOXooOXooooooooooX",
"...OXooOXoooOXoooooooXXX",
"...OXooXOXooOXooooooXOO.",
"....OXXOOXooXOXoooXXO...",
".....OO..OXXOOXooXOO....",
"..........OO..OXXO......",
"...............OO.......",
"........................"};

93
lisp/gnus/gnntg.xpm
View File

@ -1,64 +1,31 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 34 1",
" c Gray0",
". c #099909990999",
"X c #0bfb0bfb0bfb",
"o c #133313331333",
"O c Gray9",
"+ c Gray11",
"@ c #23f323f323f3",
"# c Gray15",
"$ c #2fef2fef2fef",
"% c #399939993999",
"& c #3fff3fff3fff",
"* c Gray25",
"= c #433243324332",
"- c Gray28",
"; c #4ccc4ccc4ccc",
": c #519151915191",
"> c #566656665666",
", c #5fed5fed5fed",
"< c #626262626262",
"1 c Gray42",
"2 c Gray45",
"3 c Gray46",
"4 c #77d777d777d7",
"5 c #7ccc7ccc7ccc",
"6 c Gray50",
"7 c #866586658665",
"8 c Gray56",
"9 c Gray60",
"0 c #9bcb9bcb9bcb",
"q c #a7c7a7c7a7c7",
"w c Gray70",
"e c Gray75",
"r c #dfffdfffdfff",
"t c Gray100",
/* pixels */
"w8888888weeeeeeeeeeeeeee",
"8&66666&8eeeeeeeeeeeeeee",
"86ttttt68eeeeeeeeeeeeeee",
"86ttttt68eeeee0###0eeeee",
"86ttttr&-4eee8:000:8eeee",
"86tttte 144ee,20002,eeee",
"86ttttt6 =,4e4<000<4eeee",
"86ttttt6-,0,4e4,0,4eeeee",
"86ttttt684,0<$$.,#$$0eee",
"8,eeeee,8e,200000000#eee",
"q,,,,,,,qe8:00000000,4ee",
"eeeeeeeeeee0=000006,0$ee",
"eeeeeeeeeeee8;00002;0$ee",
"eeeeeeeeeeee8;00002;0$ee",
"eeeeeeeeeeee8;00002;0$ee",
"eeeeeeeeeeee8;00002;0$ee",
"eeeeeeeeeeee8#;;;;%#;$ee",
"eeeeeeeeeeee=2222+88@0ee",
"eeeeeeeeeeee#00000.4$eee",
"eeeeeeeeeeee#00720O,,eee",
"eeeeeeeeeeee#002;02%8eee",
"eeeeeeeeeeee+22$,>2%8eee",
"eeeeeeeeeeee-#o48O%$qeee",
"eeeeeeeeeeee8;#ee$2,eeee"
};
static char * gnntg_xpm[] = {
"24 24 4 1",
" c None",
". c #000000000000",
"X c #FFFFFFFFFFFF",
"o c #C7C7C6C6C6C6",
" ",
" ....... ",
" .XXXXX. ",
" .XXXXX. ... ",
" .XXXXX... .ooo. ",
" .XXXXX.... ..ooo.. ",
" .XXXXX..o.. ..ooo.. ",
" .XXXXX...o.. ..o.. ",
" .XXXXX. ..o........ ",
" .XXXXX. ..oooooooo. ",
" ....... .oooooooo.. ",
" .ooooo..o. ",
" .oooo..o. ",
" .oooo..o. ",
" .oooo..o. ",
" .oooo..o. ",
" ......... ",
" ......oo. ",
" .ooooo... ",
" .oo..o... ",
" .oo..o.. ",
" ........ ",
" .... ... ",
" ... ... "};

3463
lisp/gnus/gnus-agent.el
View File

File diff suppressed because it is too large Load Diff

4175
lisp/gnus/gnus-art.el
View File

File diff suppressed because it is too large Load Diff

22
lisp/gnus/gnus-async.el
View File

@ -1,5 +1,6 @@
;;; gnus-async.el --- asynchronous support for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -35,12 +36,6 @@
"Support for asynchronous operations."
:group 'gnus)
(defcustom gnus-asynchronous nil
"*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;
@ -50,6 +45,12 @@ if t, prefetch as many articles as possible."
(const :tag "all" t)
(integer :tag "some" 0)))
(defcustom gnus-asynchronous nil
"*If nil, inhibit all Gnus asynchronicity.
If non-nil, let the other asynch variables be heeded."
:group 'gnus-asynchronous
:type 'boolean)
(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
@ -276,15 +277,16 @@ It should return non-nil if the article is to be prefetched."
;; needs to be done in nntp.el.
(while (eq article gnus-async-current-prefetch-article)
(incf tries)
(when (nntp-accept-process-output proc 1)
(when (nntp-accept-process-output proc)
(setq tries 0))
(when (and (not nntp-have-messaged) (eq 3 tries))
(when (and (not nntp-have-messaged)
(= tries 3))
(gnus-message 5 "Waiting for async article...")
(setq nntp-have-messaged t)))
(quit
;; if the user interrupted on a slow/hung connection,
;; do something friendly.
(when (< 3 tries)
(when (> tries 3)
(setq gnus-async-current-prefetch-article nil))
(signal 'quit nil)))
(when nntp-have-messaged

14
lisp/gnus/gnus-audio.el
View File

@ -1,5 +1,5 @@
;;; gnus-audio.el --- sound effects for Gnus
;; Copyright (C) 1996, 2000 Free Software Foundation
;;; gnus-audio.el --- Sound effects for Gnus
;; Copyright (C) 1996, 2000, 2003 Free Software Foundation
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news, mail, multimedia
@ -47,15 +47,15 @@
:type '(choice directory (const nil))
:group 'gnus-audio)
(defcustom gnus-audio-au-player "/usr/bin/showaudio"
(defcustom gnus-audio-au-player (executable-find "play")
"Executable program for playing sun AU format sound files."
:group 'gnus-audio
:type 'string)
:type '(choice file (const nil)))
(defcustom gnus-audio-wav-player "/usr/local/bin/play"
(defcustom gnus-audio-wav-player (executable-find "play")
"Executable program for playing WAV files."
:group 'gnus-audio
:type 'string)
:type '(choice file (const nil)))
;;; The following isn't implemented yet. Wait for Millennium Gnus.
;;(defvar gnus-audio-effects-enabled t
@ -93,7 +93,7 @@
;;;###autoload
(defun gnus-audio-play (file)
"Play a sound FILE through the speaker."
(interactive)
(interactive "fSound file name: ")
(let ((sound-file (if (file-exists-p file)
file
(expand-file-name file gnus-audio-directory))))

53
lisp/gnus/gnus-bcklg.el
View File

@ -1,5 +1,6 @@
;;; gnus-bcklg.el --- backlog functions for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -55,36 +56,39 @@
(defun gnus-backlog-shutdown ()
"Clear all backlog variables and buffers."
(interactive)
(when (get-buffer gnus-backlog-buffer)
(kill-buffer gnus-backlog-buffer))
(gnus-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.
(when (and (numberp number)
(not (string-match "^nnvirtual" group)))
(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)
(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.
(if (> (point-max) b)
(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.
(if (> (point-max) b)
(gnus-put-text-property b (1+ b) 'gnus-backlog ident)
(gnus-error 3 "Article %d is blank" number)))))))
(gnus-error 3 "Article %d is blank" number))))))))
(defun gnus-backlog-remove-oldest-article ()
(save-excursion
@ -127,7 +131,8 @@
(setq gnus-backlog-articles (delq ident gnus-backlog-articles)))))))
(defun gnus-backlog-request-article (group number &optional buffer)
(when (numberp number)
(when (and (numberp number)
(not (string-match "^nnvirtual" group)))
(gnus-backlog-setup)
(let ((ident (intern (concat group ":" (int-to-string number))
gnus-backlog-hashtb))

156
lisp/gnus/gnus-cache.el
View File

@ -1,5 +1,5 @@
;;; gnus-cache.el --- cache interface for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -33,6 +33,8 @@
(require 'gnus-range)
(require 'gnus-start)
(eval-when-compile
(if (not (fboundp 'gnus-agent-load-alist))
(defun gnus-agent-load-alist (group)))
(require 'gnus-sum))
(defcustom gnus-cache-active-file
@ -160,11 +162,7 @@ it's not cached."
(when (and number
(> number 0) ; Reffed article.
(or force
(and (or (not gnus-cacheable-groups)
(string-match gnus-cacheable-groups group))
(or (not gnus-uncacheable-groups)
(not (string-match
gnus-uncacheable-groups group)))
(and (gnus-cache-fully-p group)
(gnus-cache-member-of-class
gnus-cache-enter-articles ticked dormant unread)))
(not (file-exists-p (setq file (gnus-cache-file-name
@ -183,7 +181,8 @@ it's not cached."
(when (> (buffer-size) 0)
(let ((coding-system-for-write gnus-cache-coding-system))
(gnus-write-buffer file))
(setq headers (nnheader-parse-head t))
(nnheader-remove-body)
(setq headers (nnheader-parse-naked-head))
(mail-header-set-number headers number)
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
@ -209,8 +208,9 @@ it's not cached."
(nnheader-insert-nov headers)
;; Update the active info.
(set-buffer gnus-summary-buffer)
(gnus-cache-update-active group number)
(push article gnus-newsgroup-cached)
(gnus-cache-possibly-update-active group (cons number number))
(setq gnus-newsgroup-cached
(gnus-add-to-sorted-list gnus-newsgroup-cached article))
(gnus-summary-update-secondary-mark article))
t))))))
@ -235,7 +235,7 @@ it's not cached."
(defun gnus-cache-possibly-remove-articles-1 ()
"Possibly remove some of the removable articles."
(unless (eq gnus-use-cache 'passive)
(when (gnus-cache-fully-p gnus-newsgroup-name)
(let ((articles gnus-cache-removable-articles)
(cache-articles gnus-newsgroup-cached)
article)
@ -283,9 +283,7 @@ it's not cached."
;; 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))
(let ((uncached-articles (gnus-sorted-difference articles cached))
(cache-file (gnus-cache-file-name group ".overview"))
type)
;; We first retrieve all the headers that we don't have in
@ -335,14 +333,16 @@ Returns the list of articles entered."
(when (gnus-cache-possibly-enter-article
gnus-newsgroup-name article
nil nil nil t)
(setq gnus-newsgroup-undownloaded (delq article gnus-newsgroup-undownloaded))
(push article out))
(gnus-message 2 "Can't cache article %d" article))
(gnus-summary-update-download-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)
(defun gnus-cache-remove-article (&optional 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."
@ -354,7 +354,14 @@ Returns the list of articles removed."
(setq article (pop articles))
(gnus-summary-remove-process-mark article)
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(when gnus-newsgroup-agentized
(let ((alist (gnus-agent-load-alist gnus-newsgroup-name)))
(unless (cdr (assoc article alist))
(setq gnus-newsgroup-undownloaded
(gnus-add-to-sorted-list
gnus-newsgroup-undownloaded article)))))
(push article out))
(gnus-summary-update-download-mark article)
(gnus-summary-update-secondary-mark article))
(gnus-summary-next-subject 1)
(gnus-summary-position-point)
@ -367,15 +374,20 @@ Returns the list of articles removed."
(defun gnus-summary-insert-cached-articles ()
"Insert all the articles cached for this group into the current buffer."
(interactive)
(let ((cached (sort (copy-sequence gnus-newsgroup-cached) '>))
(gnus-verbose (max 6 gnus-verbose)))
(unless cached
(gnus-message 3 "No cached articles for this group"))
(while cached
(gnus-summary-goto-subject (pop cached) t))))
(let ((gnus-verbose (max 6 gnus-verbose)))
(if (not gnus-newsgroup-cached)
(gnus-message 3 "No cached articles for this group")
(gnus-summary-goto-subjects gnus-newsgroup-cached))))
(defalias 'gnus-summary-limit-include-cached
'gnus-summary-insert-cached-articles)
(defun gnus-summary-limit-include-cached ()
"Limit the summary buffer to articles that are cached."
(interactive)
(let ((gnus-verbose (max 6 gnus-verbose)))
(if gnus-newsgroup-cached
(progn
(gnus-summary-limit gnus-newsgroup-cached)
(gnus-summary-position-point))
(gnus-message 3 "No cached articles for this group"))))
;;; Internal functions.
@ -422,7 +434,8 @@ Returns the list of articles removed."
?. ?_)))
;; Translate the first colon into a slash.
(when (string-match ":" group)
(aset group (match-beginning 0) ?/))
(setq group (concat (substring group 0 (match-beginning 0))
"/" (substring group (match-end 0)))))
(nnheader-replace-chars-in-string group ?. ?/)))
t)
gnus-cache-directory))))
@ -460,10 +473,11 @@ Returns the list of articles removed."
(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-delete-line)))
(unless (setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached))
(gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb)
(setq gnus-cache-active-altered t))
(gnus-summary-update-secondary-mark article)
t)))
@ -477,9 +491,13 @@ Returns the list of articles removed."
(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))))
(if articles
(progn
(gnus-cache-update-active group (car articles) t)
(gnus-cache-update-active group (car (last articles))))
(when (gnus-gethash group gnus-cache-active-hashtb)
(gnus-sethash group nil gnus-cache-active-hashtb)
(setq gnus-cache-active-altered t)))
articles)))
(defun gnus-cache-braid-nov (group cached &optional file)
@ -503,13 +521,13 @@ Returns the list of articles removed."
(< (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)))
(set-buffer cache-buf)
(if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
nil t)
(setq beg (gnus-point-at-bol)
end (progn (end-of-line) (point)))
(setq beg nil))
(set-buffer nntp-server-buffer)
(when beg
(insert-buffer-substring cache-buf beg end)
(insert "\n"))
@ -531,20 +549,20 @@ Returns the list of articles removed."
(car cached)))
(search-forward "\n.\n" nil 'move))
(beginning-of-line)
(save-excursion
(set-buffer cache-buf)
(erase-buffer)
(let ((coding-system-for-read
gnus-cache-coding-system))
(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 "."))
(set-buffer cache-buf)
(erase-buffer)
(let ((coding-system-for-read
gnus-cache-coding-system))
(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 ".")
(set-buffer nntp-server-buffer)
(insert-buffer-substring cache-buf)
(setq cached (cdr cached)))
(kill-buffer cache-buf)))
@ -604,6 +622,24 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
;; Mark the active hashtb as unaltered.
(setq gnus-cache-active-altered nil)))
(defun gnus-cache-possibly-update-active (group active)
"Update active info bounds of GROUP with ACTIVE if necessary.
The update is performed if ACTIVE contains a higher or lower bound
than the current."
(let ((lower t) (higher t))
(if gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
(when cache-active
(unless (< (car active) (car cache-active))
(setq lower nil))
(unless (> (cdr active) (cdr cache-active))
(setq higher nil))))
(gnus-cache-read-active))
(when lower
(gnus-cache-update-active group (car active) t))
(when higher
(gnus-cache-update-active group (cdr active)))))
(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."
@ -641,7 +677,7 @@ If LOW, update the lower bound instead."
(gnus-message 5 "Generating the cache active file...")
(setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
(when (string-match "^\\(nn[^_]+\\)_" group)
(setq group (replace-match "\\1:" t t group)))
(setq group (replace-match "\\1:" t nil group)))
;; Separate articles from all other files and directories.
(while files
(if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
@ -670,13 +706,27 @@ If LOW, update the lower bound instead."
(interactive (list gnus-cache-directory))
(gnus-cache-close)
(let ((nnml-generate-active-function 'identity))
(nnml-generate-nov-databases-1 dir)))
(nnml-generate-nov-databases-1 dir))
(gnus-cache-open))
(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))
(defun gnus-cache-fully-p (&optional group)
"Returns non-nil if the cache should be fully used.
If GROUP is non-nil, also cater to `gnus-cacheable-groups' and
`gnus-uncacheable-groups'."
(and gnus-use-cache
(not (eq gnus-use-cache 'passive))
(if (null group)
t
(and (or (not gnus-cacheable-groups)
(string-match gnus-cacheable-groups group))
(or (not gnus-uncacheable-groups)
(not (string-match gnus-uncacheable-groups group)))))))
(provide 'gnus-cache)
;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a

258
lisp/gnus/gnus-cite.el
View File

@ -1,6 +1,6 @@
;;; gnus-cite.el --- parse citations in articles for Gnus -*- coding: iso-latin-1 -*-
;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Per Abhiddenware
@ -29,8 +29,9 @@
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-art)
(require 'gnus-range)
(require 'gnus-art)
(require 'message) ; for message-cite-prefix-regexp
;;; Customization:
@ -40,19 +41,6 @@
: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-opened-text-button-line-format "%(%{[-]%}%)\n"
"Format of opened cited text buttons."
:group 'gnus-cite
@ -79,20 +67,13 @@ Set it to nil to parse all articles."
:type '(choice (const :tag "all" nil)
integer))
(defcustom gnus-cite-prefix-regexp
;; The Latin-1 angle quote looks pretty dubious. -- fx
"^[]>»|:}+ ]*[]>»|:}+]\\(.*>»\\)?\\|^.*>"
"*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 "\\)? *"
(concat "^\\(" message-cite-prefix-regexp "\\)? *"
">>>>> +\"\\([^\"\n]+\\)\" +==")
"*Regexp matching normal Supercite attribution lines.
The first grouping must match prefixes added by other packages."
@ -110,21 +91,51 @@ The first regexp group should match the Supercite attribution."
:group 'gnus-cite
:type 'integer)
;; Some Microsoft products put in a citation that extends to the
;; remainder of the message:
;;
;; -----Original Message-----
;; From: ...
;; To: ...
;; Sent: ... [date, in non-RFC-2822 format]
;; Subject: ...
;;
;; Cited message, with no prefixes
;;
;; The four headers are always the same. But note they are prone to
;; folding without additional indentation.
;;
;; Others use "----- Original Message -----" instead, and properly quote
;; the body using "> ". This style is handled without special cases.
(defcustom gnus-cite-attribution-prefix
"In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|-----Original Message-----"
"In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----"
"*Regexp matching the beginning of an attribution line."
:group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-attribution-suffix
"\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|-----Original Message-----\\)[ \t]*$"
"\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \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)
(defcustom gnus-cite-unsightly-citation-regexp
"^-----Original Message-----\nFrom: \\(.+\n\\)+\n"
"Regexp matching Microsoft-type rest-of-message citations."
:group 'gnus-cite
:type 'regexp)
(defcustom gnus-cite-ignore-quoted-from t
"Non-nil means don't regard lines beginning with \">From \" as cited text.
Those lines may have been quoted by MTAs in order not to mix up with
the envelope From line."
:group 'gnus-cite
:type 'boolean)
(defface gnus-cite-attribution-face '((t
(:slant italic)))
(:italic t)))
"Face used for attribution lines.")
(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
@ -140,7 +151,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "MidnightBlue"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-2 '((((class color)
@ -150,7 +161,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "firebrick"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-3 '((((class color)
@ -160,7 +171,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "dark green"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-4 '((((class color)
@ -170,7 +181,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "OrangeRed"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-5 '((((class color)
@ -180,7 +191,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "dark khaki"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-6 '((((class color)
@ -190,7 +201,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "dark violet"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-7 '((((class color)
@ -200,7 +211,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "SteelBlue4"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-8 '((((class color)
@ -210,7 +221,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "magenta"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-9 '((((class color)
@ -220,7 +231,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "violet"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-10 '((((class color)
@ -230,7 +241,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "medium purple"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defface gnus-cite-face-11 '((((class color)
@ -240,7 +251,7 @@ It is merged with the face for the cited text belonging to the attribution."
(background light))
(:foreground "turquoise"))
(t
(:slant italic)))
(:italic t)))
"Citation face.")
(defcustom gnus-cite-face-list
@ -270,6 +281,17 @@ This should make it easier to see who wrote what."
:group 'gnus-cite
:type 'boolean)
;; This has to go here because its default value depends on
;; gnus-cite-face-list.
(defcustom gnus-article-boring-faces (cons 'gnus-signature-face
gnus-cite-face-list)
"List of faces that are not worth reading.
If an article has more pages below the one you are looking at, but
nothing on those pages is a word of at least three letters that is not
in a boring face, then the pages will be skipped."
:type '(repeat face)
:group 'gnus-article-hiding)
;;; Internal Variables:
(defvar gnus-cite-article nil)
@ -317,7 +339,7 @@ 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 matches `message-cite-prefix-regexp' with the same prefix.
Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
@ -358,7 +380,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
(goto-char (point-min))
(forward-line (1- number))
(when (re-search-forward gnus-cite-attribution-suffix
(save-excursion (end-of-line 1) (point))
(gnus-point-at-eol)
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
'gnus-cite-toggle prefix))
@ -450,7 +472,10 @@ If WIDTH (the numerical prefix), use that text width when filling."
(narrow-to-region (caar marks) (caadr marks))
(let ((adaptive-fill-regexp
(concat "^" (regexp-quote (cdar marks)) " *"))
(fill-prefix (cdar marks)))
(fill-prefix
(if (string= (cdar marks) "") ""
(concat (cdar marks) " ")))
use-hard-newlines)
(fill-region (point-min) (point-max)))
(set-marker (caar marks) nil)
(setq marks (cdr marks)))
@ -519,6 +544,7 @@ always hide."
(setq beg nil)
(setq end (point-marker))))))
(when (and beg end)
(gnus-add-wash-type 'cite)
;; We use markers for the end-points to facilitate later
;; wrapping and mangling of text.
(setq beg (set-marker (make-marker) beg)
@ -558,14 +584,20 @@ means show, nil means toggle."
(and (> arg 0) (not hidden))
(and (< arg 0) hidden))
(if hidden
(gnus-remove-text-properties-when
'article-type 'cite beg end
(cons 'article-type (cons 'cite
gnus-hidden-properties)))
(progn
;; Can't remove 'cite from g-a-wash-types here because
;; multiple citations may be hidden -jas
(gnus-remove-text-properties-when
'article-type 'cite beg end
(cons 'article-type (cons 'cite
gnus-hidden-properties))))
(gnus-add-wash-type 'cite)
(gnus-add-text-properties-when
'article-type nil beg end
(cons 'article-type (cons 'cite
gnus-hidden-properties))))
(let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
(gnus-set-mode-line 'article))
(save-excursion
(goto-char start)
(gnus-delete-line)
@ -594,41 +626,44 @@ 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) '(force)))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(article-goto-body)
(let ((start (point))
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
(inhibit-point-motion-hooks t)
(hidden 0)
total)
(goto-char (point-max))
(gnus-article-search-signature)
(setq total (count-lines start (point)))
(while atts
(setq hidden (+ hidden (length (cdr (assoc (cdar atts)
gnus-cite-prefix-alist))))
atts (cdr atts)))
(when (or force
(and (> (* 100 hidden) (* gnus-cite-hide-percentage total))
(> hidden gnus-cite-hide-absolute)))
(setq atts gnus-cite-attribution-alist)
(with-current-buffer gnus-article-buffer
(gnus-delete-wash-type 'cite)
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(gnus-cite-parse-maybe force)
(article-goto-body)
(let ((start (point))
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
(inhibit-point-motion-hooks t)
(hidden 0)
total)
(goto-char (point-max))
(gnus-article-search-signature)
(setq total (count-lines start (point)))
(while atts
(setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
atts (cdr atts))
(while total
(setq hidden (car total)
total (cdr total))
(goto-char (point-min))
(forward-line (1- hidden))
(unless (assq hidden gnus-cite-attribution-alist)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'article-type 'cite)
gnus-hidden-properties))))))))))
(setq hidden (+ hidden (length (cdr (assoc (cdar atts)
gnus-cite-prefix-alist))))
atts (cdr atts)))
(when (or force
(and (> (* 100 hidden) (* gnus-cite-hide-percentage total))
(> hidden gnus-cite-hide-absolute)))
(gnus-add-wash-type 'cite)
(setq atts gnus-cite-attribution-alist)
(while atts
(setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
atts (cdr atts))
(while total
(setq hidden (car total)
total (cdr total))
(goto-char (point-min))
(forward-line (1- hidden))
(unless (assq hidden gnus-cite-attribution-alist)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'article-type 'cite)
gnus-hidden-properties)))))))))
(gnus-set-mode-line 'article)))
(defun gnus-article-hide-citation-in-followups ()
"Hide cited text in non-root articles."
@ -663,11 +698,13 @@ See also the documentation for `gnus-article-highlight-citation'."
(defun gnus-cite-delete-overlays ()
(dolist (overlay gnus-cite-overlay-list)
(when (or (not (gnus-overlay-end overlay))
(and (>= (gnus-overlay-end overlay) (point-min))
(<= (gnus-overlay-end overlay) (point-max))))
(setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list))
(gnus-delete-overlay overlay))))
(ignore-errors
(when (or (not (gnus-overlay-end overlay))
(and (>= (gnus-overlay-end overlay) (point-min))
(<= (gnus-overlay-end overlay) (point-max))))
(setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list))
(ignore-errors
(gnus-delete-overlay overlay))))))
(defun gnus-cite-parse-wrapper ()
;; Wrap chopped gnus-cite-parse.
@ -690,23 +727,33 @@ See also the documentation for `gnus-article-highlight-citation'."
(goto-char (point-max))
(gnus-article-search-signature)
(point)))
alist entry start begin end numbers prefix)
(prefix-regexp (concat "^\\(" message-cite-prefix-regexp "\\)"))
alist entry start begin end numbers prefix guess-limit)
;; Get all potential prefixes in `alist'.
(while (< (point) max)
;; Each line.
(setq begin (point)
end (progn (beginning-of-line 2) (point))
guess-limit (progn (skip-chars-forward "^> \t\r\n") (point))
end (gnus-point-at-bol 2)
start end)
(goto-char begin)
;; Ignore standard Supercite attribution prefix.
(when (looking-at gnus-supercite-regexp)
(when (and (< guess-limit (+ begin gnus-cite-max-prefix))
(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)
(when (> end (+ begin gnus-cite-max-prefix))
(setq end (+ begin gnus-cite-max-prefix)))
;; Ignore quoted envelope From_.
(when (and gnus-cite-ignore-quoted-from
(prog2
(setq case-fold-search nil)
(looking-at ">From ")
(setq case-fold-search t)))
(setq end (1+ begin)))
(while (re-search-forward prefix-regexp (1- end) t)
;; Each prefix.
(setq end (match-end 0)
prefix (buffer-substring begin end))
@ -718,9 +765,19 @@ See also the documentation for `gnus-article-highlight-citation'."
(goto-char begin))
(goto-char start)
(setq line (1+ line)))
;; Horrible special case for some Microsoft mailers.
(goto-char (point-min))
(when (re-search-forward gnus-cite-unsightly-citation-regexp max t)
(setq begin (count-lines (point-min) (point)))
(setq end (count-lines (point-min) max))
(setq entry nil)
(while (< begin end)
(push begin entry)
(setq begin (1+ begin)))
(push (cons "" entry) alist))
;; 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
;; 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))))))
@ -960,14 +1017,20 @@ See also the documentation for `gnus-article-highlight-citation'."
(goto-char (point-min))
(forward-line (1- number))
(cond ((get-text-property (point) 'invisible)
;; Can't remove 'cite from g-a-wash-types here because
;; multiple citations may be hidden -jas
(remove-text-properties (point) (progn (forward-line 1) (point))
gnus-hidden-properties))
((assq number gnus-cite-attribution-alist))
(t
(gnus-add-wash-type 'cite)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'article-type 'cite)
gnus-hidden-properties))))))))
gnus-hidden-properties))))
(let ((gnus-article-mime-handle-alist-1
gnus-article-mime-handle-alist))
(gnus-set-mode-line 'article))))))
(defun gnus-cite-find-prefix (line)
;; Return citation prefix for LINE.
@ -990,6 +1053,17 @@ See also the documentation for `gnus-article-highlight-citation'."
(while vars
(make-local-variable (pop vars)))))
(defun gnus-cited-line-p ()
"Say whether the current line is a cited line."
(save-excursion
(beginning-of-line)
(let ((found nil))
(dolist (prefix (mapcar 'car gnus-cite-prefix-alist))
(when (string= (buffer-substring (point) (+ (length prefix) (point)))
prefix)
(setq found t)))
found)))
(gnus-ems-redefine)
(provide 'gnus-cite)

472
lisp/gnus/gnus-cus.el
View File

@ -1,6 +1,7 @@
;;; gnus-cus.el --- customization commands for Gnus
;;
;; Copyright (C) 1996,1999, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: news
@ -27,15 +28,14 @@
;;; Code:
(require 'wid-edit)
(require 'gnus)
(require 'gnus-agent)
(require 'gnus-score)
(require 'gnus-topic)
(require 'gnus-art)
;;; 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.
@ -72,36 +72,7 @@ if that value is non-nil."
;;; 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.
The gnus-group-split mail splitting mechanism will behave as if this
address was listed in gnus-group-split Addresses (see below).")
(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'.
The gnus-group-split mail splitting mechanism will behave as if this
address was listed in gnus-group-split Addresses (see below).")
(extra-aliases (choice
'((extra-aliases (choice
:tag "Extra Aliases"
(list
:tag "List"
@ -168,29 +139,6 @@ 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).")
(banner (choice :tag "Banner"
:value nil
(const :tag "Remove signature" signature)
(symbol :tag "Item in `gnus-article-banner-alist'" none)
regexp
(const :tag "None" nil)) "\
If non-nil, specify how to remove `banners' from articles.
Symbol `signature' means to remove signatures delimited by
`gnus-signature-separator'. Any other symbol is used to look up a
regular expression to match the banner in `gnus-article-banner-alist'.
A string is used as a regular expression to match the banner
directly.")
(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)
@ -205,13 +153,13 @@ days (not necessarily an integer) or the symbols `never' or
`immediate'.")
(expiry-target (choice :tag "Expiry Target"
:value delete
(const delete)
(function :format "%v" nnmail-)
string) "\
:value delete
(const delete)
(function :format "%v" nnmail-)
string) "\
Where expired messages end up.
Overrides `nnmail-expiry-target', which see.")
Overrides `nnmail-expiry-target'.")
(score-file (file :tag "Score File") "\
Make the specified file into the current score file.
@ -232,34 +180,31 @@ you to put the admin address somewhere convenient.")
(display (choice :tag "Display"
:value default
(const all)
(const default)) "\
(integer)
(const default)
(sexp :tag "Other")) "\
Which articles to display on entering the group.
`all'
Display all articles, both read and unread.
`integer'
Display the last NUMBER articles in the group. This is the same as
entering the group with C-u NUMBER.
`default'
Display the default visible articles, which normally includes
unread and ticked articles.")
unread and ticked articles.
`Other'
Display the articles that satisfy the S-expression. The S-expression
should be in an array form.")
(comment (string :tag "Comment") "\
An arbitrary comment on the group.")
(visible (const :tag "Permanently visible" t) "\
Always display this group, even when there are no unread articles
in it..")
(charset (symbol :tag "Charset") "\
The default charset to use in the group.")
(ignored-charsets
(choice :tag "Ignored charsets"
:value nil
(repeat (symbol))) "\
List of charsets that should be ignored.
When these charsets are used in the \"charset\" parameter, the
default charset will be used instead.")
Always display this group, even when there are no unread articles in it.")
(highlight-words
(choice :tag "Highlight words"
@ -270,23 +215,23 @@ default charset will be used instead.")
(symbol :tag "Face"
gnus-emphasis-highlight-words))))
"highlight regexps.
See gnus-emphasis-alist.")
See `gnus-emphasis-alist'.")
(posting-style
(choice :tag "Posting style"
:value nil
(repeat (list
(choice :tag "Type"
(choice :tag "Type"
:value nil
(const signature)
(const signature-file)
(const organization)
(const address)
(const name)
(const body))
(const signature-file)
(const organization)
(const address)
(const name)
(const body))
(string :format "%v"))))
"post style.
See gnus-posting-styles."))
See `gnus-posting-styles'."))
"Alist of valid group or topic parameters.
Each entry has the form (NAME TYPE DOC), where NAME is the parameter
@ -295,9 +240,15 @@ DOC is a documentation string for the parameter.")
(defconst gnus-extra-topic-parameters
'((subscribe (regexp :tag "Subscribe") "\
If `gnus-subscribe-newsgroup-method' is set to
If `gnus-subscribe-newsgroup-method' or
`gnus-subscribe-options-newsgroup-method' is set to
`gnus-subscribe-topics', new groups that matches this regexp will
automatically be subscribed to this topic"))
automatically be subscribed to this topic")
(subscribe-level (integer :tag "Subscribe Level" :value 1) "\
If this topic parameter is set, when new groups are subscribed
automatically under this topic (via the `subscribe' topic parameter)
assign this level to the group, rather than the default level
set in `gnus-level-default-subscribed'"))
"Alist of topic parameters that are not also group parameters.
Each entry has the form (NAME TYPE DOC), where NAME is the parameter
@ -312,6 +263,72 @@ Server-assigned value attached to IMAP groups, used to maintain consistency."))
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.")
(eval-and-compile
(defconst gnus-agent-parameters
'((agent-predicate
(sexp :tag "Selection Predicate" :value false)
"Predicate used to automatically select articles for downloading."
gnus-agent-cat-predicate)
(agent-score
(choice :tag "Score File" :value nil
(const file :tag "Use group's score files")
(repeat (list (string :format "%v" :tag "File name"))))
"Which score files to use when using score to select articles to fetch.
`nil'
All articles will be scored to zero (0).
`file'
The group's score files will be used to score the articles.
`List'
A list of score file names."
gnus-agent-cat-score-file)
(agent-short-article
(integer :tag "Max Length of Short Article" :value "")
"The SHORT predicate will evaluate to true when the article is
shorter than this length." gnus-agent-cat-length-when-short)
(agent-long-article
(integer :tag "Min Length of Long Article" :value "")
"The LONG predicate will evaluate to true when the article is
longer than this length." gnus-agent-cat-length-when-long)
(agent-low-score
(integer :tag "Low Score Limit" :value "")
"The LOW predicate will evaluate to true when the article scores
lower than this limit." gnus-agent-cat-low-score)
(agent-high-score
(integer :tag "High Score Limit" :value "")
"The HIGH predicate will evaluate to true when the article scores
higher than this limit." gnus-agent-cat-high-score)
(agent-days-until-old
(integer :tag "Days Until Old" :value "")
"The OLD predicate will evaluate to true when the fetched article
has been stored locally for at least this many days."
gnus-agent-cat-days-until-old)
(agent-enable-expiration
(radio :tag "Expire in this Group or Topic" :value nil
(const :format "Enable " ENABLE)
(const :format "Disable " DISABLE))
"\nEnable, or disable, agent expiration in this group or topic."
gnus-agent-cat-enable-expiration)
(agent-enable-undownloaded-faces
(boolean :tag "Enable Agent Faces")
"Have the summary buffer use the agent's undownloaded faces.
These faces, when enabled, act as a warning that an article has not
been fetched into either the agent nor the cache. This is of most use
to users who use the agent as a cache (i.e. they only operate on
articles that have been downloaded). Leave disabled to display normal
article faces even when the article hasn't been downloaded."
gnus-agent-cat-enable-undownloaded-faces))
"Alist of group parameters that are not also topic parameters.
Each entry has the form (NAME TYPE DOC ACCESSOR), where NAME is the
parameter itself (a symbol), TYPE is the parameters type (a sexp
widget), DOC is a documentation string for the parameter, and ACCESSOR
is a function (symbol) that extracts the current value from the
category."))
(defvar gnus-custom-params)
(defvar gnus-custom-method)
(defvar gnus-custom-group)
@ -326,18 +343,37 @@ DOC is a documentation string for the parameter.")
:doc ,(nth 2 entry)
(const :format "" ,(nth 0 entry))
,(nth 1 entry)))
(append gnus-group-parameters
(append (reverse gnus-group-parameters-more)
gnus-group-parameters
(if group
gnus-extra-group-parameters
gnus-extra-topic-parameters)))))
gnus-extra-topic-parameters))))
(agent (mapcar (lambda (entry)
(let ((type (nth 1 entry))
vcons)
(if (listp type)
(setq type (copy-sequence type)))
(setq vcons (cdr (memq :value type)))
(if (symbolp (car vcons))
(condition-case nil
(setcar vcons (symbol-value (car vcons)))
(error)))
`(cons :format "%v%h\n"
:doc ,(nth 2 entry)
(const :format "" ,(nth 0 entry))
,type)))
(if gnus-agent
gnus-agent-parameters))))
(unless (or group topic)
(error "No group on current line"))
(when (and group topic)
(error "Both a group and topic on current line"))
(error "Both a group an topic on current line"))
(unless (or topic (setq info (gnus-get-info group)))
(error "Killed group; can't be edited"))
;; Ready.
(kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(gnus-kill-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*"))
(gnus-custom-mode)
(make-local-variable 'gnus-custom-group)
@ -364,24 +400,54 @@ DOC is a documentation string for the parameter.")
:action 'gnus-group-customize-done)
(widget-insert ".\n\n")
(make-local-variable 'gnus-custom-params)
(setq gnus-custom-params
(widget-create 'group
:value (if group
(gnus-info-params info)
(gnus-topic-parameters topic))
`(set :inline t
:greedy t
:tag "Parameters"
:format "%t:\n%h%v"
:doc "\
(let ((values (if group
(gnus-info-params info)
(gnus-topic-parameters topic))))
;; The parameters in values may contain duplicates. This is
;; normally OK as assq returns the first. However, right here
;; every duplicate ends up being displayed. So, rather than
;; display them, remove them from the list.
(let ((tmp (setq values (gnus-copy-sequence values)))
elem)
(while (cdr tmp)
(while (setq elem (assq (caar tmp) (cdr tmp)))
(delq elem tmp))
(setq tmp (cdr tmp))))
(setq gnus-custom-params
(apply 'widget-create 'group
:value values
(delq nil
(list `(set :inline t
:greedy t
:tag "Parameters"
:format "%t:\n%h%v"
:doc "\
These special parameters are recognized by Gnus.
Check the [ ] for the parameters you want to apply to this group or
to the groups in this topic, then edit the value to suit your taste."
,@types)
'(repeat :inline t
:tag "Variables"
:format "%t:\n%h%v%i\n\n"
:doc "\
,@types)
(when gnus-agent
`(set :inline t
:greedy t
:tag "Agent Parameters"
:format "%t:\n%h%v"
:doc "\ These agent parameters are
recognized by Gnus. They control article selection and expiration for
use in the unplugged cache. Check the [ ] for the parameters you want
to apply to this group or to the groups in this topic, then edit the
value to suit your taste.
For those interested, group parameters override topic parameters while
topic parameters override agent category parameters. Underlying
category parameters are the customizable variables." ,@agent))
'(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
@ -394,14 +460,14 @@ 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?"
(list :format "%v" :value (nil nil)
(symbol :tag "Variable")
(sexp :tag
"Value")))
(list :format "%v" :value (nil nil)
(symbol :tag "Variable")
(sexp :tag
"Value")))
'(repeat :inline t
:tag "Unknown entries"
sexp)))
'(repeat :inline t
:tag "Unknown entries"
sexp))))))
(when group
(widget-insert "\n\nYou can also edit the ")
(widget-create 'info-link
@ -701,8 +767,13 @@ eh?")))
(defvar gnus-custom-score-alist)
(defun gnus-score-customize (file)
"Customize score file FILE."
"Customize score file FILE.
When called interactively, FILE defaults to the current score file.
This can be changed using the `\\[gnus-score-change-score-file]' command."
(interactive (list gnus-current-score-file))
(unless file
(error (format "No score file for %s"
(gnus-group-decoded-name gnus-newsgroup-name))))
(let ((scores (gnus-score-load file))
(types (mapcar (lambda (entry)
`(group :format "%v%h\n"
@ -814,6 +885,175 @@ articles in the thread.
(gnus-score-set 'touched '(t) alist))
(bury-buffer))
(eval-when-compile
(defvar category-fields nil)
(defvar gnus-agent-cat-name)
(defvar gnus-agent-cat-score-file)
(defvar gnus-agent-cat-length-when-short)
(defvar gnus-agent-cat-length-when-long)
(defvar gnus-agent-cat-low-score)
(defvar gnus-agent-cat-high-score)
(defvar gnus-agent-cat-enable-expiration)
(defvar gnus-agent-cat-days-until-old)
(defvar gnus-agent-cat-predicate)
(defvar gnus-agent-cat-groups)
(defvar gnus-agent-cat-enable-undownloaded-faces)
)
(defun gnus-trim-whitespace (s)
(when (string-match "\\`[ \n\t]+" s)
(setq s (substring s (match-end 0))))
(when (string-match "[ \n\t]+\\'" s)
(setq s (substring s 0 (match-beginning 0))))
s)
(defmacro gnus-agent-cat-prepare-category-field (parameter)
(let* ((entry (assq parameter gnus-agent-parameters))
(field (nth 3 entry)))
`(let* ((type (copy-sequence
(nth 1 (assq ',parameter gnus-agent-parameters))))
(val (,field info))
(deflt (if (,field defaults)
(concat " [" (gnus-trim-whitespace
(gnus-pp-to-string (,field defaults)))
"]")))
symb)
(if (eq (car type) 'radio)
(let* ((rtype (nreverse type))
(rt rtype))
(while (listp (or (cadr rt) 'not-list))
(setq rt (cdr rt)))
(setcdr rt (cons '(const :format "Inherit " nil) (cdr rt)))
(setq type (nreverse rtype))))
(if deflt
(let ((tag (cdr (memq :tag type))))
(when (string-match "\n" deflt)
(while (progn (setq deflt (replace-match "\n " t t
deflt))
(string-match "\n" deflt (match-end 0))))
(setq deflt (concat "\n" deflt)))
(setcar tag (concat (car tag) deflt))))
(widget-insert "\n")
(setq val (if val
(widget-create type :value val)
(widget-create type))
symb (set (make-local-variable ',field) val))
(widget-put symb :default val)
(widget-put symb :accessor ',field)
(push symb category-fields))))
(defun gnus-agent-customize-category (category)
"Edit the CATEGORY."
(interactive (list (gnus-category-name)))
(let ((info (assq category gnus-category-alist))
(defaults (list nil '(agent-predicate . false)
(cons 'agent-enable-expiration
gnus-agent-enable-expiration)
'(agent-days-until-old . 7)
(cons 'agent-length-when-short
gnus-agent-short-article)
(cons 'agent-length-when-long gnus-agent-long-article)
(cons 'agent-low-score gnus-agent-low-score)
(cons 'agent-high-score gnus-agent-high-score))))
(let ((old (get-buffer "*Gnus Agent Category Customize*")))
(when old
(gnus-kill-buffer old)))
(switch-to-buffer (gnus-get-buffer-create
"*Gnus Agent Category Customize*"))
(let ((inhibit-read-only t))
(gnus-custom-mode)
(buffer-disable-undo)
(let* ((name (gnus-agent-cat-name info)))
(widget-insert "Customize the Agent Category '")
(widget-insert (symbol-name name))
(widget-insert "' and press ")
(widget-create
'push-button
:notify
'(lambda (&rest ignore)
(let* ((info (assq gnus-agent-cat-name gnus-category-alist))
(widgets category-fields))
(while widgets
(let* ((widget (pop widgets))
(value (condition-case nil (widget-value widget) (error))))
(eval `(setf (,(widget-get widget :accessor) ',info)
',value)))))
(gnus-category-write)
(gnus-kill-buffer (current-buffer))
(when (get-buffer gnus-category-buffer)
(switch-to-buffer (get-buffer gnus-category-buffer))
(gnus-category-list)))
"Done")
(widget-insert
"\n Note: Empty fields default to the customizable global\
variables.\n\n")
(set (make-local-variable 'gnus-agent-cat-name)
name))
(set (make-local-variable 'category-fields) nil)
(gnus-agent-cat-prepare-category-field agent-predicate)
(gnus-agent-cat-prepare-category-field agent-score)
(gnus-agent-cat-prepare-category-field agent-short-article)
(gnus-agent-cat-prepare-category-field agent-long-article)
(gnus-agent-cat-prepare-category-field agent-low-score)
(gnus-agent-cat-prepare-category-field agent-high-score)
;; The group list is NOT handled with
;; gnus-agent-cat-prepare-category-field as I don't want the
;; group list to appear when customizing a topic.
(widget-insert "\n")
(let ((symb
(set
(make-local-variable 'gnus-agent-cat-groups)
(widget-create
`(choice
:format "%[Select Member Groups%]\n%v" :value ignore
(const :menu-tag "do not change" :tag "" :value ignore)
(checklist :entry-format "%b %v"
:menu-tag "display group selectors"
:greedy t
:value
,(delq nil
(mapcar
(lambda (newsrc)
(car (member
(gnus-info-group newsrc)
(gnus-agent-cat-groups info))))
(cdr gnus-newsrc-alist)))
,@(mapcar (lambda (newsrc)
`(const ,(gnus-info-group newsrc)))
(cdr gnus-newsrc-alist))))))))
(widget-put symb :default (gnus-agent-cat-groups info))
(widget-put symb :accessor 'gnus-agent-cat-groups)
(push symb category-fields))
(widget-insert "\nExpiration Settings ")
(gnus-agent-cat-prepare-category-field agent-enable-expiration)
(gnus-agent-cat-prepare-category-field agent-days-until-old)
(widget-insert "\nVisual Settings ")
(gnus-agent-cat-prepare-category-field agent-enable-undownloaded-faces)
(use-local-map widget-keymap)
(widget-setup)
(buffer-enable-undo))))
;;; The End:
(provide 'gnus-cus)

196
lisp/gnus/gnus-delay.el Normal file
View File

@ -0,0 +1,196 @@
;;; gnus-delay.el --- Delayed posting of articles
;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
;; Author: Kai Großjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
;; Keywords: mail, news, extensions
;; 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:
;; Provide delayed posting of articles.
;;; Todo:
;; * `gnus-delay-send-queue' barfs when group does not exist.
;; * Integrate gnus-delay.el into the rest of Gnus automatically. How
;; should this be done? Basically, we need to do what
;; `gnus-delay-initialize' does. But in which files?
;;; Code:
(require 'nndraft)
(require 'gnus-draft)
;;;###autoload
(defgroup gnus-delay nil
"Arrange for sending postings later."
:group 'gnus)
(defcustom gnus-delay-group "delayed"
"Group name for storing delayed articles."
:type 'string
:group 'gnus-delay)
(defcustom gnus-delay-header "X-Gnus-Delayed"
"Header name for storing info about delayed articles."
:type 'string
:group 'gnus-delay)
(defcustom gnus-delay-default-delay "3d"
"*Default length of delay."
:type 'string
:group 'gnus-delay)
(defcustom gnus-delay-default-hour 8
"*If deadline is given as date, then assume this time of day."
:type 'integer
:group 'gnus-delay)
;;;###autoload
(defun gnus-delay-article (delay)
"Delay this article by some time.
DELAY is a string, giving the length of the time. Possible values are:
* <digits><units> for <units> in minutes (`m'), hours (`h'), days (`d'),
weeks (`w'), months (`M'), or years (`Y');
* YYYY-MM-DD for a specific date. The time of day is given by the
variable `gnus-delay-default-hour', minute and second are zero.
* hh:mm for a specific time. Use 24h format. If it is later than this
time, then the deadline is tomorrow, else today."
(interactive
(list (read-string
"Target date (YYYY-MM-DD) or length of delay (units in [mhdwMY]): "
gnus-delay-default-delay)))
(let (num unit days year month day hour minute deadline)
(cond ((string-match
"\\([0-9][0-9][0-9]?[0-9]?\\)-\\([0-9]+\\)-\\([0-9]+\\)"
delay)
(setq year (string-to-number (match-string 1 delay))
month (string-to-number (match-string 2 delay))
day (string-to-number (match-string 3 delay)))
(setq deadline
(message-make-date
(encode-time 0 0 ; second and minute
gnus-delay-default-hour
day month year))))
((string-match "\\([0-9]+\\):\\([0-9]+\\)" delay)
(setq hour (string-to-number (match-string 1 delay))
minute (string-to-number (match-string 2 delay)))
;; Use current time, except...
(setq deadline (apply 'vector (decode-time (current-time))))
;; ... for minute and hour.
(aset deadline 1 minute)
(aset deadline 2 hour)
;; Convert to seconds.
(setq deadline (time-to-seconds (apply 'encode-time
(append deadline nil))))
;; If this time has passed already, add a day.
(when (< deadline (time-to-seconds (current-time)))
(setq deadline (+ 3600 deadline))) ;3600 secs/day
;; Convert seconds to date header.
(setq deadline (message-make-date
(seconds-to-time deadline))))
((string-match "\\([0-9]+\\)\\s-*\\([mhdwMY]\\)" delay)
(setq num (match-string 1 delay))
(setq unit (match-string 2 delay))
;; Start from seconds, then multiply into needed units.
(setq num (string-to-number num))
(cond ((string= unit "Y")
(setq delay (* num 60 60 24 365)))
((string= unit "M")
(setq delay (* num 60 60 24 30)))
((string= unit "w")
(setq delay (* num 60 60 24 7)))
((string= unit "d")
(setq delay (* num 60 60 24)))
((string= unit "h")
(setq delay (* num 60 60)))
(t
(setq delay (* num 60))))
(setq deadline (message-make-date
(seconds-to-time (+ (time-to-seconds (current-time))
delay)))))
(t (error "Malformed delay `%s'" delay)))
(message-add-header (format "%s: %s" gnus-delay-header deadline)))
(set-buffer-modified-p t)
;; If group does not exist, create it.
(let ((group (format "nndraft:%s" gnus-delay-group)))
(gnus-agent-queue-setup gnus-delay-group))
(message-disassociate-draft)
(nndraft-request-associate-buffer gnus-delay-group)
(save-buffer 0)
(kill-buffer (current-buffer))
(message-do-actions message-postpone-actions))
;;;###autoload
(defun gnus-delay-send-queue ()
"Send all the delayed messages that are due now."
(interactive)
(save-excursion
(let* ((group (format "nndraft:%s" gnus-delay-group))
(message-send-hook (copy-sequence message-send-hook))
articles
article deadline)
(when (gnus-gethash group gnus-newsrc-hashtb)
(gnus-activate-group group)
(add-hook 'message-send-hook
'(lambda ()
(message-remove-header gnus-delay-header)))
(setq articles (nndraft-articles))
(while (setq article (pop articles))
(gnus-request-head article group)
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(if (re-search-forward
(concat "^" (regexp-quote gnus-delay-header) ":\\s-+")
nil t)
(progn
(setq deadline (nnheader-header-value))
(setq deadline (apply 'encode-time
(parse-time-string deadline)))
(setq deadline (time-since deadline))
(when (and (>= (nth 0 deadline) 0)
(>= (nth 1 deadline) 0))
(message "Sending delayed article %d" article)
(gnus-draft-send article group)
(message "Sending delayed article %d...done" article)))
(message "Delay header missing for article %d" article)))))))
;;;###autoload
(defun gnus-delay-initialize (&optional no-keymap no-check)
"Initialize the gnus-delay package.
This sets up a key binding in `message-mode' to delay a message.
This tells Gnus to look for delayed messages after getting new news.
The optional arg NO-KEYMAP is ignored.
Checking delayed messages is skipped if optional arg NO-CHECK is non-nil."
(unless no-check
(add-hook 'gnus-get-new-news-hook 'gnus-delay-send-queue)))
(provide 'gnus-delay)
;; Local Variables:
;; coding: iso-8859-1
;; End:
;;; arch-tag: fb2ad634-a897-4142-a503-f5991ec2349d
;;; gnus-delay.el ends here

56
lisp/gnus/gnus-demon.el
View File

@ -1,5 +1,7 @@
;;; gnus-demon.el --- daemonic Gnus behaviour
;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -148,32 +150,32 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(if (not (stringp time))
time
(let* ((now (current-time))
;; obtain NOW as discrete components -- make a vector for speed
(nowParts (decode-time now))
;; obtain THEN as discrete components
(thenParts (parse-time-string time))
(thenHour (elt thenParts 2))
(thenMin (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)))))
;; obtain NOW as discrete components -- make a vector for speed
(nowParts (decode-time now))
;; obtain THEN as discrete components
(thenParts (parse-time-string time))
(thenHour (elt thenParts 2))
(thenMin (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)))))

461
lisp/gnus/gnus-diary.el Normal file
View File

@ -0,0 +1,461 @@
;;; gnus-diary.el --- Wrapper around the NNDiary Gnus backend
;; Copyright (c) 2001, 2002, 2003 Free Software Foundation, Inc.
;; Copyright (C) 1999, 2000, 2001 Didier Verna.
;; Author: Didier Verna <didier@xemacs.org>
;; Maintainer: Didier Verna <didier@xemacs.org>
;; Created: Tue Jul 20 10:42:55 1999
;; Keywords: calendar 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 of the License,
;; 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 this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; Contents management by FCM version 0.1.
;; Description:
;; ===========
;; Gnus-Diary is a wrapper around the NNDiary Gnus backend. It is here to
;; make your nndiary-user life easier in different ways. So, you don't have
;; to use it if you don't want to. But, really, you should.
;; Gnus-Diary offers the following features on top of the NNDiary backend:
;; - A nice summary line format:
;; Displaying diary messages in standard summary line format (usually
;; something like "<From Joe>: <Subject>") is pretty useless. Most of the
;; time, you're the one who wrote the message, and you mostly want to see
;; the event's date. Gnus-Diary offers you a nice summary line format
;; which will do this. By default, a summary line will appear like this:
;;
;; <Event Date>: <Subject> <Remaining time>
;;
;; for example, here's how Joe's birthday is displayed in my
;; "nndiary:birhdays" summary buffer (the message is expirable, but will
;; never be deleted, as it specifies a regular event):
;;
;; E Sat, Sep 22 01, 12:00: Joe's birthday (in 6 months, 1 week)
;; - More article sorting functions:
;; Gnus-Diary adds a new sorting function called
;; `gnus-summary-sort-by-schedule'. This function lets you organize your
;; diary summary buffers from the closest event to the farthest one.
;; - Automatic generation of diary group parameters:
;; When you create a new diary group, or visit one, Gnus-Diary checks your
;; group parameters, and if needed, sets the summary line format to the
;; diary-specific value, adds the diary-specific sorting functions, and
;; also adds the different `X-Diary-*' headers to the group's
;; posting-style. It is then easier to send a diary message, because if
;; you use `C-u a' or `C-u m' on a diary group to prepare a message, these
;; headers will be inserted automatically (but not filled with proper
;; values yet).
;; - An interactive mail-to-diary convertion function:
;; The function `gnus-diary-check-message' ensures that the current message
;; contains all the required diary headers, and prompts you for values /
;; correction if needed. This function is hooked in the nndiary backend so
;; that moving an article to an nndiary group will trigger it
;; automatically. It is also bound to `C-c D c' in message-mode and
;; article-edit-mode in order to ease the process of converting a usual
;; mail to a diary one. This function takes a prefix argument which will
;; force prompting of all diary headers, regardless of their
;; presence/validity. That way, you can very easily reschedule a diary
;; message for instance.
;; Usage:
;; =====
;; 0/ Don't use any `gnus-user-format-function-[d|D]'. Gnus-Diary provides
;; both of these (sorry if you used them before).
;; 1/ Add '(require 'gnus-diary) to your gnusrc file.
;; 2/ Customize your gnus-diary options to suit your needs.
;; Bugs / Todo:
;; ===========
;;; Code:
(require 'nndiary)
(require 'message)
(require 'gnus-art)
(defgroup gnus-diary nil
"Utilities on top of the nndiary backend for Gnus.")
(defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n"
"*Summary line format for nndiary groups."
:type 'string
:group 'gnus-diary
:group 'gnus-summary-format)
(defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M"
"*Time format to display appointements in nndiary summary buffers.
Please refer to `format-time-string' for information on possible values."
:type 'string
:group 'gnus-diary)
(defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english
"*Function called to format a diary delay string.
It is passed two arguments. The first one is non nil if the delay is in
the past. The second one is of the form ((NUM . UNIT) ...) where NUM is
an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute.
It should return strings like \"In 2 months, 3 weeks\", \"3 hours,
1 minute ago\" and so on.
There are currently two built-in format functions:
`gnus-diary-delay-format-english' (the default)
`gnus-diary-delay-format-french'"
:type '(choice (const :tag "english" gnus-diary-delay-format-english)
(const :tag "french" gnus-diary-delay-format-french)
(symbol :tag "other"))
:group 'gnus-diary)
(defconst gnus-diary-version nndiary-version
"Current Diary backend version.")
;; Compatibility functions ==================================================
(eval-and-compile
(if (fboundp 'kill-entire-line)
(defalias 'gnus-diary-kill-entire-line 'kill-entire-line)
(defun gnus-diary-kill-entire-line ()
(beginning-of-line)
(let ((kill-whole-line t))
(kill-line)))))
;; Summary line format ======================================================
(defun gnus-diary-delay-format-french (past delay)
(if (null delay)
"maintenant!"
;; Keep only a precision of two degrees
(and (> (length delay) 1) (setcdr (cdr delay) nil))
(concat (if past "il y a " "dans ")
(let ((str "")
del)
(while (setq del (pop delay))
(setq str (concat str
(int-to-string (car del)) " "
(cond ((eq (cdr del) 'year)
"an")
((eq (cdr del) 'month)
"mois")
((eq (cdr del) 'week)
"semaine")
((eq (cdr del) 'day)
"jour")
((eq (cdr del) 'hour)
"heure")
((eq (cdr del) 'minute)
"minute"))
(unless (or (eq (cdr del) 'month)
(= (car del) 1))
"s")
(if delay ", "))))
str))))
(defun gnus-diary-delay-format-english (past delay)
(if (null delay)
"now!"
;; Keep only a precision of two degrees
(and (> (length delay) 1) (setcdr (cdr delay) nil))
(concat (unless past "in ")
(let ((str "")
del)
(while (setq del (pop delay))
(setq str (concat str
(int-to-string (car del)) " "
(symbol-name (cdr del))
(and (> (car del) 1) "s")
(if delay ", "))))
str)
(and past " ago"))))
(defun gnus-diary-header-schedule (headers)
;; Same as `nndiary-schedule', but given a set of headers HEADERS
(mapcar
(lambda (elt)
(let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt)))
headers))))
(when head
(nndiary-parse-schedule-value head (cadr elt) (caddr elt)))))
nndiary-headers))
;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
;; message, with all fields set to nil here. I don't know what it is for, and
;; I just ignore it.
(defun gnus-user-format-function-d (header)
;; Returns an aproximative delay string for the next occurence of this
;; message. The delay is given only in the first non zero unit.
;; Code partly stolen from article-make-date-line
(let* ((extras (mail-header-extra header))
(sched (gnus-diary-header-schedule extras))
(occur (nndiary-next-occurence sched (current-time)))
(now (current-time))
(real-time (subtract-time occur now)))
(if (null real-time)
"?????"
(let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time)))
(past (< sec 0))
delay)
(and past (setq sec (- sec)))
(unless (zerop sec)
;; 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.
(let ((units `((year . ,(* 365.25 24 3600))
(month . ,(* 31 24 3600))
(week . ,(* 7 24 3600))
(day . ,(* 24 3600))
(hour . 3600)
(minute . 60)))
unit num)
(while (setq unit (pop units))
(unless (zerop (setq num (ffloor (/ sec (cdr unit)))))
(setq delay (append delay `((,(floor num) . ,(car unit))))))
(setq sec (- sec (* num (cdr unit)))))))
(funcall gnus-diary-delay-format-function past delay)))
))
;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
;; message, with all fields set to nil here. I don't know what it is for, and
;; I just ignore it.
(defun gnus-user-format-function-D (header)
;; Returns a formatted time string for the next occurence of this message.
(let* ((extras (mail-header-extra header))
(sched (gnus-diary-header-schedule extras))
(occur (nndiary-next-occurence sched (current-time))))
(format-time-string gnus-diary-time-format occur)))
;; Article sorting functions ================================================
(defun gnus-article-sort-by-schedule (h1 h2)
(let* ((now (current-time))
(e1 (mail-header-extra h1))
(e2 (mail-header-extra h2))
(s1 (gnus-diary-header-schedule e1))
(s2 (gnus-diary-header-schedule e2))
(o1 (nndiary-next-occurence s1 now))
(o2 (nndiary-next-occurence s2 now)))
(if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2)))
(< (mail-header-number h1) (mail-header-number h2))
(time-less-p o1 o2))))
(defun gnus-thread-sort-by-schedule (h1 h2)
(gnus-article-sort-by-schedule (gnus-thread-header h1)
(gnus-thread-header h2)))
(defun gnus-summary-sort-by-schedule (&optional reverse)
"Sort nndiary summary buffers by schedule of appointements.
Optional prefix (or REVERSE argument) means sort in reverse order."
(interactive "P")
(gnus-summary-sort 'schedule reverse))
(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
(add-hook 'gnus-summary-menu-hook
(lambda ()
(easy-menu-add-item gnus-summary-misc-menu
'("Sort")
["Sort by schedule"
gnus-summary-sort-by-schedule
(eq (car (gnus-find-method-for-group
gnus-newsgroup-name))
'nndiary)]
"Sort by number")))
;; Group parameters autosetting =============================================
(defun gnus-diary-update-group-parameters (group)
;; Ensure that nndiary groups have convenient group parameters:
;; - a posting style containing X-Diary headers
;; - a nice summary line format
;; - NNDiary specific sorting by schedule functions
;; In general, try not to mess with what the user might have modified.
(let ((posting-style (gnus-group-get-parameter group 'posting-style t)))
;; Posting style:
(mapcar (lambda (elt)
(let ((header (format "X-Diary-%s" (car elt))))
(unless (assoc header posting-style)
(setq posting-style (append posting-style
`((,header "*")))))
))
nndiary-headers)
(gnus-group-set-parameter group 'posting-style posting-style)
;; Summary line format:
(unless (gnus-group-get-parameter group 'gnus-summary-line-format t)
(gnus-group-set-parameter group 'gnus-summary-line-format
`(,gnus-diary-summary-line-format)))
;; Sorting by schedule:
(unless (gnus-group-get-parameter group 'gnus-article-sort-functions)
(gnus-group-set-parameter group 'gnus-article-sort-functions
'((append gnus-article-sort-functions
(list
'gnus-article-sort-by-schedule)))))
(unless (gnus-group-get-parameter group 'gnus-thread-sort-functions)
(gnus-group-set-parameter group 'gnus-thread-sort-functions
'((append gnus-thread-sort-functions
(list
'gnus-thread-sort-by-schedule)))))
))
;; Called when a group is subscribed. This is needed because groups created
;; because of mail splitting are *not* created with the backend function.
;; Thus, `nndiary-request-create-group-hooks' is inoperative.
(defun gnus-diary-maybe-update-group-parameters (group)
(when (eq (car (gnus-find-method-for-group group)) 'nndiary)
(gnus-diary-update-group-parameters group)))
(add-hook 'nndiary-request-create-group-hooks
'gnus-diary-update-group-parameters)
;; Now that we have `gnus-subscribe-newsgroup-hooks', this is not needed
;; anymore. Maybe I should remove this completely.
(add-hook 'nndiary-request-update-info-hooks
'gnus-diary-update-group-parameters)
(add-hook 'gnus-subscribe-newsgroup-hooks
'gnus-diary-maybe-update-group-parameters)
;; Diary Message Checking ===================================================
(defvar gnus-diary-header-value-history nil
;; History variable for header value prompting
)
(defun gnus-diary-narrow-to-headers ()
"Narrow the current buffer to the header part.
Point is left at the beginning of the region.
The buffer is assumed to contain a message, but the format is unknown."
(cond ((eq major-mode 'message-mode)
(message-narrow-to-headers))
(t
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(narrow-to-region (point-min) (- (point) 1))
(goto-char (point-min))))
))
(defun gnus-diary-add-header (str)
"Add a header to the current buffer.
The buffer is assumed to contain a message, but the format is unknown."
(cond ((eq major-mode 'message-mode)
(message-add-header str))
(t
(save-restriction
(gnus-diary-narrow-to-headers)
(goto-char (point-max))
(if (string-match "\n$" str)
(insert str)
(insert str ?\n))))
))
(defun gnus-diary-check-message (arg)
"Ensure that the current message is a valid for NNDiary.
This function checks that all NNDiary required headers are present and
valid, and prompts for values / correction otherwise.
If ARG (or prefix) is non-nil, force prompting for all fields."
(interactive "P")
(save-excursion
(mapcar
(lambda (head)
(let ((header (concat "X-Diary-" (car head)))
(ask arg)
value invalid)
;; First, try to find the header, and checks for validity:
(save-restriction
(gnus-diary-narrow-to-headers)
(when (re-search-forward (concat "^" header ":") nil t)
(unless (eq (char-after) ? )
(insert " "))
(setq value (buffer-substring (point) (gnus-point-at-eol)))
(and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value)
(setq value (match-string 1 value)))
(condition-case ()
(nndiary-parse-schedule-value value
(nth 1 head) (nth 2 head))
(t
(setq invalid t)))
;; #### NOTE: this (along with the `gnus-diary-add-header'
;; function) could be rewritten in a better way, in particular
;; not to blindly remove an already present header and reinsert
;; it somewhere else afterwards.
(when (or ask invalid)
(gnus-diary-kill-entire-line))
))
;; Now, loop until a valid value is provided:
(while (or ask (not value) invalid)
(let ((prompt (concat (and invalid
(prog1 "(current value invalid) "
(beep)))
header ": ")))
(setq value
(if (listp (nth 1 head))
(completing-read prompt (cons '("*" nil) (nth 1 head))
nil t value
gnus-diary-header-value-history)
(read-string prompt value
gnus-diary-header-value-history))))
(setq ask nil)
(setq invalid nil)
(condition-case ()
(nndiary-parse-schedule-value value
(nth 1 head) (nth 2 head))
(t
(setq invalid t))))
(gnus-diary-add-header (concat header ": " value))
))
nndiary-headers)
))
(add-hook 'nndiary-request-accept-article-hooks
(lambda () (gnus-diary-check-message nil)))
(define-key message-mode-map "\C-cDc" 'gnus-diary-check-message)
(define-key gnus-article-edit-mode-map "\C-cDc" 'gnus-diary-check-message)
;; The end ==================================================================
(defun gnus-diary-version ()
"Current Diary backend version."
(interactive)
(message "NNDiary version %s" nndiary-version))
(define-key message-mode-map "\C-cDv" 'gnus-diary-version)
(define-key gnus-article-edit-mode-map "\C-cDv" 'gnus-diary-version)
(provide 'gnus-diary)
;;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b
;;; gnus-diary.el ends here

207
lisp/gnus/gnus-dired.el Normal file
View File

@ -0,0 +1,207 @@
;;; gnus-dired.el --- utility functions where gnus and dired meet
;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Authors: Benjamin Rutt <brutt@bloomington.in.us>,
;; Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: mail, news, extensions
;; 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 utility functions for intersections of gnus
;; and dired. To enable the gnus-dired-mode minor mode which will
;; have the effect of installing keybindings in dired-mode, place the
;; following in your ~/.gnus:
;; (require 'gnus-dired) ;, isn't needed due to autoload cookies
;; (add-hook 'dired-mode-hook 'turn-on-gnus-dired-mode)
;; Note that if you visit dired buffers before your ~/.gnus file has
;; been read, those dired buffers won't have the keybindings in
;; effect. To get around that problem, you may want to add the above
;; statements to your ~/.emacs instead.
;;; Code:
(require 'dired)
(require 'gnus-ems)
(require 'gnus-msg)
(require 'gnus-util)
(require 'message)
(require 'mm-encode)
(require 'mml)
(defvar gnus-dired-mode nil
"Minor mode for intersections of gnus and dired.")
(defvar gnus-dired-mode-map nil)
(unless gnus-dired-mode-map
(setq gnus-dired-mode-map (make-sparse-keymap))
(gnus-define-keys gnus-dired-mode-map
"\C-c\C-m\C-a" gnus-dired-attach
"\C-c\C-m\C-l" gnus-dired-find-file-mailcap
"\C-c\C-m\C-p" gnus-dired-print))
(defun gnus-dired-mode (&optional arg)
"Minor mode for intersections of gnus and dired.
\\{gnus-dired-mode-map}"
(interactive "P")
(when (eq major-mode 'dired-mode)
(set (make-local-variable 'gnus-dired-mode)
(if (null arg) (not gnus-dired-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-dired-mode
(gnus-add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map)
(gnus-run-hooks 'gnus-dired-mode-hook))))
;;;###autoload
(defun turn-on-gnus-dired-mode ()
"Convenience method to turn on gnus-dired-mode."
(gnus-dired-mode 1))
;; Method to attach files to a gnus composition.
(defun gnus-dired-attach (files-to-attach)
"Attach dired's marked files to a gnus message composition.
If called non-interactively, FILES-TO-ATTACH should be a list of
filenames."
(interactive
(list
(delq nil
(mapcar
;; don't attach directories
(lambda (f) (if (file-directory-p f) nil f))
(nreverse (dired-map-over-marks (dired-get-filename) nil))))))
(let ((destination nil)
(files-str nil)
(bufs nil))
;; warn if user tries to attach without any files marked
(if (null files-to-attach)
(error "No files to attach")
(setq files-str
(mapconcat
(lambda (f) (file-name-nondirectory f))
files-to-attach ", "))
(setq bufs (message-buffers))
;; set up destination message buffer
(if (and bufs
(y-or-n-p "Attach files to existing message buffer? "))
(setq destination
(if (= (length bufs) 1)
(get-buffer (car bufs))
(completing-read "Attach to which message buffer: "
(mapcar
(lambda (b)
(cons b (get-buffer b)))
bufs)
nil t)))
;; setup a new gnus message buffer
(gnus-setup-message 'message (message-mail))
(setq destination (current-buffer)))
;; set buffer to destination buffer, and attach files
(set-buffer destination)
(goto-char (point-max)) ;attach at end of buffer
(while files-to-attach
(mml-attach-file (car files-to-attach)
(or (mm-default-file-encoding (car files-to-attach))
"application/octet-stream") nil)
(setq files-to-attach (cdr files-to-attach)))
(message "Attached file(s) %s" files-str))))
(autoload 'mailcap-parse-mailcaps "mailcap" "" t)
(defun gnus-dired-find-file-mailcap (&optional file-name arg)
"In dired, visit FILE-NAME according to the mailcap file.
If ARG is non-nil, open it in a new buffer."
(interactive (list
(file-name-sans-versions (dired-get-filename) t)
current-prefix-arg))
(mailcap-parse-mailcaps)
(if (file-exists-p file-name)
(let (mime-type method)
(if (and (not arg)
(not (file-directory-p file-name))
(string-match "\\.[^\\.]+$" file-name)
(setq mime-type
(mailcap-extension-to-mime
(match-string 0 file-name)))
(stringp
(setq method
(cdr (assoc 'viewer
(car (mailcap-mime-info mime-type
'all)))))))
(let ((view-command (mm-mailcap-command method file-name nil)))
(message "viewing via %s" view-command)
(start-process "*display*"
nil
shell-file-name
shell-command-switch
view-command))
(find-file file-name)))
(if (file-symlink-p file-name)
(error "File is a symlink to a nonexistent target")
(error "File no longer exists; type `g' to update Dired buffer"))))
(defun gnus-dired-print (&optional file-name print-to)
"In dired, print FILE-NAME according to the mailcap file.
If there is no print command, print in a PostScript image. If the
optional argument PRINT-TO is nil, send the image to the printer. If
PRINT-TO is a string, save the PostScript image in a file with that
name. If PRINT-TO is a number, prompt the user for the name of the
file to save in."
(interactive (list
(file-name-sans-versions (dired-get-filename) t)
(ps-print-preprint current-prefix-arg)))
(mailcap-parse-mailcaps)
(cond
((file-directory-p file-name)
(error "Can't print a directory"))
((file-exists-p file-name)
(let (mime-type method)
(if (and (string-match "\\.[^\\.]+$" file-name)
(setq mime-type
(mailcap-extension-to-mime
(match-string 0 file-name)))
(stringp
(setq method (mailcap-mime-info mime-type "print"))))
(call-process shell-file-name nil
(generate-new-buffer " *mm*")
nil
shell-command-switch
(mm-mailcap-command method file-name mime-type))
(with-temp-buffer
(insert-file-contents file-name)
(gnus-print-buffer))
(ps-despool print-to))))
((file-symlink-p file-name)
(error "File is a symlink to a nonexistent target"))
(t
(error "File no longer exists; type `g' to update Dired buffer"))))
(provide 'gnus-dired)
;;; arch-tag: 44737731-e445-4638-a31e-713c7590ec76
;;; gnus-dired.el ends here

107
lisp/gnus/gnus-draft.el
View File

@ -1,5 +1,5 @@
;;; gnus-draft.el --- draft message support for Gnus
;; Copyright (C) 1997, 1998, 1999, 2000
;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -46,6 +46,7 @@
(gnus-define-keys gnus-draft-mode-map
"Dt" gnus-draft-toggle-sending
"e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article'
"De" gnus-draft-edit-message
"Ds" gnus-draft-send-message
"DS" gnus-draft-send-all-messages))
@ -94,13 +95,18 @@
(defun gnus-draft-edit-message ()
"Enter a mail/post buffer to edit and send the draft."
(interactive)
(let ((article (gnus-summary-article-number)))
(let ((article (gnus-summary-article-number))
(group gnus-newsgroup-name))
(gnus-summary-mark-as-read article gnus-canceled-mark)
(gnus-draft-setup article gnus-newsgroup-name t)
(gnus-draft-setup article group t)
(set-buffer-modified-p t)
(save-excursion
(save-restriction
(message-narrow-to-headers)
(message-remove-header "date")))
(save-buffer)
(let ((gnus-verbose-backends nil))
(gnus-request-expire-articles (list article) gnus-newsgroup-name t))
(gnus-request-expire-articles (list article) group t))
(push
`((lambda ()
(when (gnus-buffer-exists-p ,gnus-summary-buffer)
@ -126,8 +132,9 @@
(defun gnus-draft-send (article &optional group interactive)
"Send message ARTICLE."
(let ((message-syntax-checks (if interactive nil
(let ((message-syntax-checks (if interactive message-syntax-checks
'dont-check-for-anything-just-trust-me))
(message-hidden-headers nil)
(message-inhibit-body-encoding (or (not group)
(equal group "nndraft:queue")
message-inhibit-body-encoding))
@ -135,12 +142,19 @@
message-send-hook))
(message-setup-hook (and group (not (equal group "nndraft:queue"))
message-setup-hook))
type method)
type method move-to)
(gnus-draft-setup article (or group "nndraft:queue"))
;; We read the meta-information that says how and where
;; this message is to be sent.
(save-restriction
(message-narrow-to-head)
(when (re-search-forward
(concat "^" (regexp-quote gnus-agent-target-move-group-header)
":") nil t)
(skip-syntax-forward "-")
(setq move-to (buffer-substring (point) (gnus-point-at-eol)))
(message-remove-header gnus-agent-target-move-group-header))
(goto-char (point-min))
(when (re-search-forward
(concat "^" (regexp-quote gnus-agent-meta-information-header) ":")
nil t)
@ -159,8 +173,12 @@
(message-this-is-mail (eq type 'mail))
(gnus-post-method method)
(message-post-method method))
(message-send-and-exit))
(message-send-and-exit)))
(if move-to
(gnus-inews-do-gcc move-to)
(message-send-and-exit)))
(if move-to
(gnus-inews-do-gcc move-to)
(message-send-and-exit))))
(let ((gnus-verbose-backends nil))
(gnus-request-expire-articles
(list article) (or group "nndraft:queue") t)))))
@ -168,10 +186,14 @@
(defun gnus-draft-send-all-messages ()
"Send all the sendable drafts."
(interactive)
(gnus-uu-mark-buffer)
(gnus-draft-send-message))
(when (or
gnus-expert-user
(gnus-y-or-n-p
"Send all drafts? "))
(gnus-uu-mark-buffer)
(gnus-draft-send-message)))
(defun gnus-group-send-drafts ()
(defun gnus-group-send-queue ()
"Send all sendable articles from the queue group."
(interactive)
(gnus-activate-group "nndraft:queue")
@ -181,6 +203,7 @@
(cdr (assq 'unsend
(gnus-info-marks
(gnus-get-info "nndraft:queue"))))))
(gnus-posting-styles nil)
(total (length articles))
article)
(while (setq article (pop articles))
@ -190,6 +213,20 @@
(- total (length articles)) total)))
(gnus-draft-send article)))))))
;;;###autoload
(defun gnus-draft-reminder ()
"Reminder user if there are unsent drafts."
(interactive)
(if (gnus-alive-p)
(let (active)
(catch 'continue
(dolist (group '("nndraft:drafts" "nndraft:queue"))
(setq active (gnus-activate-group group))
(if (and active (>= (cdr active) (car active)))
(if (y-or-n-p "There are unsent drafts. Confirm to exit? ")
(throw 'continue t)
(error "Stop!"))))))))
;;; Utility functions
;;;!!!If this is byte-compiled, it fails miserably.
@ -199,21 +236,41 @@
(progn
(defun gnus-draft-setup (narticle group &optional restore)
(gnus-setup-message 'forward
(let ((article narticle))
(message-mail)
(erase-buffer)
(if (not (gnus-request-restore-buffer article group))
(error "Couldn't restore the article")
(if (and restore (equal group "nndraft:queue"))
(let (ga)
(gnus-setup-message 'forward
(let ((article narticle))
(message-mail)
(erase-buffer)
(if (not (gnus-request-restore-buffer article group))
(error "Couldn't restore the article")
(when (and restore
(equal group "nndraft:queue"))
(mime-to-mml))
;; Insert the separator.
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(insert mail-header-separator)
(forward-line 1)
(message-set-auto-save-file-name))))))
;; Insert the separator.
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(insert mail-header-separator)
(forward-line 1)
(setq ga (message-fetch-field gnus-draft-meta-information-header))
(message-set-auto-save-file-name))))
(gnus-backlog-remove-article group narticle)
(when (and ga
(ignore-errors (setq ga (car (read-from-string ga)))))
(setq gnus-newsgroup-name
(if (equal (car ga) "") nil (car ga)))
(gnus-configure-posting-styles)
(setq gnus-message-group-art (cons gnus-newsgroup-name (cadr ga)))
(setq message-post-method
`(lambda (arg)
(gnus-post-method arg ,(car ga))))
(unless (equal (cadr ga) "")
(message-add-action
`(progn
(gnus-add-mark ,(car ga) 'replied ,(cadr ga))
(gnus-request-set-mark ,(car ga) (list (list (list ,(cadr ga))
'add '(reply)))))
'send))))))
(defun gnus-draft-article-sendable-p (article)
"Say whether ARTICLE is sendable."

10
lisp/gnus/gnus-dup.el
View File

@ -113,7 +113,7 @@ seen in the same session."
(gnus-dup-open))
(setq gnus-dup-list-dirty t) ; mark list for saving
(let ((data gnus-newsgroup-data)
datum msgid)
datum msgid)
;; Enter the Message-IDs of all read articles into the list
;; and hash table.
(while (setq datum (pop data))
@ -121,11 +121,11 @@ seen in the same session."
(> (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)))
(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))))
(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

8
lisp/gnus/gnus-eform.el
View File

@ -1,5 +1,5 @@
;;; gnus-eform.el --- a mode for editing forms for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -106,7 +106,7 @@ of the buffer."
(insert ";; Type `C-c C-c' after you've finished editing.\n")
(insert "\n")
(let ((p (point)))
(pp form (current-buffer))
(gnus-pp form)
(insert "\n")
(goto-char p))))
@ -114,7 +114,9 @@ of the buffer."
"Update changes and kill the current buffer."
(interactive)
(goto-char (point-min))
(let ((form (read (current-buffer)))
(let ((form (condition-case nil
(read (current-buffer))
(end-of-file nil)))
(func gnus-edit-form-done-function))
(gnus-edit-form-exit)
(funcall func form)))

164
lisp/gnus/gnus-ems.el
View File

@ -1,5 +1,5 @@
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -45,12 +45,13 @@
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
(autoload 'appt-select-lowest-window "appt"))
(autoload 'appt-select-lowest-window "appt")
(autoload 'gnus-get-buffer-create "gnus")
(autoload 'nnheader-find-etc-directory "nnheader"))
(if (featurep 'xemacs)
(autoload 'gnus-smiley-display "smiley")
(autoload 'gnus-smiley-display "smiley-ems") ; override XEmacs version
)
(autoload 'smiley-region "smiley")
;; Fixme: shouldn't require message
(autoload 'message-text-with-property "message")
(defun gnus-kill-all-overlays ()
"Delete all overlays in the current buffer."
@ -70,21 +71,31 @@
(truncate-string-to-width valstr ,max-width)
valstr)))
(eval-and-compile
(defalias 'gnus-char-width
(if (fboundp 'char-width)
'char-width
(lambda (ch) 1)))) ;; A simple hack.
(eval-and-compile
(if (featurep 'xemacs)
(gnus-xmas-define)
(defvar gnus-mouse-face-prop 'mouse-face
"Property used for highlighting mouse regions.")))
(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)
(eval-when-compile
(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-check-before-posting)
(defvar gnus-mouse-face)
(defvar gnus-group-buffer))
(defun gnus-ems-redefine ()
(cond
@ -96,18 +107,18 @@
;; [Note] Now there are three kinds of mule implementations,
;; original MULE, XEmacs/mule and Emacs 20+ including
;; MULE features. Unfortunately these API are different. In
;; particular, Emacs (including original MULE) and XEmacs are
;; MULE features. Unfortunately these APIs are different. In
;; particular, Emacs (including original Mule) and XEmacs are
;; quite different. However, this version of Gnus doesn't support
;; anything other than XEmacs 20+ and Emacs 20.3+.
;; Predicates to check are following:
;; (boundp 'MULE) is t only if MULE (original; anything older than
;; (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.
;; (featurep 'mule) is t when other mule variants are running.
;; It is possible to detect XEmacs/mule by (featurep 'mule) and
;; checking `emacs-version'. In this case, the implementation for
;; (featurep 'xemacs). In this case, the implementation for
;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
(defvar gnus-summary-display-table nil
@ -144,6 +155,10 @@
(boundp 'mark-active)
mark-active))
(defun gnus-mark-active-p ()
"Non-nil means the mark and region are currently active in this buffer."
mark-active) ; aliased to region-exists-p in XEmacs.
(if (fboundp 'add-minor-mode)
(defalias 'gnus-add-minor-mode 'add-minor-mode)
(defun gnus-add-minor-mode (mode name map &rest rest)
@ -166,11 +181,13 @@
(when (and dir
(file-exists-p (setq file
(expand-file-name "x-splash" dir))))
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(ignore-errors
(setq pixmap (read (current-buffer))))))
(let ((coding-system-for-read 'raw-text)
default-enable-multibyte-characters)
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(ignore-errors
(setq pixmap (read (current-buffer)))))))
(when pixmap
(make-face 'gnus-splash)
(setq height (/ (car pixmap) (frame-char-height))
@ -189,81 +206,36 @@
(goto-char (point-min))
(sit-for 0))))))
(defvar gnus-article-xface-ring-internal nil
"Cache for face data.")
;;; Image functions.
;; Worth customizing?
(defvar gnus-article-xface-ring-size 6
"Length of the ring used for `gnus-article-xface-ring-internal'.")
(defun gnus-image-type-available-p (type)
(and (fboundp 'image-type-available-p)
(image-type-available-p type)))
(defvar gnus-article-compface-xbm
(eq 0 (string-match "#define" (shell-command-to-string "uncompface -X")))
"Non-nil means the compface program supports the -X option.
That produces XBM output.")
(defun gnus-create-image (file &optional type data-p &rest props)
(let ((face (plist-get props :face)))
(when face
(setq props (plist-put props :foreground (face-foreground face)))
(setq props (plist-put props :background (face-background face))))
(apply 'create-image file type data-p props)))
(defun gnus-article-display-xface (beg end)
"Display an XFace header from between BEG and END in the current article.
Requires support for images in your Emacs and the external programs
`uncompface', and `icontopbm'. On a GNU/Linux system these
might be in packages with names like `compface' or `faces-xface' and
`netpbm' or `libgr-progs', for instance. See also
`gnus-article-compface-xbm'.
(defun gnus-put-image (glyph &optional string category)
(let ((point (point)))
(insert-image glyph (or string " "))
(put-text-property point (point) 'gnus-image-category category)
(unless string
(put-text-property (1- (point)) (point)
'gnus-image-text-deletable t))
glyph))
This function is for Emacs 21+. See `gnus-xmas-article-display-xface'
for XEmacs."
;; It might be worth converting uncompface's output in Lisp.
(when (if (fboundp 'display-graphic-p)
(display-graphic-p))
(unless gnus-article-xface-ring-internal ; Only load ring when needed.
(setq gnus-article-xface-ring-internal
(make-ring gnus-article-xface-ring-size)))
(save-excursion
(let* ((cur (current-buffer))
(data (buffer-substring beg end))
(image (cdr-safe (assoc data (ring-elements
gnus-article-xface-ring-internal))))
default-enable-multibyte-characters)
(unless image
(with-temp-buffer
(insert data)
(and (eq 0 (apply #'call-process-region (point-min) (point-max)
"uncompface"
'delete '(t nil) nil
(if gnus-article-compface-xbm
'("-X"))))
(if gnus-article-compface-xbm
t
(goto-char (point-min))
(progn (insert "/* Width=48, Height=48 */\n") t)
(eq 0 (call-process-region (point-min) (point-max)
"icontopbm"
'delete '(t nil))))
;; Miles Bader says that faces don't look right as
;; light on dark.
(if (eq 'dark (cdr-safe (assq 'background-mode
(frame-parameters))))
(setq image (create-image (buffer-string)
(if gnus-article-compface-xbm
'xbm
'pbm)
t
:ascent 'center
:foreground "black"
:background "white"))
(setq image (create-image (buffer-string)
(if gnus-article-compface-xbm
'xbm
'pbm)
t
:ascent 'center)))))
(ring-insert gnus-article-xface-ring-internal (cons data image)))
(when image
(goto-char (point-min))
(re-search-forward "^From:" nil 'move)
(while (get-text-property (point) 'display)
(goto-char (next-single-property-change (point) 'display)))
(insert-image image))))))
(defun gnus-remove-image (image &optional category)
(dolist (position (message-text-with-property 'display))
(when (and (equal (get-text-property position 'display) image)
(equal (get-text-property position 'gnus-image-category)
category))
(put-text-property position (1+ position) 'display nil)
(when (get-text-property position 'gnus-image-text-deletable)
(delete-region position (1+ position))))))
(provide 'gnus-ems)

252
lisp/gnus/gnus-fun.el Normal file
View File

@ -0,0 +1,252 @@
;;; gnus-fun.el --- various frivolous extension functions to Gnus
;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; 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 'mm-util))
(defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory)
"*Directory where X-Face PBM files are stored."
:group 'gnus-fun
:type 'directory)
(defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface"
"Command for converting a PBM to an X-Face."
:group 'gnus-fun
:type 'string)
(defcustom gnus-convert-image-to-x-face-command "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface"
"Command for converting an image to an X-Face.
By default it takes a GIF filename and output the X-Face header data
on stdout."
:group 'gnus-fun
:type 'string)
(defcustom gnus-convert-image-to-face-command "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng"
"Command for converting an image to an Face.
By default it takes a JPEG filename and output the Face header data
on stdout."
:group 'gnus-fun
:type 'string)
(defun gnus-shell-command-to-string (command)
"Like `shell-command-to-string' except not mingling ERROR."
(with-output-to-string
(call-process shell-file-name nil (list standard-output nil)
nil shell-command-switch command)))
(defun gnus-shell-command-on-region (start end command)
"A simplified `shell-command-on-region'.
Output to the current buffer, replace text, and don't mingle error."
(call-process-region start end shell-file-name t
(list (current-buffer) nil)
nil shell-command-switch command))
;;;###autoload
(defun gnus-random-x-face ()
"Return X-Face header data chosen randomly from `gnus-x-face-directory'."
(interactive)
(when (file-exists-p gnus-x-face-directory)
(let* ((files (directory-files gnus-x-face-directory t "\\.pbm$"))
(file (nth (random (length files)) files)))
(when file
(gnus-shell-command-to-string
(format gnus-convert-pbm-to-x-face-command
(shell-quote-argument file)))))))
;;;###autoload
(defun gnus-insert-random-x-face-header ()
"Insert a random X-Face header from `gnus-x-face-directory'."
(interactive)
(let ((data (gnus-random-x-face)))
(save-excursion
(message-goto-eoh)
(if data
(insert "X-Face: " data)
(message
"No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?"
gnus-x-face-directory)))))
;;;###autoload
(defun gnus-x-face-from-file (file)
"Insert an X-Face header based on an image file."
(interactive "fImage file name (by default GIF): ")
(when (file-exists-p file)
(gnus-shell-command-to-string
(format gnus-convert-image-to-x-face-command
(shell-quote-argument (expand-file-name file))))))
;;;###autoload
(defun gnus-face-from-file (file)
"Return an Face header based on an image file."
(interactive "fImage file name (by default JPEG): ")
(when (file-exists-p file)
(let ((done nil)
(attempt "")
(quant 16))
(while (and (not done)
(> quant 1))
(setq attempt
(let ((coding-system-for-read 'binary))
(gnus-shell-command-to-string
(format gnus-convert-image-to-face-command
(shell-quote-argument (expand-file-name file))
quant))))
(if (> (length attempt) 726)
(progn
(setq quant (- quant 2))
(gnus-message 9 "Length %d; trying quant %d"
(length attempt) quant))
(setq done t)))
(if done
(mm-with-unibyte-buffer
(insert attempt)
(gnus-face-encode))
nil))))
(defun gnus-face-encode ()
(let ((step 72))
(base64-encode-region (point-min) (point-max))
(goto-char (point-min))
(while (search-forward "\n" nil t)
(replace-match ""))
(goto-char (point-min))
(while (> (- (point-max) (point))
step)
(forward-char step)
(insert "\n ")
(setq step 76))
(buffer-string)))
;;;###autoload
(defun gnus-convert-face-to-png (face)
"Convert FACE (which is base64-encoded) to a PNG.
The PNG is returned as a string."
(mm-with-unibyte-buffer
(insert face)
(ignore-errors
(base64-decode-region (point-min) (point-max)))
(buffer-string)))
;;;###autoload
(defun gnus-convert-png-to-face (file)
"Convert FILE to a Face.
FILE should be a PNG file that's 48x48 and smaller than or equal to
726 bytes."
(mm-with-unibyte-buffer
(insert-file-contents file)
(when (> (buffer-size) 726)
(error "The file is %d bytes long, which is too long"
(buffer-size)))
(gnus-face-encode)))
(defface gnus-x-face '((t (:foreground "black" :background "white")))
"Face to show X-Face.
The colors from this face are used as the foreground and background
colors of the displayed X-Faces."
:group 'gnus-article-headers)
(defun gnus-display-x-face-in-from (data)
"Display the X-Face DATA in the From header."
(let ((default-enable-multibyte-characters nil)
pbm)
(when (or (gnus-image-type-available-p 'xface)
(and (gnus-image-type-available-p 'pbm)
(setq pbm (uncompface data))))
(save-excursion
(save-restriction
(article-narrow-to-head)
(gnus-article-goto-header "from")
(when (bobp)
(insert "From: [no `from' set]\n")
(forward-char -17))
(gnus-add-image
'xface
(gnus-put-image
(if (gnus-image-type-available-p 'xface)
(gnus-create-image
(concat "X-Face: " data)
'xface t :face 'gnus-x-face)
(gnus-create-image
pbm 'pbm t :face 'gnus-x-face)) nil 'xface))
(gnus-add-wash-type 'xface))))))
(defun gnus-grab-cam-x-face ()
"Grab a picture off the camera and make it into an X-Face."
(interactive)
(shell-command "xawtv-remote snap ppm")
(let ((file nil))
(while (null (setq file (directory-files "/tftpboot/sparky/tmp"
t "snap.*ppm")))
(sleep-for 1))
(setq file (car file))
(with-temp-buffer
(shell-command
(format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | pnmscale -width 48 | ppmtopgm | pgmtopbm -threshold -value 0.92 | pbmtoxbm | compface"
file)
(current-buffer))
;;(sleep-for 3)
(delete-file file)
(buffer-string))))
(defun gnus-grab-cam-face ()
"Grab a picture off the camera and make it into an X-Face."
(interactive)
(shell-command "xawtv-remote snap ppm")
(let ((file nil)
result)
(while (null (setq file (directory-files "/tftpboot/sparky/tmp"
t "snap.*ppm")))
(sleep-for 1))
(setq file (car file))
(shell-command
(format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm > /tmp/gnus.face.ppm"
file))
(let ((gnus-convert-image-to-face-command
(format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng"
(gnus-fun-ppm-change-string))))
(setq result (gnus-face-from-file "/tmp/gnus.face.ppm")))
(delete-file file)
;;(delete-file "/tmp/gnus.face.ppm")
result))
(defun gnus-fun-ppm-change-string ()
(let* ((possibilites '("%02x0000" "00%02x00" "0000%02x"
"%02x%02x00" "00%02x%02x" "%02x00%02x"))
(format (concat "'#%02x%02x%02x' '#"
(nth (random 6) possibilites)
"'"))
(values nil))
(dotimes (i 255)
(push (format format i i i i i i)
values))
(mapconcat 'identity values " ")))
(provide 'gnus-fun)
;;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1
;;; gnus-fun.el ends here

28
lisp/gnus/gnus-gl.el
View File

@ -1,6 +1,6 @@
;;; gnus-gl.el --- an interface to GroupLens for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Brad Miller <bmiller@cs.umn.edu>
@ -131,7 +131,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar gnus-summary-grouplens-line-format
"%U\%R\%z%l%I\%(%[%4L: %-20,20n%]%) %s\n"
"%U\%R\%z%l%I\%(%[%4L: %-23,23n%]%) %s\n"
"*The line format spec in summary GroupLens mode buffers.")
(defvar grouplens-pseudonym ""
@ -342,7 +342,7 @@ If this times out we give up and assume that something has died..." )
(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.
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
@ -510,11 +510,11 @@ recommend using both scores and grouplens predictions together."
;; 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)))
(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 ?|)
@ -632,10 +632,10 @@ recommend using both scores and grouplens predictions together."
(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)))
(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"))
@ -810,9 +810,9 @@ If prefix argument ALL is non-nil, all articles are marked as read."
(if (null arg) (not gnus-grouplens-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-grouplens-mode
(make-local-hook 'gnus-select-article-hook)
(gnus-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)
(gnus-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)

1528
lisp/gnus/gnus-group.el
View File

File diff suppressed because it is too large Load Diff

227
lisp/gnus/gnus-int.el
View File

@ -1,5 +1,5 @@
;;; gnus-int.el --- backend interface functions for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -29,12 +29,31 @@
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'message)
(require 'gnus-range)
(autoload 'gnus-agent-expire "gnus-agent")
(autoload 'gnus-agent-read-servers-validate-native "gnus-agent")
(defcustom gnus-open-server-hook nil
"Hook called just before opening connection to the news server."
:group 'gnus-start
:type 'hook)
(defcustom gnus-server-unopen-status nil
"The default status if the server is not able to open.
If the server is covered by Gnus agent, the possible values are
`denied', set the server denied; `offline', set the server offline;
nil, ask user. If the server is not covered by Gnus agent, set the
server denied."
:group 'gnus-start
:type '(choice (const :tag "Ask" nil)
(const :tag "Deny server" denied)
(const :tag "Unplug Agent" offline)))
(defvar gnus-internal-registry-spool-current-method nil
"The current method, for the registry.")
;;;
;;; Server Communication
;;;
@ -87,6 +106,18 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server."
(require 'nntp)))
(setq gnus-current-select-method gnus-select-method)
(gnus-run-hooks 'gnus-open-server-hook)
;; Partially validate agent covered methods now that the
;; gnus-select-method is known.
(if gnus-agent
;; NOTE: This is here for one purpose only. By validating
;; the current select method, it converts the old 5.10.3,
;; and earlier, format to the current format. That enables
;; the agent code within gnus-open-server to function
;; correctly.
(gnus-agent-read-servers-validate-native gnus-select-method))
(or
;; gnus-open-server-hook might have opened it
(gnus-server-opened gnus-select-method)
@ -110,7 +141,8 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server."
"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)))
(let ((method (or method gnus-select-method))
result)
;; Transform virtual server names into select methods.
(when (stringp method)
(setq method (gnus-server-to-method method)))
@ -124,9 +156,15 @@ If it is down, start it up (again)."
(format " on %s" (nth 1 method)))))
(gnus-run-hooks 'gnus-open-server-hook)
(prog1
(gnus-open-server method)
(condition-case ()
(setq result (gnus-open-server method))
(quit (message "Quit gnus-check-server")
nil))
(unless silent
(message ""))))))
(gnus-message 5 "Opening %s server%s...%s" (car method)
(if (equal (nth 1 method) "") ""
(format " on %s" (nth 1 method)))
(if result "done" "failed")))))))
(defun gnus-get-function (method function &optional noerror)
"Return a function symbol based on METHOD and FUNCTION."
@ -175,18 +213,66 @@ If it is down, start it up (again)."
(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))))
(let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
(result
(condition-case err
(funcall open-server-function
(nth 1 gnus-command-method)
(nthcdr 2 gnus-command-method))
(error
(gnus-message 1 (format
"Unable to open server due to: %s"
(error-message-string err)))
nil)
(quit
(gnus-message 1 "Quit trying to open server")
nil)))
open-offline)
;; 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))))
(setcar (cdr elem)
(cond (result
(if (eq open-server-function #'nnagent-open-server)
;; The agent's backend has a "special" status
'offline
'ok))
((and gnus-agent
(gnus-agent-method-p gnus-command-method))
(cond (gnus-server-unopen-status
;; Set the server's status to the unopen
;; status. If that status is offline,
;; recurse to open the agent's backend.
(setq open-offline (eq gnus-server-unopen-status 'offline))
gnus-server-unopen-status)
((gnus-y-or-n-p
(format "Unable to open %s:%s, go offline? "
(car gnus-command-method)
(cadr gnus-command-method)))
(setq open-offline t)
'offline)
(t
;; This agentized server was still denied
'denied)))
(t
;; This unagentized server must be denied
'denied)))
;; NOTE: I MUST set the server's status to offline before this
;; recursive call as this status will drive the
;; gnus-get-function (called above) to return the agent's
;; backend.
(if open-offline
;; Recursively open this offline server to perform the
;; open-server function of the agent's backend.
(let ((gnus-server-unopen-status 'denied))
;; Bind gnus-server-unopen-status to avoid recursively
;; prompting with "go offline?". This is only a concern
;; when the agent's backend fails to open the server.
(gnus-open-server gnus-command-method))
result)))))
(defun gnus-close-server (gnus-command-method)
"Close the connection to GNUS-COMMAND-METHOD."
@ -228,8 +314,8 @@ If it is down, start it up (again)."
(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."
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)
@ -289,11 +375,16 @@ this group uses will be queried."
"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)
(cond
((and gnus-use-cache (numberp (car articles)))
(gnus-cache-retrieve-headers articles group fetch-old))
((and gnus-agent (gnus-online gnus-command-method)
(gnus-agent-method-p gnus-command-method))
(gnus-agent-retrieve-headers articles group fetch-old))
(t
(funcall (gnus-get-function gnus-command-method 'retrieve-headers)
articles (gnus-group-real-name group)
(nth 1 gnus-command-method) fetch-old))))
(nth 1 gnus-command-method) fetch-old)))))
(defun gnus-retrieve-articles (articles group)
"Request ARTICLES in GROUP."
@ -319,7 +410,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
(gnus-group-real-name group) article))))
(defun gnus-request-set-mark (group action)
"Set marks on articles in the backend."
"Set marks on articles in the back end."
(let ((gnus-command-method (gnus-find-method-for-group group)))
(if (not (gnus-check-backend-function
'request-set-mark (car gnus-command-method)))
@ -329,7 +420,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
(nth 1 gnus-command-method)))))
(defun gnus-request-update-mark (group article mark)
"Allow the backend to change the mark the user tries to put on an article."
"Allow the back end to change the mark the user tries to put on an article."
(let ((gnus-command-method (gnus-find-method-for-group group)))
(if (not (gnus-check-backend-function
'request-update-mark (car gnus-command-method)))
@ -358,6 +449,10 @@ If BUFFER, insert the article in that group."
(gnus-cache-request-article article group))
(setq res (cons group article)
clean-up t))
;; Check the agent cache.
((gnus-agent-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)
@ -387,6 +482,10 @@ If BUFFER, insert the article in that group."
(gnus-cache-request-article article group))
(setq res (cons group article)
clean-up t))
;; Check the agent cache.
((gnus-agent-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)
@ -418,9 +517,11 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(gnus-inhibit-demon t)
(mail-source-plugged gnus-plugged))
(if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method)))
(funcall (gnus-get-function gnus-command-method 'request-scan)
(and group (gnus-group-real-name group))
(nth 1 gnus-command-method)))))
(progn
(setq gnus-internal-registry-spool-current-method gnus-command-method)
(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."
@ -428,23 +529,49 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(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))))
(let ((group (gnus-info-group info)))
(and (funcall (gnus-get-function gnus-command-method
'request-update-info)
(gnus-group-real-name group)
info (nth 1 gnus-command-method))
;; If the minimum article number is greater than 1, then all
;; smaller article numbers are known not to exist; we'll
;; artificially add those to the 'read range.
(let* ((active (gnus-active group))
(min (car active)))
(when (> min 1)
(let* ((range (if (= min 2) 1 (cons 1 (1- min))))
(read (gnus-info-read info))
(new-read (gnus-range-add read (list range))))
(gnus-info-set-read info new-read)))
info)))))
(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)))
(let* ((gnus-command-method (gnus-find-method-for-group group))
(not-deleted
(funcall
(gnus-get-function gnus-command-method 'request-expire-articles)
articles (gnus-group-real-name group) (nth 1 gnus-command-method)
force)))
(when (and gnus-agent
(gnus-agent-method-p gnus-command-method))
(let ((expired-articles (gnus-sorted-difference articles not-deleted)))
(when expired-articles
(gnus-agent-expire expired-articles group 'force))))
not-deleted))
(defun gnus-request-move-article (article group server accept-function
&optional last)
(let* ((gnus-command-method (gnus-find-method-for-group group))
(result (funcall (gnus-get-function gnus-command-method
'request-move-article)
article (gnus-group-real-name group)
(nth 1 gnus-command-method) accept-function last)))
(when (and result gnus-agent
(gnus-agent-method-p gnus-command-method))
(gnus-agent-expire (list article) group 'force))
result))
(defun gnus-request-accept-article (group &optional gnus-command-method last
no-encode)
;; Make sure there's a newline at the end of the article.
@ -457,25 +584,29 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(unless (bolp)
(insert "\n"))
(unless no-encode
(save-restriction
(message-narrow-to-head)
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body))
(let ((func (car (or gnus-command-method
(gnus-find-method-for-group group)))))
(funcall (intern (format "%s-request-accept-article" func))
(let ((message-options message-options))
(message-options-set-recipient)
(save-restriction
(message-narrow-to-head)
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body)))
(let ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group))))
(funcall (gnus-get-function gnus-command-method 'request-accept-article)
(if (stringp group) (gnus-group-real-name group) group)
(cadr gnus-command-method)
last)))
(defun gnus-request-replace-article (article group buffer &optional no-encode)
(unless no-encode
(save-restriction
(message-narrow-to-head)
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body))
(let ((message-options message-options))
(message-options-set-recipient)
(save-restriction
(message-narrow-to-head)
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body)))
(let ((func (car (gnus-group-name-to-method group))))
(funcall (intern (format "%s-request-replace-article" func))
article (gnus-group-real-name group) buffer)))

60
lisp/gnus/gnus-kill.el
View File

@ -1,5 +1,5 @@
;;; gnus-kill.el --- kill commands for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003
;; Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@ -357,16 +357,16 @@ If NEWSGROUP is nil, return the global kill file instead."
(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))
;; 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)))
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.
@ -398,7 +398,7 @@ Returns the number of articles marked as read."
gnus-newsgroup-kill-headers))
(setq headers (cdr headers))))
(setq files nil))
(setq files (cdr files)))))
(setq files (cdr files)))))
(if (not gnus-newsgroup-kill-headers)
()
(save-window-excursion
@ -428,16 +428,6 @@ Returns the number of articles marked as read."
0))))
;; Parse a Gnus killfile.
(defun gnus-score-insert-help (string alist idx)
(save-excursion
(pop-to-buffer "*Score Help*")
(buffer-disable-undo)
(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)
@ -588,7 +578,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(insert "\n t"))
(insert ")")
(prog1
(buffer-substring (point-min) (point-max))
(buffer-string)
(kill-buffer (current-buffer))))))
(defun gnus-execute-1 (function regexp form header)
@ -608,7 +598,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(setq did-kill (string-match regexp value)))
(cond ((stringp form) ;Keyboard macro.
(execute-kbd-macro form))
((gnus-functionp form)
((functionp form)
(funcall form))
(t
(eval form)))))
@ -627,7 +617,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
(setq did-kill (re-search-forward regexp nil t)))
(cond ((stringp form) ;Keyboard macro.
(execute-kbd-macro form))
((gnus-functionp form)
((functionp form)
(funcall form))
(t
(eval form)))))))
@ -641,18 +631,30 @@ 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)
function article header extras)
(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))))
((cond ((fboundp
(setq function
(intern-soft
(concat "mail-header-" (downcase field)))))
(setq function `(lambda (h) (,function h))))
((when (setq extras
(member (downcase field)
(mapcar (lambda (header)
(downcase (symbol-name header)))
gnus-extra-headers)))
(setq function
`(lambda (h)
(gnus-extra-header
(quote ,(nth (- (length gnus-extra-headers)
(length extras))
gnus-extra-headers))
h)))))))
;; Signal error.
(t
(error "Unknown header field: \"%s\"" field)))

42
lisp/gnus/gnus-logic.el
View File

@ -1,5 +1,5 @@
;;; gnus-logic.el --- advanced scoring code for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -59,24 +59,25 @@
(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.
(let (new-score score multiple)
(dolist (gnus-advanced-headers gnus-newsgroup-headers)
(when (setq multiple (gnus-advanced-score-rule (car rule)))
(setq new-score (or (nth 1 rule)
gnus-score-interactive-default-score))
(when (numberp multiple)
(setq new-score (* multiple new-score)))
;; 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)))
(+ (cdr score) new-score))
(push (cons (mail-header-number gnus-advanced-headers)
(or (nth 1 rule)
gnus-score-interactive-default-score))
new-score)
gnus-newsgroup-scored)
(when trace
(push (cons "A file" rule)
;; Must be synced with `gnus-score-edit-file-at-point'.
gnus-score-trace)))))))
(defun gnus-advanced-score-rule (rule)
@ -116,7 +117,7 @@
;; 1- type redirection.
(string-to-number
(substring (symbol-name type)
(match-beginning 0) (match-end 0)))
(match-beginning 1) (match-end 1)))
;; ^^^ type redirection.
(length (symbol-name type))))))
(when gnus-advanced-headers
@ -129,9 +130,8 @@
(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.
;; `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)
@ -162,7 +162,7 @@
(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))))
(funcall type (or (aref gnus-advanced-headers index) 0) match)))
(defun gnus-advanced-date (index match type)
(let ((date (apply 'encode-time (parse-time-string
@ -189,8 +189,8 @@
'gnus-request-body)
(t 'gnus-request-article)))
ofunc article)
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire 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)
@ -201,8 +201,8 @@
(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.
;; backend didn't support partial fetching, we just narrow to
;; the relevant parts.
(when ofunc
(if (eq ofunc 'gnus-request-head)
(narrow-to-region

3
lisp/gnus/gnus-mh.el
View File

@ -40,6 +40,9 @@
(require 'gnus-msg)
(require 'gnus-sum)
(eval-when-compile
(defvar mh-lib-progs))
(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.

53
lisp/gnus/gnus-ml.el
View File

@ -1,6 +1,6 @@
;;; gnus-ml.el --- mailing list minor mode for Gnus
;;; gnus-ml.el --- Mailing list minor mode for Gnus
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
;; Author: Julien Gilles <jgilles@free.fr>
;; Keywords: news
@ -26,10 +26,6 @@
;; implement (small subset of) RFC 2369
;;; Usage:
;; (add-hook 'gnus-summary-mode-hook 'turn-on-gnus-mailing-list-mode)
;;; Code:
(require 'gnus)
@ -49,12 +45,12 @@
(setq gnus-mailing-list-mode-map (make-sparse-keymap))
(gnus-define-keys gnus-mailing-list-mode-map
"\C-nh" gnus-mailing-list-help
"\C-ns" gnus-mailing-list-subscribe
"\C-nu" gnus-mailing-list-unsubscribe
"\C-np" gnus-mailing-list-post
"\C-no" gnus-mailing-list-owner
"\C-na" gnus-mailing-list-archive
"\C-c\C-nh" gnus-mailing-list-help
"\C-c\C-ns" gnus-mailing-list-subscribe
"\C-c\C-nu" gnus-mailing-list-unsubscribe
"\C-c\C-np" gnus-mailing-list-post
"\C-c\C-no" gnus-mailing-list-owner
"\C-c\C-na" gnus-mailing-list-archive
))
(defun gnus-mailing-list-make-menu-bar ()
@ -71,9 +67,28 @@
;;;###autoload
(defun turn-on-gnus-mailing-list-mode ()
(when (gnus-group-get-parameter gnus-newsgroup-name 'to-list)
(when (gnus-group-find-parameter gnus-newsgroup-name 'to-list)
(gnus-mailing-list-mode 1)))
;;;###autoload
(defun gnus-mailing-list-insinuate (&optional force)
"Setup group parameters from List-Post header.
If FORCE is non-nil, replace the old ones."
(interactive "P")
(let ((list-post
(with-current-buffer gnus-original-article-buffer
(gnus-fetch-field "list-post"))))
(if list-post
(if (and (not force)
(gnus-group-get-parameter gnus-newsgroup-name 'to-list))
(gnus-message 1 "to-list is non-nil.")
(if (string-match "<mailto:\\([^>]*\\)>" list-post)
(setq list-post (match-string 1 list-post)))
(gnus-group-add-parameter gnus-newsgroup-name
(cons 'to-list list-post))
(gnus-mailing-list-mode 1))
(gnus-message 1 "no list-post in this message."))))
;;;###autoload
(defun gnus-mailing-list-mode (&optional arg)
"Minor mode for providing mailing-list commands.
@ -140,11 +155,15 @@
(defun gnus-mailing-list-archive ()
"Browse archive"
(interactive)
(require 'browse-url)
(let ((list-archive
(with-current-buffer gnus-original-article-buffer
(gnus-fetch-field "list-archive"))))
(cond (list-archive (gnus-mailing-list-message list-archive))
(t (gnus-message 1 "no list-owner in this group")))))
(cond (list-archive
(if (string-match "<\\(http:[^>]*\\)>" list-archive)
(browse-url (match-string 1 list-archive))
(browse-url list-archive)))
(t (gnus-message 1 "no list-archive in this group")))))
;;; Utility functions
@ -158,7 +177,7 @@
(cond
((string-match "<mailto:\\([^>]*\\)>" address)
(let ((args (match-string 1 address)))
(cond ; with param
(cond ; with param
((string-match "\\(.*\\)\\?\\(.*\\)" args)
(setq mailto (match-string 1 args))
(let ((param (match-string 2 args)))
@ -169,7 +188,7 @@
(if (string-match "to=\\([^&]*\\)" param)
(push (match-string 1 param) to))
))
(t (setq mailto args))))) ; without param
(t (setq mailto args))))) ; without param
; other case <http://... to be done.
(t nil))

43
lisp/gnus/gnus-mlspl.el
View File

@ -1,5 +1,6 @@
;;; gnus-mlspl.el --- a group params-based mail splitting mechanism
;; Copyright (C) 1998, 1999, 2000
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2004
;; Free Software Foundation, Inc.
;; Author: Alexandre Oliva <oliva@lsd.ic.unicamp.br>
@ -8,18 +9,18 @@
;; 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.
;; 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.
;; 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,
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
@ -62,7 +63,7 @@ unless overridden by any group marked as a catch-all group. Typical
uses are as simple as the name of a default mail group, but more
elaborate fancy splits may also be useful to split mail that doesn't
match any of the group-specified splitting rules. See
gnus-group-split-fancy for details."
`gnus-group-split-fancy' for details."
(interactive "P")
(setq nnmail-split-methods 'nnmail-split-fancy)
(when catch-all
@ -73,8 +74,9 @@ gnus-group-split-fancy for details."
;;;###autoload
(defun gnus-group-split-update (&optional catch-all)
"Computes nnmail-split-fancy from group params and CATCH-ALL, by
calling (gnus-group-split-fancy nil nil CATCH-ALL).
"Computes nnmail-split-fancy from group params and CATCH-ALL.
It does this by calling by calling (gnus-group-split-fancy nil
nil CATCH-ALL).
If CATCH-ALL is nil, gnus-group-split-default-catch-all-group is used
instead. This variable is set by gnus-group-split-setup."
@ -88,7 +90,7 @@ instead. This variable is set by gnus-group-split-setup."
;;;###autoload
(defun gnus-group-split ()
"Uses information from group parameters in order to split mail.
See gnus-group-split-fancy for more information.
See `gnus-group-split-fancy' for more information.
gnus-group-split is a valid value for nnmail-split-methods."
(let (nnmail-split-fancy)
@ -140,12 +142,12 @@ nnml:mail.foo:
nnml:mail.others:
\((split-spec . catch-all))
Calling (gnus-group-split-fancy nil nil \"mail.misc\") returns:
Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
\(| (& (any \"\\\\(bar@femail\\\\.com\\\\|.*@femail\\\\.com\\\\)\"
\"mail.bar\")
(any \"\\\\(foo@nowhere\\\\.gov\\\\|foo@localhost\\\\|foo-redist@home\\\\)\"
- \"bugs-foo\" - \"rambling-foo\" \"mail.foo\"))
- \"bugs-foo\" - \"rambling-foo\" \"mail.foo\"))
\"mail.others\")"
(let* ((newsrc (cdr gnus-newsrc-alist))
split)
@ -202,12 +204,9 @@ Calling (gnus-group-split-fancy nil nil \"mail.misc\") returns:
(list 'any split-regexp)
;; Generate RESTRICTs for SPLIT-EXCLUDEs.
(if (listp split-exclude)
(let ((seq split-exclude)
res)
(while seq
(push (cons '- (pop seq))
res))
(apply #'nconc (nreverse res)))
(apply #'append
(mapcar (lambda (arg) (list '- arg))
split-exclude))
(list '- split-exclude))
(list group-clean))
split)

1250
lisp/gnus/gnus-msg.el
View File

File diff suppressed because it is too large Load Diff

75
lisp/gnus/gnus-mule.el
View File

@ -1,75 +0,0 @@
;;; gnus-mule.el --- provide backward compatibility function to GNUS
;; Copyright (C) 1995, 1997, 2002 Free Software Foundation, Inc.
;; Copyright (C) 1995, 2000 Electrotechnical Laboratory, JAPAN.
;; Maintainer: FSF
;; Keywords: news, i18n
;; 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 the function `gnus-mule-add-group' for backward
;; compatibility with old version of Gnus included in Emacs 20.
;;; Code:
(require 'gnus-sum)
;;;###autoload
(defun gnus-mule-add-group (name coding-system)
"Specify that articles of news group NAME are encoded in CODING-SYSTEM.
All news groups deeper than NAME are also the target.
If CODING-SYSTEM is a cons, the car part is used and the cdr
part is ignored.
This function exists for backward compatibility with Emacs 20. It is
recommended to customize the variable `gnus-group-charset-alist'
rather than using this function."
(if (consp coding-system)
;; Ignore the cdr part because now Gnus can't use different
;; coding systems for encoding and decoding.
(setq coding-system (car coding-system)))
(let ((tail gnus-group-charset-alist)
(prev nil)
(pattern (concat "^" (regexp-quote name))))
;; Check entries of `gnus-group-charset-alist' if they match NAME.
(while (not (string-match (car (car tail)) name))
(setq prev tail tail (cdr tail)))
(if tail
;; A matching entry was found.
(if (string= pattern (car (car tail)))
;; We can modify this entry.
(setcar (cdr (car tail)) coding-system)
;; We must add a new entry before this.
(if prev
(setcdr prev (cons (list pattern coding-system)
(cdr prev)))
(setq gnus-group-charset-alist
(cons (list pattern coding-system)
gnus-group-charset-alist))))
;; We must prepend a new entry.
(setq gnus-group-charset-alist
(cons (list pattern coding-system)
gnus-group-charset-alist)))))
(provide 'gnus-mule)
;;; arch-tag: 525e6b69-85de-4dfc-9dbb-764c795d63af
;;; gnus-mule.el ends here

8
lisp/gnus/gnus-nocem.el
View File

@ -1,6 +1,8 @@
;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -58,6 +60,7 @@ This can also be a list of `(ISSUER CONDITION ...)' elements.
See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an
issuer registry."
:group 'gnus-nocem
:link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html")
:type '(repeat (choice string sexp)))
(defcustom gnus-nocem-directory
@ -294,7 +297,8 @@ valid issuer, which is much faster if you are selective about the issuers."
(while (search-forward "\t" nil t)
(cond
((not (ignore-errors
(setq group (let ((obarray gnus-active-hashtb)) (read buf)))))
(setq group (let ((obarray gnus-nocem-real-group-hashtb))
(read buf)))))
;; An error.
)
((not (symbolp group))

283
lisp/gnus/gnus-picon.el Normal file
View File

@ -0,0 +1,283 @@
;;; gnus-picon.el --- displaying pretty icons in Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; 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:
;; There are three picon types relevant to Gnus:
;;
;; Persons: person@subdomain.dom
;; users/dom/subdomain/person/face.gif
;; usenix/dom/subdomain/person/face.gif
;; misc/MISC/person/face.gif
;; Domains: subdomain.dom
;; domain/dom/subdomain/unknown/face.gif
;; Groups: comp.lang.lisp
;; news/comp/lang/lisp/unknown/face.gif
;;
;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>.
;;
;;; Code:
(require 'gnus)
(require 'custom)
(require 'gnus-art)
;;; User variables:
(defcustom gnus-picon-news-directories '("news")
"*List of directories to search for newsgroups faces."
:type '(repeat string)
:group 'gnus-picon)
(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
"*List of directories to search for user faces."
:type '(repeat string)
:group 'gnus-picon)
(defcustom gnus-picon-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 'gnus-picon)
(defcustom gnus-picon-file-types
(let ((types (list "xbm")))
(when (gnus-image-type-available-p 'gif)
(push "gif" types))
(when (gnus-image-type-available-p 'xpm)
(push "xpm" types))
types)
"*List of suffixes on picon file names to try."
:type '(repeat string)
:group 'gnus-picon)
(defface gnus-picon-xbm-face '((t (:foreground "black" :background "white")))
"Face to show xbm picon in."
:group 'gnus-picon)
(defface gnus-picon-face '((t (:foreground "black" :background "white")))
"Face to show picon in."
:group 'gnus-picon)
;;; Internal variables:
(defvar gnus-picon-setup-p nil)
(defvar gnus-picon-glyph-alist nil
"Picon glyphs cache.
List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
(defvar gnus-picon-cache nil)
;;; Functions:
(defsubst gnus-picon-split-address (address)
(setq address (split-string address "@"))
(if (stringp (cadr address))
(cons (car address) (split-string (cadr address) "\\."))
(if (stringp (car address))
(split-string (car address) "\\."))))
(defun gnus-picon-find-face (address directories &optional exact)
(let* ((address (gnus-picon-split-address address))
(user (pop address))
(faddress address)
database directory result instance base)
(catch 'found
(dolist (database gnus-picon-databases)
(dolist (directory directories)
(setq address faddress
base (expand-file-name directory database))
(while address
(when (setq result (gnus-picon-find-image
(concat base "/" (mapconcat 'downcase
(reverse address)
"/")
"/" (downcase user) "/")))
(throw 'found result))
(if exact
(setq address nil)
(pop address)))
;; Kludge to search MISC as well. But not in "news".
(unless (string= directory "news")
(when (setq result (gnus-picon-find-image
(concat base "/MISC/" user "/")))
(throw 'found result))))))))
(defun gnus-picon-find-image (directory)
(let ((types gnus-picon-file-types)
found type file)
(while (and (not found)
(setq type (pop types)))
(setq found (file-exists-p (setq file (concat directory "face." type)))))
(if found
file
nil)))
(defun gnus-picon-insert-glyph (glyph category)
"Insert GLYPH into the buffer.
GLYPH can be either a glyph or a string."
(if (stringp glyph)
(insert glyph)
(gnus-add-wash-type category)
(gnus-add-image category (car glyph))
(gnus-put-image (car glyph) (cdr glyph) category)))
(defun gnus-picon-create-glyph (file)
(or (cdr (assoc file gnus-picon-glyph-alist))
(cdar (push (cons file (gnus-create-image file))
gnus-picon-glyph-alist))))
;;; Functions that does picon transformations:
(defun gnus-picon-transform-address (header category)
(gnus-with-article-headers
(let ((addresses
(mail-header-parse-addresses
;; mail-header-parse-addresses does not work (reliably) on
;; decoded headers.
(or
(ignore-errors
(mail-encode-encoded-word-string
(or (mail-fetch-field header) "")))
(mail-fetch-field header))))
spec file point cache)
(dolist (address addresses)
(setq address (car address))
(when (and (stringp address)
(setq spec (gnus-picon-split-address address)))
(if (setq cache (cdr (assoc address gnus-picon-cache)))
(setq spec cache)
(when (setq file (or (gnus-picon-find-face
address gnus-picon-user-directories)
(gnus-picon-find-face
(concat "unknown@"
(mapconcat
'identity (cdr spec) "."))
gnus-picon-user-directories)))
(setcar spec (cons (gnus-picon-create-glyph file)
(car spec))))
(dotimes (i (1- (length spec)))
(when (setq file (gnus-picon-find-face
(concat "unknown@"
(mapconcat
'identity (nthcdr (1+ i) spec) "."))
gnus-picon-domain-directories t))
(setcar (nthcdr (1+ i) spec)
(cons (gnus-picon-create-glyph file)
(nth (1+ i) spec)))))
(setq spec (nreverse spec))
(push (cons address spec) gnus-picon-cache))
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
(when (search-forward address nil t)
(delete-region (match-beginning 0) (match-end 0))
(setq point (point))
(while spec
(goto-char point)
(if (> (length spec) 2)
(insert ".")
(if (= (length spec) 2)
(insert "@")))
(gnus-picon-insert-glyph (pop spec) category))))))))
(defun gnus-picon-transform-newsgroups (header)
(interactive)
(gnus-with-article-headers
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
(let ((groups (message-tokenize-header (mail-fetch-field header)))
spec file point)
(dolist (group groups)
(unless (setq spec (cdr (assoc group gnus-picon-cache)))
(setq spec (nreverse (split-string group "[.]")))
(dotimes (i (length spec))
(when (setq file (gnus-picon-find-face
(concat "unknown@"
(mapconcat
'identity (nthcdr i spec) "."))
gnus-picon-news-directories t))
(setcar (nthcdr i spec)
(cons (gnus-picon-create-glyph file)
(nth i spec)))))
(push (cons group spec) gnus-picon-cache))
(when (search-forward group nil t)
(delete-region (match-beginning 0) (match-end 0))
(save-restriction
(narrow-to-region (point) (point))
(while spec
(goto-char (point-min))
(if (> (length spec) 1)
(insert "."))
(gnus-picon-insert-glyph (pop spec) 'newsgroups-picon))
(goto-char (point-max))))))))
;;; Commands:
;; #### NOTE: the test for buffer-read-only is the same as in
;; article-display-[x-]face. See the comment up there.
;;;###autoload
(defun gnus-treat-from-picon ()
"Display picons in the From header.
If picons are already displayed, remove them."
(interactive)
(let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
(if (and wash-picon-p (memq 'from-picon gnus-article-wash-types))
(gnus-delete-images 'from-picon)
(gnus-picon-transform-address "from" 'from-picon)))
))
;;;###autoload
(defun gnus-treat-mail-picon ()
"Display picons in the Cc and To headers.
If picons are already displayed, remove them."
(interactive)
(let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
(if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types))
(gnus-delete-images 'mail-picon)
(gnus-picon-transform-address "cc" 'mail-picon)
(gnus-picon-transform-address "to" 'mail-picon)))
))
;;;###autoload
(defun gnus-treat-newsgroups-picon ()
"Display picons in the Newsgroups and Followup-To headers.
If picons are already displayed, remove them."
(interactive)
(let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
(if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types))
(gnus-delete-images 'newsgroups-picon)
(gnus-picon-transform-newsgroups "newsgroups")
(gnus-picon-transform-newsgroups "followup-to")))
))
(provide 'gnus-picon)
;;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f
;;; gnus-picon.el ends here

5
etc/gnus-pointer.xbm → lisp/gnus/gnus-pointer.xbm
View File

@ -1,7 +1,6 @@
#define noname_width 18
#define noname_height 12
#define noname_height 13
static char noname_bits[] = {
0xc0,0x0c,0x00,0xe0,0x1f,0x00,0x92,0x39,0x00,0x0e,0x71,0x02,
0x00,0x00,0x00,0xc0,0x0c,0x00,0xe0,0x1f,0x00,0x92,0x39,0x00,0x0e,0x71,0x02,
0x46,0xe0,0x03,0x20,0xc0,0x01,0x00,0x08,0x00,0x10,0x0d,0x00,0xc4,0x08,0x00,
0x78,0x08,0x00,0x18,0x89,0x00,0x00,0x08,0x00};

3
etc/gnus-pointer.xpm → lisp/gnus/gnus-pointer.xpm
View File

@ -1,11 +1,12 @@
/* XPM */
static char *gnus-pointer[] = {
/* width height num_colors chars_per_pixel */
" 18 12 2 1",
" 18 13 2 1",
/* colors */
". c #0000ff",
"# c None s None",
/* pixels */
"##################",
"######..##..######",
"#####........#####",
"#.##.##..##...####",

214
lisp/gnus/gnus-range.el
View File

@ -1,6 +1,7 @@
;;; gnus-range.el --- range and sequence functions for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -30,6 +31,11 @@
;;; List and range functions
(defsubst gnus-range-normalize (range)
"Normalize RANGE.
If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
(if (listp (cdr-safe range)) range (list range)))
(defun gnus-last-element (list)
"Return last element of LIST."
(while (cdr list)
@ -55,6 +61,85 @@
(setq list2 (cdr list2)))
list1))
(defun gnus-range-difference (range1 range2)
"Return the range of elements in RANGE1 that do not appear in RANGE2.
Both ranges must be in ascending order."
(setq range1 (gnus-range-normalize range1))
(setq range2 (gnus-range-normalize range2))
(let* ((new-range (cons nil (copy-sequence range1)))
(r new-range)
(safe t))
(while (cdr r)
(let* ((r1 (cadr r))
(r2 (car range2))
(min1 (if (numberp r1) r1 (car r1)))
(max1 (if (numberp r1) r1 (cdr r1)))
(min2 (if (numberp r2) r2 (car r2)))
(max2 (if (numberp r2) r2 (cdr r2))))
(cond ((> min1 max1)
;; Invalid range: may result from overlap condition (below)
;; remove Invalid range
(setcdr r (cddr r)))
((and (= min1 max1)
(listp r1))
;; Inefficient representation: may result from overlap condition (below)
(setcar (cdr r) min1))
((not min2)
;; All done with range2
(setq r nil))
((< max1 min2)
;; No overlap: range1 preceeds range2
(pop r))
((< max2 min1)
;; No overlap: range2 preceeds range1
(pop range2))
((and (<= min2 min1) (<= max1 max2))
;; Complete overlap: range1 removed
(setcdr r (cddr r)))
(t
(setcdr r (nconc (list (cons min1 (1- min2)) (cons (1+ max2) max1)) (cddr r)))))))
(cdr new-range)))
;;;###autoload
(defun gnus-sorted-difference (list1 list2)
"Return a list of elements of LIST1 that do not appear in LIST2.
Both lists have to be sorted over <.
The tail of LIST1 is not copied."
(let (out)
(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 list2 (cdr list2)))))
(nconc (nreverse out) list1)))
;;;###autoload
(defun gnus-sorted-ndifference (list1 list2)
"Return a list of elements of LIST1 that do not appear in LIST2.
Both lists have to be sorted over <.
LIST1 is modified."
(let* ((top (cons nil list1))
(prev top))
(while (and list1 list2)
(cond ((= (car list1) (car list2))
(setcdr prev (cdr list1))
(setq list1 (cdr list1)
list2 (cdr list2)))
((< (car list1) (car list2))
(setq prev list1
list1 (cdr list1)))
(t
(setq list2 (cdr list2)))))
(cdr top)))
;;;###autoload
(defun gnus-sorted-complement (list1 list2)
"Return a list of elements that are in LIST1 or LIST2 but not both.
Both lists have to be sorted over <."
@ -73,6 +158,7 @@ Both lists have to be sorted over <."
(setq list2 (cdr list2)))))
(nconc (nreverse out) (or list1 list2)))))
;;;###autoload
(defun gnus-intersection (list1 list2)
(let ((result nil))
(while list2
@ -81,8 +167,10 @@ Both lists have to be sorted over <."
(setq list2 (cdr list2)))
result))
;;;###autoload
(defun gnus-sorted-intersection (list1 list2)
;; LIST1 and LIST2 have to be sorted over <.
"Return intersection of LIST1 and LIST2.
LIST1 and LIST2 have to be sorted over <."
(let (out)
(while (and list1 list2)
(cond ((= (car list1) (car list2))
@ -95,9 +183,13 @@ Both lists have to be sorted over <."
(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.
;;;###autoload
(defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection)
;;;###autoload
(defun gnus-sorted-nintersection (list1 list2)
"Return intersection of LIST1 and LIST2 by modifying cdr pointers of LIST1.
LIST1 and LIST2 have to be sorted over <."
(let* ((top (cons nil list1))
(prev top))
(while (and list1 list2)
@ -113,6 +205,55 @@ Both lists have to be sorted over <."
(setcdr prev nil)
(cdr top)))
;;;###autoload
(defun gnus-sorted-union (list1 list2)
"Return union of LIST1 and 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 out (cons (car list1) out)
list1 (cdr list1)))
(t
(setq out (cons (car list2) out)
list2 (cdr list2)))))
(while list1
(setq out (cons (car list1) out)
list1 (cdr list1)))
(while list2
(setq out (cons (car list2) out)
list2 (cdr list2)))
(nreverse out)))
;;;###autoload
(defun gnus-sorted-nunion (list1 list2)
"Return union of LIST1 and LIST2 by modifying cdr pointers of LIST1.
LIST1 and LIST2 have to be sorted over <."
(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))
(setq prev list1
list1 (cdr list1)))
(t
(setcdr prev (list (car list2)))
(setq prev (cdr prev)
list2 (cdr list2))
(setcdr prev list1))))
(while list2
(setcdr prev (list (car list2)))
(setq prev (cdr prev)
list2 (cdr list2)))
(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
@ -319,9 +460,58 @@ modified."
(setq ranges (cdr ranges)))
(not not-stop))))
(defun gnus-list-range-intersection (list ranges)
"Return a list of numbers in LIST that are members of RANGES.
LIST is a sorted list."
(setq ranges (gnus-range-normalize ranges))
(let (number result)
(while (setq number (pop list))
(while (and ranges
(if (numberp (car ranges))
(< (car ranges) number)
(< (cdar ranges) number)))
(setq ranges (cdr ranges)))
(when (and ranges
(if (numberp (car ranges))
(= (car ranges) number)
;; (caar ranges) <= number <= (cdar ranges)
(>= number (caar ranges))))
(push number result)))
(nreverse result)))
(defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference)
(defun gnus-list-range-difference (list ranges)
"Return a list of numbers in LIST that are not members of RANGES.
LIST is a sorted list."
(setq ranges (gnus-range-normalize ranges))
(let (number result)
(while (setq number (pop list))
(while (and ranges
(if (numberp (car ranges))
(< (car ranges) number)
(< (cdar ranges) number)))
(setq ranges (cdr ranges)))
(when (or (not ranges)
(if (numberp (car ranges))
(not (= (car ranges) number))
;; not ((caar ranges) <= number <= (cdar ranges))
(< number (caar ranges))))
(push number result)))
(nreverse result)))
(defun gnus-range-length (range)
"Return the length RANGE would have if uncompressed."
(length (gnus-uncompress-range range)))
(cond
((null range)
0)
((not (listp (cdr range)))
(- (cdr range) (car range) -1))
(t
(let ((sum 0))
(dolist (x range sum)
(setq sum
(+ sum (if (consp x) (- (cdr x) (car x) -1) 1))))))))
(defun gnus-sublist-p (list sublist)
"Test whether all elements in SUBLIST are members of LIST."
@ -387,6 +577,18 @@ modified."
(if item (push item range))
(reverse range)))
;;;###autoload
(defun gnus-add-to-sorted-list (list num)
"Add NUM into sorted LIST by side effect."
(let* ((top (cons nil list))
(prev top))
(while (and list (< (car list) num))
(setq prev list
list (cdr list)))
(unless (eq (car list) num)
(setcdr prev (cons num list)))
(cdr top)))
(provide 'gnus-range)
;;; arch-tag: 4780bdd8-5a15-4aff-be28-18727895b6ad

703
lisp/gnus/gnus-registry.el Normal file
View File

@ -0,0 +1,703 @@
;;; gnus-registry.el --- article registry for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; 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 is the gnus-registry.el package, works with other backends
;; besides nnmail. The major issue is that it doesn't go across
;; backends, so for instance if an article is in nnml:sys and you see
;; a reference to it in nnimap splitting, the article will end up in
;; nnimap:sys
;; gnus-registry.el intercepts article respooling, moving, deleting,
;; and copying for all backends. If it doesn't work correctly for
;; you, submit a bug report and I'll be glad to fix it. It needs
;; documentation in the manual (also on my to-do list).
;; Put this in your startup file (~/.gnus.el for instance)
;; (setq gnus-registry-max-entries 2500
;; gnus-registry-use-long-group-names t)
;; (gnus-registry-initialize)
;; Then use this in your fancy-split:
;; (: gnus-registry-split-fancy-with-parent)
;; TODO:
;; - get the correct group on spool actions
;; - articles that are spooled to a different backend should be handled
;;; Code:
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-int)
(require 'gnus-sum)
(require 'nnmail)
(defvar gnus-registry-dirty t
"Boolean set to t when the registry is modified")
(defgroup gnus-registry nil
"The Gnus registry."
:group 'gnus)
(defvar gnus-registry-hashtb nil
"*The article registry by Message ID.")
(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
"List of groups that gnus-registry-split-fancy-with-parent won't follow.
The group names are matched, they don't have to be fully qualified."
:group 'gnus-registry
:type '(repeat string))
(defcustom gnus-registry-install nil
"Whether the registry should be installed."
:group 'gnus-registry
:type 'boolean)
(defcustom gnus-registry-clean-empty t
"Whether the empty registry entries should be deleted.
Registry entries are considered empty when they have no groups."
:group 'gnus-registry
:type 'boolean)
(defcustom gnus-registry-use-long-group-names nil
"Whether the registry should use long group names (BUGGY)."
:group 'gnus-registry
:type 'boolean)
(defcustom gnus-registry-track-extra nil
"Whether the registry should track extra data about a message.
The Subject and Sender (From:) headers are currently tracked this
way."
:group 'gnus-registry
:type
'(set :tag "Tracking choices"
(const :tag "Track by subject (Subject: header)" subject)
(const :tag "Track by sender (From: header)" sender)))
(defcustom gnus-registry-entry-caching t
"Whether the registry should cache extra information."
:group 'gnus-registry
:type 'boolean)
(defcustom gnus-registry-minimum-subject-length 5
"The minimum length of a subject before it's considered trackable."
:group 'gnus-registry
:type 'integer)
(defcustom gnus-registry-trim-articles-without-groups t
"Whether the registry should clean out message IDs without groups."
:group 'gnus-registry
:type 'boolean)
(defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
"File where the Gnus registry will be stored."
:group 'gnus-registry
:type 'file)
(defcustom gnus-registry-max-entries nil
"Maximum number of entries in the registry, nil for unlimited."
:group 'gnus-registry
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum number: %v\n" :size 0)))
;; Function(s) missing in Emacs 20
(when (memq nil (mapcar 'fboundp '(puthash)))
(require 'cl)
(unless (fboundp 'puthash)
;; alias puthash is missing from Emacs 20 cl-extra.el
(defalias 'puthash 'cl-puthash)))
(defun gnus-registry-track-subject-p ()
(memq 'subject gnus-registry-track-extra))
(defun gnus-registry-track-sender-p ()
(memq 'sender gnus-registry-track-extra))
(defun gnus-registry-cache-read ()
"Read the registry cache file."
(interactive)
(let ((file gnus-registry-cache-file))
(when (file-exists-p file)
(gnus-message 5 "Reading %s..." file)
(gnus-load file)
(gnus-message 5 "Reading %s...done" file))))
(defun gnus-registry-cache-save ()
"Save the registry cache file."
(interactive)
(let ((file gnus-registry-cache-file))
(save-excursion
(set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
(make-local-variable 'version-control)
(setq version-control gnus-backup-startup-file)
(setq buffer-file-name file)
(setq default-directory (file-name-directory buffer-file-name))
(buffer-disable-undo)
(erase-buffer)
(gnus-message 5 "Saving %s..." file)
(if gnus-save-startup-file-via-temp-buffer
(let ((coding-system-for-write gnus-ding-file-coding-system)
(standard-output (current-buffer)))
(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
(gnus-registry-cache-whitespace file)
(save-buffer))
(let ((coding-system-for-write gnus-ding-file-coding-system)
(version-control gnus-backup-startup-file)
(startup-file file)
(working-dir (file-name-directory file))
working-file
(i -1))
;; Generate the name of a non-existent file.
(while (progn (setq working-file
(format
(if (and (eq system-type 'ms-dos)
(not (gnus-long-file-names)))
"%s#%d.tm#" ; MSDOS limits files to 8+3
(if (memq system-type '(vax-vms axp-vms))
"%s$tmp$%d"
"%s#tmp#%d"))
working-dir (setq i (1+ i))))
(file-exists-p working-file)))
(unwind-protect
(progn
(gnus-with-output-to-file working-file
(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
;; These bindings will mislead the current buffer
;; into thinking that it is visiting the startup
;; file.
(let ((buffer-backed-up nil)
(buffer-file-name startup-file)
(file-precious-flag t)
(setmodes (file-modes startup-file)))
;; Backup the current version of the startup file.
(backup-buffer)
;; Replace the existing startup file with the temp file.
(rename-file working-file startup-file t)
(set-file-modes startup-file setmodes)))
(condition-case nil
(delete-file working-file)
(file-error nil)))))
(gnus-kill-buffer (current-buffer))
(gnus-message 5 "Saving %s...done" file))))
;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
;; Save the gnus-registry file with extra line breaks.
(defun gnus-registry-cache-whitespace (filename)
(gnus-message 5 "Adding whitespace to %s" filename)
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^(\\|(\\\"" nil t)
(replace-match "\n\\&" t))
(goto-char (point-min))
(while (re-search-forward " $" nil t)
(replace-match "" t t))))
(defun gnus-registry-save (&optional force)
(when (or gnus-registry-dirty force)
(let ((caching gnus-registry-entry-caching))
;; turn off entry caching, so mtime doesn't get recorded
(setq gnus-registry-entry-caching nil)
;; remove entry caches
(maphash
(lambda (key value)
(if (hash-table-p value)
(remhash key gnus-registry-hashtb)))
gnus-registry-hashtb)
;; remove empty entries
(when gnus-registry-clean-empty
(gnus-registry-clean-empty-function))
;; now trim the registry appropriately
(setq gnus-registry-alist (gnus-registry-trim
(hashtable-to-alist gnus-registry-hashtb)))
;; really save
(gnus-registry-cache-save)
(setq gnus-registry-entry-caching caching)
(setq gnus-registry-dirty nil))))
(defun gnus-registry-clean-empty-function ()
"Remove all empty entries from the registry. Returns count thereof."
(let ((count 0))
(maphash
(lambda (key value)
(unless (gnus-registry-fetch-group key)
(incf count)
(remhash key gnus-registry-hashtb)))
gnus-registry-hashtb)
count))
(defun gnus-registry-read ()
(gnus-registry-cache-read)
(setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
(setq gnus-registry-dirty nil))
(defun gnus-registry-trim (alist)
"Trim alist to size, using gnus-registry-max-entries."
(if (null gnus-registry-max-entries)
alist ; just return the alist
;; else, when given max-entries, trim the alist
(let ((timehash (make-hash-table
:size 4096
:test 'equal)))
(maphash
(lambda (key value)
(puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
gnus-registry-hashtb)
;; we use the return value of this setq, which is the trimmed alist
(setq alist
(nthcdr
(- (length alist) gnus-registry-max-entries)
(sort alist
(lambda (a b)
(time-less-p
(cdr (gethash (car a) timehash))
(cdr (gethash (car b) timehash))))))))))
(defun alist-to-hashtable (alist)
"Build a hashtable from the values in ALIST."
(let ((ht (make-hash-table
:size 4096
:test 'equal)))
(mapc
(lambda (kv-pair)
(puthash (car kv-pair) (cdr kv-pair) ht))
alist)
ht))
(defun hashtable-to-alist (hash)
"Build an alist from the values in HASH."
(let ((list nil))
(maphash
(lambda (key value)
(setq list (cons (cons key value) list)))
hash)
list))
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
(subject (gnus-registry-simplify-subject
(mail-header-subject data-header)))
(sender (mail-header-from data-header))
(from (gnus-group-guess-full-name-from-command-method from))
(to (if to (gnus-group-guess-full-name-from-command-method to) nil))
(to-name (if to to "the Bit Bucket"))
(old-entry (gethash id gnus-registry-hashtb)))
(gnus-message 5 "Registry: article %s %s from %s to %s"
id
(if method "respooling" "going")
from
to)
;; All except copy will need a delete
(gnus-registry-delete-group id from)
(when (equal 'copy action)
(gnus-registry-add-group id from subject sender)) ; undo the delete
(gnus-registry-add-group id to subject sender)))
(defun gnus-registry-spool-action (id group &optional subject sender)
(let ((group (gnus-group-guess-full-name-from-command-method group)))
(when (and (stringp id) (string-match "\r$" id))
(setq id (substring id 0 -1)))
(gnus-message 5 "Registry: article %s spooled to %s"
id
group)
(gnus-registry-add-group id group subject sender)))
;; Function for nn{mail|imap}-split-fancy: look up all references in
;; the cache and if a match is found, return that group.
(defun gnus-registry-split-fancy-with-parent ()
"Split this message into the same group as its parent. The parent
is obtained from the registry. This function can be used as an entry
in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
this: (: gnus-registry-split-fancy-with-parent)
For a message to be split, it looks for the parent message in the
References or In-Reply-To header and then looks in the registry to
see which group that message was put in. This group is returned.
See the Info node `(gnus)Fancy Mail Splitting' for more details."
(let ((refstr (or (message-fetch-field "references")
(message-fetch-field "in-reply-to")))
(nnmail-split-fancy-with-parent-ignore-groups
(if (listp nnmail-split-fancy-with-parent-ignore-groups)
nnmail-split-fancy-with-parent-ignore-groups
(list nnmail-split-fancy-with-parent-ignore-groups)))
references res)
(if refstr
(progn
(setq references (nreverse (gnus-split-references refstr)))
(mapcar (lambda (x)
(setq res (or (gnus-registry-fetch-group x) res))
(when (or (gnus-registry-grep-in-list
res
gnus-registry-unfollowed-groups)
(gnus-registry-grep-in-list
res
nnmail-split-fancy-with-parent-ignore-groups))
(setq res nil)))
references))
;; else: there were no references, now try the extra tracking
(let ((sender (message-fetch-field "from"))
(subject (gnus-registry-simplify-subject
(message-fetch-field "subject")))
(single-match t))
(when (and single-match
(gnus-registry-track-sender-p)
sender)
(maphash
(lambda (key value)
(let ((this-sender (cdr
(gnus-registry-fetch-extra key 'sender))))
(when (and single-match
this-sender
(equal sender this-sender))
;; too many matches, bail
(unless (equal res (gnus-registry-fetch-group key))
(setq single-match nil))
(setq res (gnus-registry-fetch-group key))
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
(if gnus-registry-track-extra 5 9)
"%s (extra tracking) traced sender %s to group %s"
"gnus-registry-split-fancy-with-parent"
sender
(if res res "nil")))))
gnus-registry-hashtb))
(when (and single-match
(gnus-registry-track-subject-p)
subject
(< gnus-registry-minimum-subject-length (length subject)))
(maphash
(lambda (key value)
(let ((this-subject (cdr
(gnus-registry-fetch-extra key 'subject))))
(when (and single-match
this-subject
(equal subject this-subject))
;; too many matches, bail
(unless (equal res (gnus-registry-fetch-group key))
(setq single-match nil))
(setq res (gnus-registry-fetch-group key))
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
(if gnus-registry-track-extra 5 9)
"%s (extra tracking) traced subject %s to group %s"
"gnus-registry-split-fancy-with-parent"
subject
(if res res "nil")))))
gnus-registry-hashtb))
(unless single-match
(gnus-message
5
"gnus-registry-split-fancy-with-parent: too many extra matches for %s"
refstr)
(setq res nil))))
(gnus-message
5
"gnus-registry-split-fancy-with-parent traced %s to group %s"
refstr (if res res "nil"))
(when (and res gnus-registry-use-long-group-names)
(let ((m1 (gnus-find-method-for-group res))
(m2 (or gnus-command-method
(gnus-find-method-for-group gnus-newsgroup-name)))
(short-res (gnus-group-short-name res)))
(if (gnus-methods-equal-p m1 m2)
(progn
(gnus-message
9
"gnus-registry-split-fancy-with-parent stripped group %s to %s"
res
short-res)
(setq res short-res))
;; else...
(gnus-message
5
"gnus-registry-split-fancy-with-parent ignored foreign group %s"
res)
(setq res nil))))
res))
(defun gnus-registry-register-message-ids ()
"Register the Message-ID of every article in the group"
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
(dolist (article gnus-newsgroup-articles)
(let ((id (gnus-registry-fetch-message-id-fast article)))
(unless (gnus-registry-fetch-group id)
(gnus-message 9 "Registry: Registering article %d with group %s"
article gnus-newsgroup-name)
(gnus-registry-add-group
(gnus-registry-fetch-message-id-fast article)
gnus-newsgroup-name
(gnus-registry-fetch-simplified-message-subject-fast article)
(gnus-registry-fetch-sender-fast article)))))))
(defun gnus-registry-fetch-message-id-fast (article)
"Fetch the Message-ID quickly, using the internal gnus-data-list function"
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
nil))
(defun gnus-registry-simplify-subject (subject)
(if (stringp subject)
(gnus-simplify-subject subject)
nil))
(defun gnus-registry-fetch-simplified-message-subject-fast (article)
"Fetch the Subject quickly, using the internal gnus-data-list function"
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(gnus-registry-simplify-subject
(mail-header-subject (gnus-data-header
(assoc article (gnus-data-list nil)))))
nil))
(defun gnus-registry-fetch-sender-fast (article)
"Fetch the Sender quickly, using the internal gnus-data-list function"
(if (and (numberp article)
(assoc article (gnus-data-list nil)))
(mail-header-from (gnus-data-header
(assoc article (gnus-data-list nil))))
nil))
(defun gnus-registry-grep-in-list (word list)
(when word
(memq nil
(mapcar 'not
(mapcar
(lambda (x)
(string-match x word))
list)))))
(defun gnus-registry-fetch-extra (id &optional entry)
"Get the extra data of a message, based on the message ID.
Returns the first place where the trail finds a nonstring."
(let ((entry-cache (gethash entry gnus-registry-hashtb)))
(if (and entry
(hash-table-p entry-cache)
(gethash id entry-cache))
(gethash id entry-cache)
;; else, if there is no caching possible...
(let ((trail (gethash id gnus-registry-hashtb)))
(when (listp trail)
(dolist (crumb trail)
(unless (stringp crumb)
(return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
(defun gnus-registry-fetch-extra-entry (alist &optional entry id)
"Get the extra data of a message, or a specific entry in it.
Update the entry cache if needed."
(if (and entry id)
(let ((entry-cache (gethash entry gnus-registry-hashtb))
entree)
(when gnus-registry-entry-caching
;; create the hash table
(unless (hash-table-p entry-cache)
(setq entry-cache (make-hash-table
:size 4096
:test 'equal))
(puthash entry entry-cache gnus-registry-hashtb))
;; get the entree from the hash table or from the alist
(setq entree (gethash id entry-cache)))
(unless entree
(setq entree (assq entry alist))
(when gnus-registry-entry-caching
(puthash id entree entry-cache)))
entree)
alist))
(defun gnus-registry-store-extra (id extra)
"Store the extra data of a message, based on the message ID.
The message must have at least one group name."
(when (gnus-registry-group-count id)
;; we now know the trail has at least 1 group name, so it's not empty
(let ((trail (gethash id gnus-registry-hashtb))
(old-extra (gnus-registry-fetch-extra id))
entry-cache)
(dolist (crumb trail)
(unless (stringp crumb)
(dolist (entry crumb)
(setq entry-cache (gethash (car entry) gnus-registry-hashtb))
(when entry-cache
(remhash id entry-cache))))
(puthash id (cons extra (delete old-extra trail))
gnus-registry-hashtb)
(setq gnus-registry-dirty t)))))
(defun gnus-registry-store-extra-entry (id key value)
"Put a specific entry in the extras field of the registry entry for id."
(let* ((extra (gnus-registry-fetch-extra id))
(alist (cons (cons key value)
(gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
(gnus-registry-store-extra id alist)))
(defun gnus-registry-fetch-group (id)
"Get the group of a message, based on the message ID.
Returns the first place where the trail finds a group name."
(when (gnus-registry-group-count id)
;; we now know the trail has at least 1 group name
(let ((trail (gethash id gnus-registry-hashtb)))
(dolist (crumb trail)
(when (stringp crumb)
(return (if gnus-registry-use-long-group-names
crumb
(gnus-group-short-name crumb))))))))
(defun gnus-registry-group-count (id)
"Get the number of groups of a message, based on the message ID."
(let ((trail (gethash id gnus-registry-hashtb)))
(if (and trail (listp trail))
(apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
0)))
(defun gnus-registry-delete-group (id group)
"Delete a group for a message, based on the message ID."
(when group
(when id
(let ((trail (gethash id gnus-registry-hashtb))
(group (gnus-group-short-name group)))
(puthash id (if trail
(delete group trail)
nil)
gnus-registry-hashtb))
;; now, clear the entry if there are no more groups
(when gnus-registry-trim-articles-without-groups
(unless (gnus-registry-group-count id)
(gnus-registry-delete-id id)))
(gnus-registry-store-extra-entry id 'mtime (current-time)))))
(defun gnus-registry-delete-id (id)
"Delete a message ID from the registry."
(when (stringp id)
(remhash id gnus-registry-hashtb)
(maphash
(lambda (key value)
(when (hash-table-p value)
(remhash id value)))
gnus-registry-hashtb)))
(defun gnus-registry-add-group (id group &optional subject sender)
"Add a group for a message, based on the message ID."
(when group
(when (and id
(not (string-match "totally-fudged-out-message-id" id)))
(let ((full-group group)
(group (if gnus-registry-use-long-group-names
group
(gnus-group-short-name group))))
(gnus-registry-delete-group id group)
(unless gnus-registry-use-long-group-names ;; unnecessary in this case
(gnus-registry-delete-group id full-group))
(let ((trail (gethash id gnus-registry-hashtb)))
(puthash id (if trail
(cons group trail)
(list group))
gnus-registry-hashtb)
(when (and (gnus-registry-track-subject-p)
subject)
(gnus-registry-store-extra-entry
id
'subject
(gnus-registry-simplify-subject subject)))
(when (and (gnus-registry-track-sender-p)
sender)
(gnus-registry-store-extra-entry
id
'sender
sender))
(gnus-registry-store-extra-entry id 'mtime (current-time)))))))
(defun gnus-registry-clear ()
"Clear the Gnus registry."
(interactive)
(setq gnus-registry-alist nil)
(setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
(setq gnus-registry-dirty t))
;;;###autoload
(defun gnus-registry-initialize ()
(interactive)
(setq gnus-registry-install t)
(gnus-registry-install-hooks)
(gnus-registry-read))
;;;###autoload
(defun gnus-registry-install-hooks ()
"Install the registry hooks."
(interactive)
(add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
(add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
(add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
(add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
(add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
(defun gnus-registry-unload-hook ()
"Uninstall the registry hooks."
(interactive)
(remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
(remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
(remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
(remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
(remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
(remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
(remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
(when gnus-registry-install
(gnus-registry-install-hooks)
(gnus-registry-read))
;; TODO: a lot of things
(provide 'gnus-registry)
;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
;;; gnus-registry.el ends here

195
lisp/gnus/gnus-salt.el
View File

@ -1,6 +1,7 @@
;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
;; Copyright (C) 1996, 1997, 1998, 1999, 2001
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@ -30,13 +31,15 @@
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-win)
;;;
;;; gnus-pick-mode
;;;
(defvar gnus-pick-mode nil
"Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
"Minor mode for providing a pick-and-read interface in Gnus
summary buffers.")
(defcustom gnus-pick-display-summary nil
"*Display summary while reading."
@ -48,18 +51,22 @@
:type 'hook
:group 'gnus-summary-pick)
(when (featurep 'xemacs)
(add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add))
(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' runs `gnus-summary-next-group' when no articles have been picked."
"If non-nil, `gnus-pick-start-reading' runs
`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"
"%-5P %U\%R\%z\%I\%(%[%4L: %-23,23n%]%) %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
@ -82,22 +89,22 @@ It accepts the same format specs that `gnus-summary-line-format' does."
(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-by-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-by-regexp t]
["Buffer" gnus-summary-unmark-all-processable t])
["Start reading" gnus-pick-start-reading t]
["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
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-by-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-by-regexp t]
["Buffer" gnus-summary-unmark-all-processable 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.
@ -148,11 +155,11 @@ 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-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
(gnus-summary-first-article)
(gnus-configure-windows
(if gnus-pick-display-summary 'article 'pick) t))
(if gnus-pick-elegant-flow
(progn
@ -223,7 +230,7 @@ This must be bound to a button-down mouse 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-line (1+ (count-lines 1 start-point)))
(start-window (posn-window start-posn))
(bounds (gnus-window-edges start-window))
(top (nth 1 bounds))
@ -235,7 +242,7 @@ This must be bound to a button-down mouse 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,
;; 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))
@ -246,61 +253,61 @@ This must be bound to a button-down mouse event."
;; (but not outside the window where the drag started).
(let (event end end-point (end-of-range (point)))
(track-mouse
(while (progn
(setq event (cdr (gnus-read-event-char)))
(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))
(while (progn
(setq event (cdr (gnus-read-event-char)))
(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))
(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)))))))))))
(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,
;; 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.
;; (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.
;; because delete-overlay increases buffer-modified-tick.
(push event unread-command-events))))))))
(defun gnus-pick-next-page ()
@ -333,9 +340,9 @@ This must be bound to a button-down mouse event."
(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]))))
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."
@ -361,7 +368,7 @@ This must be bound to a button-down mouse event."
(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))
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
(gnus-uu-decode-uu))))
(defun gnus-binary-show-article (&optional arg)
@ -418,6 +425,11 @@ Two predefined functions are available:
:type 'hook
:group 'gnus-summary-tree)
(when (featurep 'xemacs)
(add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add)
(add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off))
;;; Internal variables.
(defvar gnus-tree-line-format-alist
@ -460,9 +472,9 @@ Two predefined functions are available:
(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]))))
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."
@ -543,7 +555,7 @@ Two predefined functions are available:
(defun gnus-tree-recenter ()
"Center point in the tree window."
(let ((selected (selected-window))
(tree-window (get-buffer-window gnus-tree-buffer t)))
(tree-window (gnus-get-buffer-window gnus-tree-buffer t)))
(when tree-window
(select-window tree-window)
(when gnus-selected-tree-overlay
@ -555,7 +567,7 @@ Two predefined functions are available:
(bottom (save-excursion (goto-char (point-max))
(forward-line (- height))
(point))))
;; Set the window start to either `bottom', which is the biggest
;; 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
@ -656,6 +668,10 @@ Two predefined functions are available:
(let* ((score (or (cdr (assq article gnus-newsgroup-scored))
gnus-summary-default-score 0))
(default gnus-summary-default-score)
(default-high gnus-summary-default-high-score)
(default-low gnus-summary-default-low-score)
(uncached (memq article gnus-newsgroup-undownloaded))
(downloaded (not uncached))
(mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
;; Eval the cars of the lists until we find a match.
(while (and list
@ -686,8 +702,8 @@ Two predefined functions are available:
(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))
(when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)
(select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t))
(gnus-horizontal-recenter)
(select-window selected))))))
@ -825,6 +841,13 @@ Two predefined functions are available:
(defun gnus-tree-close (group)
(gnus-kill-buffer gnus-tree-buffer))
(defun gnus-tree-perhaps-minimize ()
(when (and gnus-tree-minimize-window
(get-buffer gnus-tree-buffer))
(save-excursion
(set-buffer gnus-tree-buffer)
(gnus-tree-minimize))))
(defun gnus-highlight-selected-tree (article)
"Highlight the selected article in the tree."
(let ((buf (current-buffer))
@ -843,11 +866,11 @@ Two predefined functions are available:
(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))
(when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)
(select-window (gnus-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?!?
;; If we remove this save-excursion, it updates the wrong mode lines?!?
(save-excursion
(set-buffer gnus-tree-buffer)
(gnus-set-mode-line 'tree))
@ -860,7 +883,7 @@ Two predefined functions are available:
(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-get-buffer-window (current-buffer) t) (cdr region))))))
;;;
;;; gnus-carpal
@ -886,6 +909,7 @@ Two predefined functions are available:
("matching" . gnus-group-list-matching)
("post" . gnus-group-post-news)
("mail" . gnus-group-mail)
("local" . (lambda () (interactive) (gnus-group-news 0)))
("rescan" . gnus-group-get-new-news)
("browse-foreign" . gnus-group-browse-foreign)
("exit" . gnus-group-exit)))
@ -916,7 +940,8 @@ Two predefined functions are available:
("kill" . gnus-summary-kill-thread)
"post"
("post" . gnus-summary-post-news)
("mail" . gnus-summary-mail)
("local" . gnus-summary-news-other-window)
("mail" . gnus-summary-mail-other-window)
("followup" . gnus-summary-followup-with-original)
("reply" . gnus-summary-reply-with-original)
("cancel" . gnus-summary-cancel-article)

254
lisp/gnus/gnus-score.el
View File

@ -1,5 +1,5 @@
;;; gnus-score.el --- scoring code for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2004
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
@ -32,9 +32,12 @@
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-range)
(require 'gnus-win)
(require 'message)
(require 'score-mode)
(autoload 'ffap-string-at-point "ffap")
(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
@ -47,7 +50,7 @@ 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\"))"
\"/ftp.some-where:/pub/score\"))"
:group 'gnus-score-files
:type '(repeat file))
@ -232,6 +235,12 @@ This variable allows the same syntax as `gnus-home-score-file'."
(symbol :tag "other"))
(integer :tag "Score"))))))
(defcustom gnus-adaptive-word-length-limit nil
"*Words of a length lesser than this limit will be ignored when doing adaptive scoring."
:group 'gnus-score-adapt
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum length: %v\n" :size 0)))
(defcustom gnus-ignored-adaptive-words nil
"List of words to be ignored when doing adaptive word scoring."
:group 'gnus-score-adapt
@ -483,7 +492,8 @@ of the last successful match.")
"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."
used as score. A symbolic prefix of `a' says to use the `all.SCORE'
file for the command instead of the current score file."
(interactive (gnus-interactive "P\ny"))
(gnus-summary-increase-score (- (gnus-score-delta-default score)) symp))
@ -497,7 +507,8 @@ used as score."
"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."
used as score. A symbolic prefix of `a' says to use the `all.SCORE'
file for the command instead of the current score file."
(interactive (gnus-interactive "P\ny"))
(let* ((nscore (gnus-score-delta-default score))
(prefix (if (< nscore 0) ?L ?I))
@ -637,7 +648,7 @@ used as score."
(and gnus-extra-headers
(equal (nth 1 entry) "extra")
(intern ; need symbol
(gnus-completing-read
(gnus-completing-read-with-default
(symbol-name (car gnus-extra-headers)) ; default response
"Score extra header:" ; prompt
(mapcar (lambda (x) ; completion list
@ -729,13 +740,16 @@ used as score."
(insert (format format (caar alist) (nth idx (car alist))))
(setq alist (cdr alist))
(setq i (1+ i))))
(goto-char (point-min))
;; display ourselves in a small window at the bottom
(gnus-appt-select-lowest-window)
(split-window)
(pop-to-buffer "*Score Help*")
(if (< (/ (window-height) 2) window-min-height)
(switch-to-buffer "*Score Help*")
(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 t))))
(select-window (gnus-get-buffer-window gnus-summary-buffer t))))
(defun gnus-summary-header (header &optional no-err extra)
;; Return HEADER for current articles, or error.
@ -863,7 +877,7 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header."
;; Return the new scoring rule.
new))
(defun gnus-summary-score-effect (header match type score extra)
(defun gnus-summary-score-effect (header match type score &optional extra)
"Simulate the effect of a score file entry.
HEADER is the header being scored.
MATCH is the string we are looking for.
@ -875,8 +889,8 @@ EXTRA is the possible non-standard header."
(lambda (x) (fboundp (nth 2 x)))
t)
(read-string "Match: ")
(y-or-n-p "Use regexp match? ")
(prefix-numeric-value current-prefix-arg)))
(if (y-or-n-p "Use regexp match? ") 'r 's)
(string-to-int (read-string "Score: "))))
(save-excursion
(unless (and (stringp match) (> (length match) 0))
(error "No match"))
@ -926,7 +940,6 @@ EXTRA is the possible non-standard header."
;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun gnus-score-set-mark-below (score)
"Automatically mark articles with score below SCORE as read."
(interactive
@ -1093,6 +1106,39 @@ EXTRA is the possible non-standard header."
4 (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
(defun gnus-score-edit-file-at-point (&optional format)
"Edit score file at point in Score Trace buffers.
If FORMAT, also format the current score file."
(let* ((rule (save-excursion
(beginning-of-line)
(read (current-buffer))))
(sep "[ \n\r\t]*")
;; Must be synced with `gnus-score-find-trace':
(reg " -> +")
(file (save-excursion
(end-of-line)
(if (and (re-search-backward reg (gnus-point-at-bol) t)
(re-search-forward reg (gnus-point-at-eol) t))
(buffer-substring (point) (gnus-point-at-eol))
nil))))
(if (or (not file)
(string-match "\\<\\(non-file rule\\|A file\\)\\>" file)
;; (see `gnus-score-find-trace' and `gnus-score-advanced')
(string= "" file))
(gnus-error 3 "Can't find a score file in current line.")
(gnus-score-edit-file file)
(when format
(gnus-score-pretty-print))
(when (consp rule) ;; the rule exists
(setq rule (mapconcat #'(lambda (obj)
(regexp-quote (format "%S" obj)))
rule
sep))
(goto-char (point-min))
(re-search-forward rule nil t)
;; make it easy to use `kill-sexp':
(goto-char (1- (match-beginning 0)))))))
(defun gnus-score-load-file (file)
;; Load score file FILE. Returns a list a retrieved score-alists.
(let* ((file (expand-file-name
@ -1143,7 +1189,7 @@ EXTRA is the possible non-standard header."
(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)))
(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)))
@ -1202,7 +1248,6 @@ EXTRA is the possible non-standard header."
(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))
@ -1366,7 +1411,7 @@ EXTRA is the possible non-standard header."
;; This is a normal score file, so we print it very
;; prettily.
(let ((lisp-mode-syntax-table score-mode-syntax-table))
(pp score (current-buffer)))))
(gnus-pp score))))
(gnus-make-directory (file-name-directory file))
;; If the score file is empty, we delete it.
(if (zerop (buffer-size))
@ -1428,7 +1473,7 @@ EXTRA is the possible non-standard header."
(headers gnus-newsgroup-headers)
(current-score-file gnus-current-score-file)
entry header new)
(gnus-message 5 "Scoring...")
(gnus-message 7 "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
@ -1470,7 +1515,7 @@ EXTRA is the possible non-standard header."
(with-current-buffer gnus-summary-buffer
(setq gnus-newsgroup-scored scored))))
;; Remove the buffer.
(kill-buffer (current-buffer)))
(gnus-kill-buffer (current-buffer)))
;; Add articles to `gnus-newsgroup-scored'.
(while gnus-scores-articles
@ -1489,7 +1534,7 @@ EXTRA is the possible non-standard header."
(gnus-score-advanced (car score) trace))
(pop score))))
(gnus-message 5 "Scoring...done"))))))
(gnus-message 7 "Scoring...done"))))))
(defun gnus-score-lower-thread (thread score-adjust)
"Lower the score on THREAD with SCORE-ADJUST.
@ -1516,21 +1561,19 @@ A root is an article with no references. An orphan is an article
which has references, but is not connected via its references to a
root article. This function finds all the orphans, and adjusts their
score in `gnus-newsgroup-scored' by SCORE."
(let ((threads (gnus-make-threads)))
;; gnus-make-threads produces a list, where each entry is a "thread"
;; as described in the gnus-score-lower-thread docs. This function
;; will be called again (after limiting has been done) if the display
;; is threaded. It would be nice to somehow save this info and use
;; it later.
(while threads
(let* ((thread (car threads))
(id (aref (car thread) gnus-score-index)))
;; If the parent of the thread is not a root, lower the score of
;; it and its descendants. Note that some roots seem to satisfy
;; (eq id nil) and some (eq id ""); not sure why.
(if (and id (not (string= id "")))
(gnus-score-lower-thread thread score)))
(setq threads (cdr threads)))))
;; gnus-make-threads produces a list, where each entry is a "thread"
;; as described in the gnus-score-lower-thread docs. This function
;; will be called again (after limiting has been done) if the display
;; is threaded. It would be nice to somehow save this info and use
;; it later.
(dolist (thread (gnus-make-threads))
(let ((id (aref (car thread) gnus-score-index)))
;; If the parent of the thread is not a root, lower the score of
;; it and its descendants. Note that some roots seem to satisfy
;; (eq id nil) and some (eq id ""); not sure why.
(when (and id
(not (string= id "")))
(gnus-score-lower-thread thread score)))))
(defun gnus-score-integer (scores header now expire &optional trace)
(let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
@ -1718,7 +1761,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq found t)
(when trace
(push
(cons (car-safe (rassq alist gnus-score-cache)) kill)
(cons (car-safe (rassq alist gnus-score-cache))
kill)
gnus-score-trace)))
;; Update expire date
(unless trace
@ -1776,7 +1820,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(put-text-property (1- (point)) (point) 'articles alike))
(setq alike (list art)
last this)))
(when last ; Bwadr, duplicate code.
(when last ; Bwadr, duplicate code.
(insert last ?\n)
(put-text-property (1- (point)) (point) 'articles alike))
@ -1785,7 +1829,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq alist (car scores)
scores (cdr scores)
entries (assoc header alist))
(while (cdr entries) ;First entry is the header index.
(while (cdr entries) ;First entry is the header index.
(let* ((rest (cdr entries))
(kill (car rest))
(match (nth 0 kill))
@ -1805,7 +1849,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(goto-char (point-min))
(if (= dmt ?e)
(while (funcall search-func match nil t)
(and (= (progn (beginning-of-line) (point))
(and (= (gnus-point-at-bol)
(match-beginning 0))
(= (progn (end-of-line) (point))
(match-end 0))
@ -1824,6 +1868,12 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq found (setq arts (get-text-property (point) 'articles)))
;; Found a match, update scores.
(while (setq art (pop arts))
(setcdr art (+ score (cdr art)))
(when trace
(push (cons
(car-safe (rassq alist gnus-score-cache))
kill)
gnus-score-trace))
(when (setq new (gnus-score-add-followups
(car art) score all-scores thread))
(push new news)))))
@ -1871,8 +1921,8 @@ score in `gnus-newsgroup-scored' by SCORE."
;; 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.
(simplify (and gnus-score-thread-simplify
(string= "subject" header)))
(simplify (and gnus-score-thread-simplify
(string= "subject" header)))
alike last this art entries alist articles
fuzzies arts words kill)
@ -1897,7 +1947,7 @@ score in `gnus-newsgroup-scored' by SCORE."
;; with working on them as a group. What a hassle.
;; Just wait 'til you see what horrors we commit against `match'...
(if (= gnus-score-index 9)
(setq this (prin1-to-string this))) ; ick.
(setq this (gnus-prin1-to-string this))) ; ick.
(if simplify
(setq this (gnus-map-function gnus-simplify-subject-functions this)))
@ -1936,10 +1986,10 @@ score in `gnus-newsgroup-scored' by SCORE."
(dmt (downcase mt))
;; Assume user already simplified regexp and fuzzies
(match (if (and simplify (not (memq dmt '(?f ?r))))
(gnus-map-function
gnus-simplify-subject-functions
(nth 0 kill))
(nth 0 kill)))
(gnus-map-function
gnus-simplify-subject-functions
(nth 0 kill))
(nth 0 kill)))
(search-func
(cond ((= dmt ?r) 're-search-forward)
((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
@ -1949,7 +1999,7 @@ score in `gnus-newsgroup-scored' by SCORE."
;; Evil hackery to make match usable in non-standard headers.
(when extra
(setq match (concat "[ (](" extra " \\. \"[^)]*"
match "[^(]*\")[ )]")
match "[^\"]*\")[ )]")
search-func 're-search-forward)) ; XXX danger?!?
(cond
@ -2275,11 +2325,14 @@ score in `gnus-newsgroup-scored' by SCORE."
;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0))
hashtb))
(setq val (+ score (or val 0)))
(if (and gnus-adaptive-word-minimum
(< val gnus-adaptive-word-minimum))
(setq val gnus-adaptive-word-minimum))
(gnus-sethash word val hashtb))
(when (or (not gnus-adaptive-word-length-limit)
(> (length word)
gnus-adaptive-word-length-limit))
(setq val (+ score (or val 0)))
(if (and gnus-adaptive-word-minimum
(< val gnus-adaptive-word-minimum))
(setq val gnus-adaptive-word-minimum))
(gnus-sethash word val hashtb)))
(erase-buffer))))
(set-syntax-table syntab))
;; Make all the ignorable words ignored.
@ -2318,7 +2371,10 @@ score in `gnus-newsgroup-scored' by SCORE."
(let ((gnus-newsgroup-headers
(list (gnus-summary-article-header)))
(gnus-newsgroup-scored nil)
trace)
;; Must be synced with `gnus-score-edit-file-at-point':
(frmt "%S [%s] -> %s\n")
trace
file)
(save-excursion
(nnheader-set-temp-buffer "*Score Trace*"))
(setq gnus-score-trace nil)
@ -2328,11 +2384,44 @@ score in `gnus-newsgroup-scored' by SCORE."
1 "No score rules apply to the current article (default score %d)."
gnus-summary-default-score)
(set-buffer "*Score Trace*")
;; Use a keymap instead?
(local-set-key "q"
(lambda ()
(interactive)
(bury-buffer nil)
(gnus-summary-expand-window)))
(local-set-key "e" (lambda ()
"Run `gnus-score-edit-file-at-point'."
(interactive)
(gnus-score-edit-file-at-point)))
(local-set-key "f" (lambda ()
"Run `gnus-score-edit-file-at-point'."
(interactive)
(gnus-score-edit-file-at-point 'format)))
(local-set-key "t" 'toggle-truncate-lines)
(setq truncate-lines t)
(while trace
(insert (format "%S -> %s\n" (cdar trace)
(or (caar trace) "(non-file rule)")))
(setq trace (cdr trace)))
(dolist (entry trace)
(setq file (or (car entry)
;; Must be synced with
;; `gnus-score-edit-file-at-point':
"(non-file rule)"))
(insert
(format frmt
(cdr entry)
;; Don't use `file-name-sans-extension' to see .SCORE and
;; .ADAPT directly:
(file-name-nondirectory file)
(abbreviate-file-name file))))
(insert
"\n\nQuick help:
Type `e' to edit score file corresponding to the score rule on current line,
`f' to format (pretty print) the score file and edit it,
`t' toggle to truncate long lines in this buffer,
`q' to quit.
The first sexp on each line is the score rule, followed by the file name of
the score file and its full name, including the directory.")
(goto-char (point-min))
(gnus-configure-windows 'score-trace)))
(set-buffer gnus-summary-buffer)
@ -2460,7 +2549,7 @@ score in `gnus-newsgroup-scored' by 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-delta-default score)))))
(gnus-summary-raise-thread (- (gnus-score-delta-default score))))
;;; Finding score files.
@ -2522,7 +2611,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(push file out))))
(or out
;; Return a dummy value.
(list "~/News/this.file.does.not.exist.SCORE"))))
(list (expand-file-name "this.file.does.not.exist.SCORE"
gnus-kill-files-directory)))))
(defun gnus-score-file-regexp ()
"Return a regexp that match all score files."
@ -2586,11 +2676,13 @@ GROUP using BNews sys file syntax."
(replace-match ".*" t t))
(goto-char (point-min))
;; Deal with "not."s.
(setq not-match (looking-at "not."))
(setq regexp
(concat "^" (buffer-substring (+ (point-min) (if not-match 4 0))
(point-max))
"$"))
(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.
@ -2601,7 +2693,7 @@ GROUP using BNews sys file syntax."
(ignore-errors (string-match regexp group-trans))))
(push (car sfiles) ofiles)))
(setq sfiles (cdr sfiles)))
(kill-buffer (current-buffer))
(gnus-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
@ -2733,9 +2825,10 @@ The list is determined from the variable `gnus-score-file-alist'."
;; 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))
(when (functionp (car funcs))
(setq score-files
(nconc score-files (nreverse (funcall (car funcs) group)))))
(append score-files
(nreverse (funcall (car funcs) group)))))
(setq funcs (cdr funcs)))
(when gnus-score-use-all-scores
;; Add any home score files.
@ -2800,7 +2893,7 @@ The list is determined from the variable `gnus-score-file-alist'."
(let (out)
(while files
;; #### /$ Unix-specific?
(if (string-match "/$" (car files))
(if (file-directory-p (car files))
(setq out (nconc (directory-files
(car files) t
(concat (gnus-score-file-regexp) "$"))))
@ -2835,16 +2928,17 @@ If ADAPT, return the home adaptive file instead."
((stringp elem)
elem)
;; Function.
((gnus-functionp elem)
((functionp elem)
(funcall elem group))
;; Regexp-file cons.
((consp elem)
(when (string-match (gnus-globalify-regexp (car elem)) group)
(replace-match (cadr elem) t nil group))))))
(when found
(setq found (nnheader-translate-file-chars found))
(if (file-name-absolute-p found)
found
(nnheader-concat gnus-kill-files-directory found)))))
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."
@ -2872,13 +2966,19 @@ If ADAPT, return the home adaptive file instead."
(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)))))))
(let ((n (- score
(* (if (< score 0) -1 1)
(min (abs score)
(max gnus-score-decay-constant
(* (abs score)
gnus-score-decay-scale)))))))
(if (and (featurep 'xemacs)
;; XEmacs' floor can handle only the floating point
;; number below the half of the maximum integer.
(> (abs n) (lsh -1 -2)))
(string-to-number
(car (split-string (number-to-string n) "\\.")))
(floor n))))
(defun gnus-decay-scores (alist day)
"Decay non-permanent scores in ALIST."
@ -2911,7 +3011,7 @@ 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."
See Info node `(gnus)Scoring Tips' for examples of good regular expressions."
(let (case-fold-search)
(and
;; First, try a relatively fast necessary condition.

9
lisp/gnus/gnus-setup.el
View File

@ -1,6 +1,7 @@
;;; gnus-setup.el --- initialization & setup for Gnus 5
;;; gnus-setup.el --- Initialization & Setup for Gnus 5
;; Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 2000, 2001
;; Free Software Foundation, Inc.
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news
@ -89,8 +90,8 @@
(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)
;;; (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)))

240
lisp/gnus/gnus-sieve.el Normal file
View File

@ -0,0 +1,240 @@
;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
;; Author: NAGY Andras <nagya@inf.elte.hu>,
;; Simon Josefsson <simon@josefsson.org>
;; 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:
;; Gnus glue to generate complete Sieve scripts from Gnus Group
;; Parameters with "if" test predicates.
;;; Code:
(require 'gnus)
(require 'gnus-sum)
(require 'format-spec)
(autoload 'sieve-mode "sieve-mode")
(eval-when-compile
(require 'sieve))
;; Variables
(defgroup gnus-sieve nil
"Manage sieve scripts in Gnus."
:group 'gnus)
(defcustom gnus-sieve-file "~/.sieve"
"Path to your Sieve script."
:type 'file
:group 'gnus-sieve)
(defcustom gnus-sieve-region-start "\n## Begin Gnus Sieve Script\n"
"Line indicating the start of the autogenerated region in
your Sieve script."
:type 'string
:group 'gnus-sieve)
(defcustom gnus-sieve-region-end "\n## End Gnus Sieve Script\n"
"Line indicating the end of the autogenerated region in
your Sieve script."
:type 'string
:group 'gnus-sieve)
(defcustom gnus-sieve-select-method nil
"Which select method we generate the Sieve script for.
For example: \"nnimap:mailbox\""
:group 'gnus-sieve)
(defcustom gnus-sieve-crosspost t
"Whether the generated Sieve script should do crossposting."
:type 'boolean
:group 'gnus-sieve)
(defcustom gnus-sieve-update-shell-command "echo put %f | sieveshell %s"
"Shell command to execute after updating your Sieve script. The following
formatting characters are recognized:
%f Script's file name (gnus-sieve-file)
%s Server name (from gnus-sieve-select-method)"
:type 'string
:group 'gnus-sieve)
;;;###autoload
(defun gnus-sieve-update ()
"Update the Sieve script in gnus-sieve-file, by replacing the region
between gnus-sieve-region-start and gnus-sieve-region-end with
\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\), then
execute gnus-sieve-update-shell-command.
See the documentation for these variables and functions for details."
(interactive)
(gnus-sieve-generate)
(save-buffer)
(shell-command
(format-spec gnus-sieve-update-shell-command
(format-spec-make ?f gnus-sieve-file
?s (or (cadr (gnus-server-get-method
nil gnus-sieve-select-method))
"")))))
;;;###autoload
(defun gnus-sieve-generate ()
"Generate the Sieve script in gnus-sieve-file, by replacing the region
between gnus-sieve-region-start and gnus-sieve-region-end with
\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\).
See the documentation for these variables and functions for details."
(interactive)
(require 'sieve)
(find-file gnus-sieve-file)
(goto-char (point-min))
(if (re-search-forward (regexp-quote gnus-sieve-region-start) nil t)
(delete-region (match-end 0)
(or (re-search-forward (regexp-quote
gnus-sieve-region-end) nil t)
(point)))
(insert sieve-template))
(insert gnus-sieve-region-start
(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost)
gnus-sieve-region-end))
(defun gnus-sieve-guess-rule-for-article ()
"Guess a sieve rule based on RFC822 article in buffer.
Return nil if no rule could be guessed."
(when (message-fetch-field "sender")
`(sieve address "sender" ,(message-fetch-field "sender"))))
;;;###autoload
(defun gnus-sieve-article-add-rule ()
(interactive)
(gnus-summary-select-article nil 'force)
(with-current-buffer gnus-original-article-buffer
(let ((rule (gnus-sieve-guess-rule-for-article))
(info (gnus-get-info gnus-newsgroup-name)))
(if (null rule)
(error "Could not guess rule for article.")
(gnus-info-set-params info (cons rule (gnus-info-params info)))
(message "Added rule in group %s for article: %s" gnus-newsgroup-name
rule)))))
;; Internals
;; FIXME: do proper quoting of " etc
(defun gnus-sieve-string-list (list)
"Convert an elisp string list to a Sieve string list.
For example:
\(gnus-sieve-string-list '(\"to\" \"cc\"))
=> \"[\\\"to\\\", \\\"cc\\\"]\"
"
(concat "[\"" (mapconcat 'identity list "\", \"") "\"]"))
(defun gnus-sieve-test-list (list)
"Convert an elisp test list to a Sieve test list.
For example:
\(gnus-sieve-test-list '((address \"sender\" \"boss@company.com\") (size :over 4K)))
=> \"(address \\\"sender\\\" \\\"boss@company.com\\\", size :over 4K)\""
(concat "(" (mapconcat 'gnus-sieve-test list ", ") ")"))
;; FIXME: do proper quoting
(defun gnus-sieve-test-token (token)
"Convert an elisp test token to a Sieve test token.
For example:
\(gnus-sieve-test-token 'address)
=> \"address\"
\(gnus-sieve-test-token \"sender\")
=> \"\\\"sender\\\"\"
\(gnus-sieve-test-token '(\"to\" \"cc\"))
=> \"[\\\"to\\\", \\\"cc\\\"]\""
(cond
((symbolp token) ;; Keyword
(symbol-name token))
((stringp token) ;; String
(concat "\"" token "\""))
((and (listp token) ;; String list
(stringp (car token)))
(gnus-sieve-string-list token))
((and (listp token) ;; Test list
(listp (car token)))
(gnus-sieve-test-list token))))
(defun gnus-sieve-test (test)
"Convert an elisp test to a Sieve test.
For example:
\(gnus-sieve-test '(address \"sender\" \"sieve-admin@extundo.com\"))
=> \"address \\\"sender\\\" \\\"sieve-admin@extundo.com\\\"\"
\(gnus-sieve-test '(anyof ((header :contains (\"to\" \"cc\") \"my@address.com\")
(size :over 100K))))
=> \"anyof (header :contains [\\\"to\\\", \\\"cc\\\"] \\\"my@address.com\\\",
size :over 100K)\""
(mapconcat 'gnus-sieve-test-token test " "))
(defun gnus-sieve-script (&optional method crosspost)
"Generate a Sieve script based on groups with select method METHOD
\(or all groups if nil\). Only groups having a `sieve' parameter are
considered. This parameter should contain an elisp test
\(see the documentation of gnus-sieve-test for details\). For each
such group, a Sieve IF control structure is generated, having the
test as the condition and { fileinto \"group.name\"; } as the body.
If CROSSPOST is nil, each conditional body contains a \"stop\" command
which stops execution after a match is found.
For example: If the INBOX.list.sieve group has the
(sieve address \"sender\" \"sieve-admin@extundo.com\")
group parameter, (gnus-sieve-script) results in:
if address \"sender\" \"sieve-admin@extundo.com\" {
fileinto \"INBOX.list.sieve\";
}
This is returned as a string."
(let* ((newsrc (cdr gnus-newsrc-alist))
script)
(dolist (info newsrc)
(when (or (not method)
(gnus-server-equal method (gnus-info-method info)))
(let* ((group (gnus-info-group info))
(spec (gnus-group-find-parameter group 'sieve t)))
(when spec
(push (concat "if " (gnus-sieve-test spec) " {\n"
"\tfileinto \"" (gnus-group-real-name group) "\";\n"
(if crosspost
""
"\tstop;\n")
"}")
script)))))
(mapconcat 'identity script "\n")))
(provide 'gnus-sieve)
;;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3
;;; gnus-sieve.el ends here

51
lisp/gnus/gnus-soup.el
View File

@ -1,6 +1,6 @@
;;; gnus-soup.el --- SOUP packet writing support for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002
;; Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
@ -154,11 +154,11 @@ move those articles instead."
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)
area (1+ (or (gnus-soup-area-number area) 0)))
;; Mark article as read.
(set-buffer gnus-summary-buffer)
(gnus-summary-mark-as-read (car articles) gnus-souped-mark))
(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)
@ -357,9 +357,9 @@ If NOT-ALL, don't pack ticked articles."
(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)))
(if (eq 0 (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))
@ -496,10 +496,10 @@ 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))))
(eq 0 (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)
@ -540,26 +540,35 @@ Return whether the unpacking was successful."
(match-beginning 1) (match-end 1)))))
(switch-to-buffer tmp-buf)
(erase-buffer)
(mm-disable-multibyte)
(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)))
'dont-check-for-anything-just-trust-me)
(method (if (functionp message-post-method)
(funcall message-post-method)
message-post-method))
result)
(run-hooks 'message-send-news-hook)
(gnus-open-server method)
(message "Sending news via %s..."
(gnus-server-string method))
(unless (let ((mail-header-separator ""))
(gnus-request-post method))
(message "Couldn't send message via news: %s"
(nnheader-get-report (car method))))))
((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))
(let ((mail-header-separator ""))
(mm-with-unibyte-current-buffer
(funcall (or message-send-mail-real-function
message-send-mail-function)))))
(t
(error "Unknown reply kind")))
(set-buffer msg-buf)

357
lisp/gnus/gnus-spec.el
View File

@ -1,5 +1,5 @@
;;; gnus-spec.el --- format spec functions for Gnus -*- coding: iso-latin-1 -*-
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;;; gnus-spec.el --- format spec functions for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -30,6 +30,17 @@
(require 'gnus)
(defcustom gnus-use-correct-string-widths (featurep 'xemacs)
"*If non-nil, use correct functions for dealing with wide characters."
:group 'gnus-format
:type 'boolean)
(defcustom gnus-make-format-preserve-properties (featurep 'xemacs)
"*If non-nil, use a replacement `format' function which preserves
text properties. This is only needed on XEmacs, as FSF Emacs does this anyway."
:group 'gnus-format
:type 'boolean)
;;; Internal variables.
(defvar gnus-summary-mark-positions nil)
@ -69,6 +80,8 @@
(defvar gnus-tmp-article-number)
(defvar gnus-mouse-face)
(defvar gnus-mouse-face-prop)
(defvar gnus-tmp-header)
(defvar gnus-tmp-from)
(defun gnus-summary-line-format-spec ()
(insert gnus-tmp-unread gnus-tmp-replied
@ -77,13 +90,15 @@
(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)
(format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines
(let ((val
(inline
(gnus-summary-from-or-to-or-newsgroups
gnus-tmp-header gnus-tmp-from))))
(if (> (length val) 23)
(substring val 0 23)
val))
gnus-tmp-closing-bracket))
(point))
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject-or-nil "\n"))
@ -120,18 +135,21 @@
(defvar gnus-format-specs
`((version . ,emacs-version)
(gnus-version . ,(gnus-continuum-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"
(summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n"
,gnus-summary-line-format-spec))
"Alist of format specs.")
(defvar gnus-default-format-specs gnus-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.
;;; Phew. All that gruft is over with, fortunately.
;;;###autoload
(defun gnus-update-format (var)
@ -162,13 +180,16 @@
(pop-to-buffer "*Gnus Format*")
(erase-buffer)
(lisp-interaction-mode)
(insert (pp-to-string spec))))
(insert (gnus-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 gnus-newsrc-file-version)
(not (equal (gnus-continuum-version)
(gnus-continuum-version gnus-newsrc-file-version)))
(not (equal emacs-version
(cdr (assq 'version gnus-format-specs)))))
(setq gnus-format-specs nil))
@ -176,8 +197,8 @@
;; 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.)
;; 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)
@ -243,39 +264,109 @@
(defun gnus-balloon-face-function (form type)
`(gnus-put-text-property
(point) (progn ,@form (point))
'balloon-help
,(if (fboundp 'balloon-help-mode)
''balloon-help
''help-echo)
,(intern (format "gnus-balloon-face-%d" type))))
(defun gnus-spec-tab (column)
(if (> column 0)
`(insert (make-string (max (- ,column (current-column)) 0) ? ))
(let ((column (abs column)))
(if gnus-use-correct-string-widths
`(progn
(if (> (current-column) ,column)
(while (progn
(delete-backward-char 1)
(> (current-column) ,column))))
(insert (make-string (max (- ,column (current-column)) 0) ? )))
`(progn
(if (> (current-column) ,column)
(delete-region (point)
(- (point) (- (current-column) ,column)))
(insert (make-string (max (- ,column (current-column)) 0)
? ))))))))
(defun gnus-correct-length (string)
"Return the correct width of STRING."
(let ((length 0))
(mapcar (lambda (char) (incf length (gnus-char-width char))) string)
length))
(defun gnus-correct-substring (string start &optional end)
(let ((wstart 0)
(wend 0)
(wseek 0)
(seek 0)
(length (length string))
(string (concat string "\0")))
;; Find the start position.
(while (and (< seek length)
(< wseek start))
(incf wseek (gnus-char-width (aref string seek)))
(incf seek))
(setq wstart seek)
;; Find the end position.
(while (and (<= seek length)
(or (not end)
(<= wseek end)))
(incf wseek (gnus-char-width (aref string seek)))
(incf seek))
(setq wend seek)
(substring string wstart (1- wend))))
(defun gnus-string-width-function ()
(cond
(gnus-use-correct-string-widths
'gnus-correct-length)
((fboundp 'string-width)
'string-width)
(t
'length)))
(defun gnus-substring-function ()
(cond
(gnus-use-correct-string-widths
'gnus-correct-substring)
((fboundp 'string-width)
'gnus-correct-substring)
(t
'substring)))
(defun gnus-tilde-max-form (el max-width)
"Return a form that limits EL to MAX-WIDTH."
(let ((max (abs max-width)))
(let ((max (abs max-width))
(length-fun (gnus-string-width-function))
(substring-fun (gnus-substring-function)))
(if (symbolp el)
`(if (> (length ,el) ,max)
`(if (> (,length-fun ,el) ,max)
,(if (< max-width 0)
`(substring ,el (- (length el) ,max))
`(substring ,el 0 ,max))
`(,substring-fun ,el (- (,length-fun ,el) ,max))
`(,substring-fun ,el 0 ,max))
,el)
`(let ((val (eval ,el)))
(if (> (length val) ,max)
(if (> (,length-fun val) ,max)
,(if (< max-width 0)
`(substring val (- (length val) ,max))
`(substring val 0 ,max))
`(,substring-fun val (- (,length-fun val) ,max))
`(,substring-fun 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)))
(let ((cut (abs cut-width))
(length-fun (gnus-string-width-function))
(substring-fun (gnus-substring-function)))
(if (symbolp el)
`(if (> (length ,el) ,cut)
`(if (> (,length-fun ,el) ,cut)
,(if (< cut-width 0)
`(substring ,el 0 (- (length el) ,cut))
`(substring ,el ,cut))
`(,substring-fun ,el 0 (- (,length-fun ,el) ,cut))
`(,substring-fun ,el ,cut))
,el)
`(let ((val (eval ,el)))
(if (> (length val) ,cut)
(if (> (,length-fun val) ,cut)
,(if (< cut-width 0)
`(substring val 0 (- (length val) ,cut))
`(substring val ,cut))
`(,substring-fun val 0 (- (,length-fun val) ,cut))
`(,substring-fun val ,cut))
val)))))
(defun gnus-tilde-ignore-form (el ignore-value)
@ -287,6 +378,28 @@
(if (equal val ,ignore-value)
"" val))))
(defun gnus-pad-form (el pad-width)
"Return a form that pads EL to PAD-WIDTH accounting for multi-column
characters correctly. This is because `format' may pad to columns or to
characters when given a pad value."
(let ((pad (abs pad-width))
(side (< 0 pad-width))
(length-fun (gnus-string-width-function)))
(if (symbolp el)
`(let ((need (- ,pad (,length-fun ,el))))
(if (> need 0)
(concat ,(when side '(make-string need ?\ ))
,el
,(when (not side) '(make-string need ?\ )))
,el))
`(let* ((val (eval ,el))
(need (- ,pad (,length-fun val))))
(if (> need 0)
(concat ,(when side '(make-string need ?\ ))
val
,(when (not side) '(make-string need ?\ )))
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
@ -294,52 +407,115 @@
;; the text between them will have the mouse-face text property.
;; If the FORMAT string contains the specifiers %[ and %], the text between
;; them will have the balloon-help 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)))
(let ((case-fold-search nil))
(if (string-match
"\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*"
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 ?\{)
(= delim ?\«))
(replace-match (concat "\"("
(cond ((= delim ?\() "mouse")
((= delim ?\{) "face")
(t "balloon"))
" " 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)))))
(let ((cursor-spec nil))
(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 "(\"")
;; Convert all font specs into font spec lists.
(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 ?\{)
(= delim ?\«))
(replace-match (concat "\"("
(cond ((= delim ?\() "mouse")
((= delim ?\{) "face")
(t "balloon"))
" " number " \"")
t t)
(replace-match "\")\""))))
(goto-char (point-max))
(insert "\")")
;; Convert point position commands.
(goto-char (point-min))
(let ((case-fold-search nil))
(while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t)
(replace-match "\"(point)\"" t t)
(setq cursor-spec t)))
;; Convert TAB commands.
(goto-char (point-min))
(while (re-search-forward "%\\([-0-9]+\\)=" nil t)
(replace-match (format "\"(tab %s)\"" (match-string 1)) t t))
;; Convert the buffer into the spec.
(goto-char (point-min))
(let ((form (read (current-buffer))))
(if cursor-spec
`(let (gnus-position)
,@(gnus-complex-form-to-spec form spec-alist)
(if gnus-position
(gnus-put-text-property gnus-position (1+ gnus-position)
'gnus-position t)))
`(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)
(cond
((stringp sform)
(gnus-parse-simple-format sform spec-alist t))
((eq (car sform) 'point)
'(setq gnus-position (point)))
((eq (car sform) 'tab)
(gnus-spec-tab (cadr sform)))
(t
(funcall (intern (format "gnus-%s-face-function" (car sform)))
(gnus-complex-form-to-spec (cddr sform) spec-alist)
(nth 1 sform))))
(nth 1 sform)))))
form)))
(defun gnus-xmas-format (fstring &rest args)
"A version of `format' which preserves text properties.
Required for XEmacs, where the built in `format' function strips all text
properties from both the format string and any inserted strings.
Only supports the format sequence %s, and %% for inserting
literal % characters. A pad width and an optional - (to right pad)
are supported for %s."
(let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s")
(n (length args)))
(with-temp-buffer
(insert fstring)
(goto-char (point-min))
(while (re-search-forward re nil t)
(goto-char (match-end 0))
(cond
((string= (match-string 0) "%%")
(delete-char -1))
(t
(if (null args)
(error 'wrong-number-of-arguments #'my-format n fstring))
(let* ((minlen (string-to-int (or (match-string 2) "")))
(arg (car args))
(str (if (stringp arg) arg (format "%s" arg)))
(lpad (null (match-string 1)))
(padlen (max 0 (- minlen (length str)))))
(replace-match "")
(if lpad (insert-char ?\ padlen))
(insert str)
(unless lpad (insert-char ?\ padlen))
(setq args (cdr args))))))
(buffer-string))))
(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
@ -347,7 +523,7 @@
(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)
tilde-form tilde elem-type extended-spec)
(save-excursion
(gnus-set-work-buffer)
(insert format)
@ -359,7 +535,8 @@
max-width nil
cut-width nil
ignore-value nil
tilde-form nil)
tilde-form nil
extended-spec nil)
(setq spec-beg (1- (point)))
;; Parse this spec fully.
@ -400,10 +577,18 @@
t)
(t
nil)))
;; User-defined spec -- find the spec name.
(when (eq (setq spec (char-after)) ?u)
(cond
;; User-defined spec -- find the spec name.
((eq (setq spec (char-after)) ?u)
(forward-char 1)
(setq user-defined (char-after)))
(when (and (eq (setq user-defined (char-after)) ?&)
(looking-at "&\\([^;]+\\);"))
(setq user-defined (match-string 1))
(goto-char (match-end 1))))
;; extended spec
((and (eq spec ?&) (looking-at "&\\([^;]+\\);"))
(setq extended-spec (intern (match-string 1)))
(goto-char (match-end 1))))
(forward-char 1)
(delete-region spec-beg (point))
@ -421,20 +606,27 @@
(user-defined
(setq elem
(list
(list (intern (format "gnus-user-format-function-%c"
user-defined))
(list (intern (format
(if (stringp user-defined)
"gnus-user-format-function-%s"
"gnus-user-format-function-%c")
user-defined))
'gnus-tmp-header)
?s)))
;; Find the specification from `spec-alist'.
((setq elem (cdr (assq spec spec-alist))))
((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
(t
(setq elem '("*" ?s))))
(setq elem-type (cadr elem))
;; Insert the new format elements.
(when pad-width
(when (and pad-width
(not (and (featurep 'xemacs)
gnus-use-correct-string-widths)))
(insert (number-to-string pad-width)))
;; Create the form to be evaled.
(if (or max-width cut-width ignore-value)
(if (or max-width cut-width ignore-value
(and (featurep 'xemacs)
gnus-use-correct-string-widths))
(progn
(insert ?s)
(let ((el (car elem)))
@ -448,16 +640,18 @@
(setq el (gnus-tilde-cut-form el cut-width)))
(when max-width
(setq el (gnus-tilde-max-form el max-width)))
(when pad-width
(setq el (gnus-pad-form el pad-width)))
(push el flist)))
(insert elem-type)
(push (car elem) flist))))
(setq fstring (buffer-string)))
(setq fstring (buffer-substring-no-properties (point-min) (point-max))))
;; Do some postprocessing to increase efficiency.
(setq
result
(cond
;; Emptyness.
;; Emptiness.
((string= fstring "")
nil)
;; Not a format string.
@ -487,6 +681,13 @@
;; A single string spec in the end of the spec.
((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
(list (match-string 1 fstring) (car flist)))
;; Only string (and %) specs (XEmacs only!)
((and (featurep 'xemacs)
gnus-make-format-preserve-properties
(string-match
"\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'"
fstring))
(list (cons 'gnus-xmas-format (cons fstring (nreverse flist)))))
;; A more complex spec.
(t
(list (cons 'format (cons fstring (nreverse flist)))))))
@ -522,7 +723,7 @@ If PROPS, insert the result."
(while entries
(setq entry (pop entries))
(if (eq (car entry) 'version)
(if (memq (car entry) '(gnus-version version))
(setq gnus-format-specs (delq entry gnus-format-specs))
(let ((form (caddr entry)))
(when (and (listp form)
@ -531,7 +732,7 @@ If PROPS, insert the result."
;; Under XEmacs, it's (funcall #<compiled-function ...>)
(not (and (eq 'funcall (car form))
(byte-code-function-p (cadr form)))))
(fset 'gnus-tmp-func `(lambda () ,form))
(defalias 'gnus-tmp-func `(lambda () ,form))
(byte-compile 'gnus-tmp-func)
(setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))

365
lisp/gnus/gnus-srvr.el
View File

@ -1,5 +1,5 @@
;;; gnus-srvr.el --- virtual server support for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -34,10 +34,17 @@
(require 'gnus-int)
(require 'gnus-range)
(defvar gnus-server-mode-hook nil
"Hook run in `gnus-server-mode' buffers.")
(defcustom gnus-server-mode-hook nil
"Hook run in `gnus-server-mode' buffers."
:group 'gnus-server
:type 'hook)
(defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
(defcustom gnus-server-exit-hook nil
"Hook run when exiting the server buffer."
:group 'gnus-server
:type 'hook)
(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
"Format of server lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
@ -47,13 +54,25 @@ The following specs are understood:
%h backend
%n name
%w address
%s status")
%s status
%a agent covered
(defvar gnus-server-mode-line-format "Gnus: %%b"
"The format specification for the server mode line.")
General format specifiers can also be used.
See Info node `(gnus)Formatting Variables'."
:link '(custom-manual "(gnus)Formatting Variables")
:group 'gnus-server-visual
:type 'string)
(defvar gnus-server-exit-hook nil
"*Hook run when exiting the server buffer.")
(defcustom gnus-server-mode-line-format "Gnus: %%b"
"The format specification for the server mode line."
:group 'gnus-server-visual
:type 'string)
(defcustom gnus-server-browse-in-group-buffer nil
"Whether server browsing should take place in the group buffer.
If nil, a faster, but more primitive, buffer is used instead."
:group 'gnus-server-visual
:type 'boolean)
;;; Internal variables.
@ -63,7 +82,8 @@ The following specs are understood:
`((?h gnus-tmp-how ?s)
(?n gnus-tmp-name ?s)
(?w gnus-tmp-where ?s)
(?s gnus-tmp-status ?s)))
(?s gnus-tmp-status ?s)
(?a gnus-tmp-agent ?s)))
(defvar gnus-server-mode-line-format-alist
`((?S gnus-tmp-news-server ?s)
@ -85,7 +105,7 @@ The following specs are understood:
(easy-menu-define
gnus-server-server-menu gnus-server-mode-map ""
'("Server"
["Add" gnus-server-add-server t]
["Add..." gnus-server-add-server t]
["Browse" gnus-server-read-server t]
["Scan" gnus-server-scan-server t]
["List" gnus-server-list-servers t]
@ -101,6 +121,7 @@ The following specs are understood:
'("Connections"
["Open" gnus-server-open-server t]
["Close" gnus-server-close-server t]
["Offline" gnus-server-offline-server t]
["Deny" gnus-server-deny-server t]
"---"
["Open All" gnus-server-open-all-servers t]
@ -117,7 +138,7 @@ The following specs are understood:
(suppress-keymap gnus-server-mode-map)
(gnus-define-keys gnus-server-mode-map
" " gnus-server-read-server
" " gnus-server-read-server-in-server-buffer
"\r" gnus-server-read-server
gnus-mouse-2 gnus-server-pick-server
"q" gnus-server-exit
@ -134,6 +155,7 @@ The following specs are understood:
"C" gnus-server-close-server
"\M-c" gnus-server-close-all-servers
"D" gnus-server-deny-server
"L" gnus-server-offline-server
"R" gnus-server-remove-denials
"n" next-line
@ -144,6 +166,75 @@ The following specs are understood:
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
(defface gnus-server-agent-face
'((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
(((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
(t (:bold t)))
"Face used for displaying AGENTIZED servers"
:group 'gnus-server-visual)
(defface gnus-server-opened-face
'((((class color) (background light)) (:foreground "Green3" :bold t))
(((class color) (background dark)) (:foreground "Green1" :bold t))
(t (:bold t)))
"Face used for displaying OPENED servers"
:group 'gnus-server-visual)
(defface gnus-server-closed-face
'((((class color) (background light)) (:foreground "Steel Blue" :italic t))
(((class color) (background dark))
(:foreground "Light Steel Blue" :italic t))
(t (:italic t)))
"Face used for displaying CLOSED servers"
:group 'gnus-server-visual)
(defface gnus-server-denied-face
'((((class color) (background light)) (:foreground "Red" :bold t))
(((class color) (background dark)) (:foreground "Pink" :bold t))
(t (:inverse-video t :bold t)))
"Face used for displaying DENIED servers"
:group 'gnus-server-visual)
(defface gnus-server-offline-face
'((((class color) (background light)) (:foreground "Orange" :bold t))
(((class color) (background dark)) (:foreground "Yellow" :bold t))
(t (:inverse-video t :bold t)))
"Face used for displaying OFFLINE servers"
:group 'gnus-server-visual)
(defcustom gnus-server-agent-face 'gnus-server-agent-face
"Face name to use on AGENTIZED servers."
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-opened-face 'gnus-server-opened-face
"Face name to use on OPENED servers."
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-closed-face 'gnus-server-closed-face
"Face name to use on CLOSED servers."
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-denied-face 'gnus-server-denied-face
"Face name to use on DENIED servers."
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-offline-face 'gnus-server-offline-face
"Face name to use on OFFLINE servers."
:group 'gnus-server-visual
:type 'face)
(defvar gnus-server-font-lock-keywords
(list
'("(\\(agent\\))" 1 gnus-server-agent-face)
'("(\\(opened\\))" 1 gnus-server-opened-face)
'("(\\(closed\\))" 1 gnus-server-closed-face)
'("(\\(offline\\))" 1 gnus-server-offline-face)
'("(\\(denied\\))" 1 gnus-server-denied-face)))
(defun gnus-server-mode ()
"Major mode for listing and editing servers.
@ -168,6 +259,10 @@ The following commands are available:
(buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
(if (featurep 'xemacs)
(put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
(set (make-local-variable 'font-lock-defaults)
'(gnus-server-font-lock-keywords t)))
(gnus-run-hooks 'gnus-server-mode-hook))
(defun gnus-server-insert-server-line (gnus-tmp-name method)
@ -175,21 +270,28 @@ The following commands are available:
(gnus-tmp-where (nth 1 method))
(elem (assoc method gnus-opened-servers))
(gnus-tmp-status
(if (eq (nth 1 elem) 'denied)
"(denied)"
(cond
((eq (nth 1 elem) 'denied) "(denied)")
((eq (nth 1 elem) 'offline) "(offline)")
(t
(condition-case nil
(if (or (gnus-server-opened method)
(eq (nth 1 elem) 'ok))
"(opened)"
"(closed)")
((error) "(error)")))))
(gnus-tmp-agent (if (and gnus-agent
(gnus-agent-method-p method))
" (agent)"
"")))
(beginning-of-line)
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
;; Insert the text.
(eval gnus-server-line-format-spec))
(list 'gnus-server (intern gnus-tmp-name)))))
(list 'gnus-server (intern gnus-tmp-name)
'gnus-named-server (intern (gnus-method-to-server method))))))
(defun gnus-enter-server-buffer ()
"Set up the server buffer."
@ -243,6 +345,12 @@ The following commands are available:
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
(and server (symbol-name server))))
(defun gnus-server-named-server ()
"Returns a server name that matches one of the names returned by
gnus-method-to-server."
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-named-server)))
(and server (symbol-name server))))
(defalias 'gnus-server-position-point 'gnus-goto-colon)
(defconst gnus-server-edit-buffer "*Gnus edit server*")
@ -257,7 +365,7 @@ The following commands are available:
(when entry
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
(prin1-to-string (cdr entry)) ")\n")))
(gnus-prin1-to-string (cdr entry)) ")\n")))
(when (or entry oentry)
;; Buffer may be narrowed.
(save-restriction
@ -276,9 +384,13 @@ The following commands are available:
(when (and server info)
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
(prin1-to-string info) ")"))
(gnus-prin1-to-string info) ")"))
(let* ((server (nth 1 info))
(entry (assoc server gnus-server-alist)))
(entry (assoc server gnus-server-alist))
(cached (assoc server gnus-server-method-cache)))
(if cached
(setq gnus-server-method-cache
(delq cached gnus-server-method-cache)))
(if entry (setcdr entry info)
(setq gnus-server-alist
(nconc gnus-server-alist (list (cons server info))))))))
@ -330,7 +442,7 @@ The following commands are available:
(setq alist (cdr alist)))
(if alist
(setcdr alist (cons killed (cdr alist)))
(setq gnus-server-alist (list killed)))))
(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)))
@ -339,7 +451,7 @@ The following commands are available:
"Return to the group buffer."
(interactive)
(gnus-run-hooks 'gnus-server-exit-hook)
(kill-buffer (current-buffer))
(gnus-kill-buffer (current-buffer))
(gnus-configure-windows 'group t))
(defun gnus-server-list-servers ()
@ -396,12 +508,23 @@ The following commands are available:
(gnus-server-update-server server)
(gnus-server-position-point))))
(defun gnus-server-offline-server (server)
"Set SERVER to offline."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(unless method
(error "No such server: %s" server))
(prog1
(gnus-close-server method)
(gnus-server-set-status method 'offline)
(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))))))
(dolist (server gnus-inserted-opened-servers)
(gnus-server-close-server (car server))))
(defun gnus-server-deny-server (server)
"Make sure SERVER will never be attempted opened."
@ -417,11 +540,9 @@ The following commands are available:
(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))))
(dolist (server gnus-opened-servers)
(when (eq (nth 1 server) 'denied)
(setcar (nthcdr 1 server) 'closed)))
(gnus-server-list-servers))
(defun gnus-server-copy-server (from to)
@ -491,6 +612,12 @@ The following commands are available:
(gnus-request-scan nil method)
(gnus-message 3 "Scanning %s...done" server))))
(defun gnus-server-read-server-in-server-buffer (server)
"Browse a server in server buffer."
(interactive (list (gnus-server-server-name)))
(let (gnus-server-browse-in-group-buffer)
(gnus-server-read-server server)))
(defun gnus-server-read-server (server)
"Browse a server."
(interactive (list (gnus-server-server-name)))
@ -541,6 +668,7 @@ The following commands are available:
"L" gnus-browse-exit
"q" gnus-browse-exit
"Q" gnus-browse-exit
"d" gnus-browse-describe-group
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
@ -556,6 +684,7 @@ The following commands are available:
["Subscribe" gnus-browse-unsubscribe-current-group t]
["Read" gnus-browse-read-group t]
["Select" gnus-browse-select-group t]
["Describe" gnus-browse-describe-group t]
["Next" gnus-browse-next-group t]
["Prev" gnus-browse-prev-group t]
["Exit" gnus-browse-exit t]))
@ -571,6 +700,7 @@ The following commands are available:
(setq gnus-browse-current-method (gnus-server-to-method server))
(setq gnus-browse-return-buffer return-buffer)
(let* ((method gnus-browse-current-method)
(orig-select-method gnus-select-method)
(gnus-select-method method)
groups group)
(gnus-message 5 "Connecting to %s..." (nth 1 method))
@ -589,58 +719,97 @@ The following commands are available:
1 "Couldn't request list: %s" (gnus-status-message method))
nil)
(t
(gnus-get-buffer-create gnus-browse-buffer)
(when gnus-carpal
(gnus-carpal-setup-buffer 'browse))
(gnus-configure-windows 'browse)
(buffer-disable-undo)
(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)
(with-current-buffer nntp-server-buffer
(let ((cur (current-buffer)))
(goto-char (point-min))
(unless (string= gnus-ignored-newsgroups "")
(delete-matching-lines gnus-ignored-newsgroups))
(while (not (eobp))
(ignore-errors
(push (cons
(if (eq (char-after) ?\")
(read cur)
(let ((p (point)) (name ""))
(skip-chars-forward "^ \t\\\\")
(setq name (buffer-substring p (point)))
(while (eq (char-after) ?\\)
(setq p (1+ (point)))
(forward-char 2)
;; We treat NNTP as a special case to avoid problems with
;; garbage group names like `"foo' that appear in some badly
;; managed active files. -jh.
(if (eq (car method) 'nntp)
(while (not (eobp))
(ignore-errors
(push (cons
(buffer-substring
(point)
(progn
(skip-chars-forward "^ \t")
(point)))
(let ((last (read cur)))
(cons (read cur) last)))
groups))
(forward-line))
(while (not (eobp))
(ignore-errors
(push (cons
(if (eq (char-after) ?\")
(read cur)
(let ((p (point)) (name ""))
(skip-chars-forward "^ \t\\\\")
(setq name (concat name (buffer-substring
p (point)))))
name))
(max 0 (- (1+ (read cur)) (read cur))))
groups))
(forward-line))))
(setq name (buffer-substring p (point)))
(while (eq (char-after) ?\\)
(setq p (1+ (point)))
(forward-char 2)
(skip-chars-forward "^ \t\\\\")
(setq name (concat name (buffer-substring
p (point)))))
name))
(let ((last (read cur)))
(cons (read cur) last)))
groups))
(forward-line)))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
(let ((buffer-read-only nil) charset)
(while groups
(setq group (car groups))
(setq charset (gnus-group-name-charset method group))
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(insert
(format "K%7d: %s\n" (cdr group)
(gnus-group-name-decode (car group) charset))))
(list 'gnus-group (car group)))
(setq groups (cdr groups))))
(switch-to-buffer (current-buffer))
(if gnus-server-browse-in-group-buffer
(let* ((gnus-select-method orig-select-method)
(gnus-group-listed-groups
(mapcar (lambda (group)
(let ((name
(gnus-group-prefixed-name
(car group) method)))
(gnus-set-active name (cdr group))
name))
groups)))
(gnus-configure-windows 'group)
(funcall gnus-group-prepare-function
gnus-level-killed 'ignore 1 'ignore))
(gnus-get-buffer-create gnus-browse-buffer)
(when gnus-carpal
(gnus-carpal-setup-buffer 'browse))
(gnus-configure-windows 'browse)
(buffer-disable-undo)
(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))))
(let ((buffer-read-only nil)
name
(prefix (let ((gnus-select-method orig-select-method))
(gnus-group-prefixed-name "" method))))
(while (setq group (pop groups))
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(insert
(format "%c%7d: %s\n"
(let ((level (gnus-group-level
(concat prefix (setq name (car group))))))
(cond
((<= level gnus-level-subscribed) ? )
((<= level gnus-level-unsubscribed) ?U)
((= level gnus-level-zombie) ?Z)
(t ?K)))
(max 0 (- (1+ (cddr group)) (cadr group)))
(mm-decode-coding-string
name
(inline (gnus-group-name-charset method name))))))
(list 'gnus-group name))))
(switch-to-buffer (current-buffer)))
(goto-char (point-min))
(gnus-group-position-point)
(gnus-message 5 "Connecting to %s...done" (nth 1 method))
@ -683,7 +852,7 @@ buffer.
(if (or (not (gnus-get-info group))
(gnus-ephemeral-group-p group))
(unless (gnus-group-read-ephemeral-group
(gnus-group-real-name group) gnus-browse-current-method nil
group gnus-browse-current-method nil
(cons (current-buffer) 'browse))
(error "Couldn't enter %s" group))
(unless (gnus-group-read-group nil no-article group)
@ -728,10 +897,14 @@ buffer.
(beginning-of-line)
(let ((name (get-text-property (point) 'gnus-group)))
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
(gnus-group-prefixed-name
(or name
(match-string-no-properties 1))
gnus-browse-current-method)))))
(concat (gnus-method-to-server-name gnus-browse-current-method) ":"
(or name
(match-string-no-properties 1)))))))
(defun gnus-browse-describe-group (group)
"Describe the current group."
(interactive (list (gnus-browse-group-name)))
(gnus-group-describe-group nil group))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
@ -741,13 +914,11 @@ buffer.
(save-excursion
(beginning-of-line)
;; If this group it killed, then we want to subscribe it.
(when (eq (char-after) ?K)
(unless (eq (char-after) ? )
(setq sub t))
(setq group (gnus-browse-group-name))
(when (and sub
(cadr (gnus-gethash group gnus-newsrc-hashtb)))
(error "Group already subscribed"))
(delete-char 1)
(when (gnus-server-equal gnus-browse-current-method "native")
(setq group (gnus-group-real-name group)))
(if sub
(progn
;; Make sure the group has been properly removed before we
@ -760,22 +931,24 @@ buffer.
nil
(gnus-method-simplify
gnus-browse-current-method)))
gnus-level-default-subscribed gnus-level-killed
gnus-level-default-subscribed (gnus-group-level group)
(and (car (nth 1 gnus-newsrc-alist))
(gnus-gethash (car (nth 1 gnus-newsrc-alist))
gnus-newsrc-hashtb))
t)
(delete-char 1)
(insert ? ))
(gnus-group-change-level
group gnus-level-killed gnus-level-default-subscribed)
(insert ?K)))
group gnus-level-unsubscribed gnus-level-default-subscribed)
(delete-char 1)
(insert ?U)))
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)))
(gnus-kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
(save-excursion
(set-buffer gnus-group-buffer)
@ -796,15 +969,17 @@ buffer.
(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)))))
(condition-case ()
(gnus-get-function (gnus-server-to-method server)
'request-regenerate)
(error
(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)

752
lisp/gnus/gnus-start.el
View File

File diff suppressed because it is too large Load Diff

5120
lisp/gnus/gnus-sum.el
View File

File diff suppressed because it is too large Load Diff

327
lisp/gnus/gnus-topic.el
View File

@ -1,5 +1,5 @@
;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Ilja Weis <kult@uni-paderborn.de>
@ -46,6 +46,9 @@
:type 'hook
:group 'gnus-topic)
(when (featurep 'xemacs)
(add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add))
(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,
@ -57,7 +60,10 @@ with some simple extensions.
%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.
"
General format specifiers can also be used.
See Info node `(gnus)Formatting Variables'."
:link '(custom-manual "(gnus)Formatting Variables")
:type 'string
:group 'gnus-topic)
@ -161,6 +167,7 @@ with some simple extensions.
(mapcar 'list (gnus-topic-list))
nil t)))
(dolist (topic (gnus-current-topics topic))
(gnus-topic-goto-topic topic)
(gnus-topic-fold t))
(gnus-topic-goto-topic topic))
@ -196,7 +203,7 @@ If TOPIC, start with that topic."
"Return entries for all visible groups in TOPIC.
If RECURSIVE is t, return groups in its subtopics too."
(let ((groups (cdr (assoc topic gnus-topic-alist)))
info clevel unread group params visible-groups entry active)
info clevel unread group params visible-groups entry active)
(setq lowest (or lowest 1))
(setq level (or level gnus-level-unsubscribed))
;; We go through the newsrc to look for matches.
@ -245,6 +252,28 @@ If RECURSIVE is t, return groups in its subtopics too."
(cdr recursive)))
visible-groups))
(defun gnus-topic-goto-previous-topic (n)
"Go to the N'th previous topic."
(interactive "p")
(gnus-topic-goto-next-topic (- n)))
(defun gnus-topic-goto-next-topic (n)
"Go to the N'th next topic."
(interactive "p")
(let ((backward (< n 0))
(n (abs n))
(topic (gnus-current-topic)))
(while (and (> n 0)
(setq topic
(if backward
(gnus-topic-previous-topic topic)
(gnus-topic-next-topic topic))))
(gnus-topic-goto-topic topic)
(setq n (1- n)))
(when (/= 0 n)
(gnus-message 7 "No more topics"))
n))
(defun gnus-topic-previous-topic (topic)
"Return the previous topic on the same level as TOPIC."
(let ((top (cddr (gnus-topic-find-topology
@ -351,9 +380,17 @@ If RECURSIVE is t, return groups in its subtopics too."
"Compute the group parameters for GROUP taking into account inheritance from topics."
(let ((params-list (copy-sequence (gnus-group-get-parameter group))))
(save-excursion
(gnus-group-goto-group group)
(nconc params-list
(gnus-topic-hierarchical-parameters (gnus-current-topic))))))
(gnus-topic-hierarchical-parameters
;; First we try to go to the group within the group
;; buffer and find the topic for the group that way.
;; This hopefully copes well with groups that are in
;; more than one topic. Failing that (i.e. when the
;; group isn't visible in the group buffer) we find a
;; topic for the group via gnus-group-topic.
(or (and (gnus-group-goto-group group)
(gnus-current-topic))
(gnus-group-topic group)))))))
(defun gnus-topic-hierarchical-parameters (topic)
"Return a topic list computed for TOPIC."
@ -384,16 +421,22 @@ If RECURSIVE is t, return groups in its subtopics too."
;;; Generating group buffers
(defun gnus-group-prepare-topics (level &optional all lowest
(defun gnus-group-prepare-topics (level &optional predicate lowest
regexp list-topic topic-level)
"List all newsgroups with unread articles of level LEVEL or lower.
Use the `gnus-group-topics' to sort the groups.
If ALL is non-nil, list groups that have no unread articles.
If PREDICTE is a function, list groups that the function returns non-nil;
if it is t, 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)))
(lowest (or lowest 1))
(not-in-list
(and gnus-group-listed-groups
(copy-sequence gnus-group-listed-groups))))
(gnus-update-format-specifications nil 'topic)
(when (or (not gnus-topic-alist)
(not gnus-topology-checked-p))
(gnus-topic-check-topology))
@ -402,48 +445,63 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(erase-buffer))
;; List dead groups?
(when (and (>= level gnus-level-zombie)
(<= lowest gnus-level-zombie))
(when (or gnus-group-listed-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))
(when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
(when (or gnus-group-listed-groups
(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-level-killed ?K regexp)
(when not-in-list
(unless gnus-killed-hashtb
(gnus-make-hashtable-from-killed))
(gnus-group-prepare-flat-list-dead
(gnus-remove-if (lambda (group)
(or (gnus-gethash group gnus-newsrc-hashtb)
(gnus-gethash group gnus-killed-hashtb)))
not-in-list)
gnus-level-killed ?K regexp)))
;; Use topics.
(prog1
(when (< lowest gnus-level-zombie)
(when (or (< lowest gnus-level-zombie)
gnus-group-listed-groups)
(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))
(or topic-level level) predicate
nil lowest regexp))
(gnus-topic-prepare-topic gnus-topic-topology 0
(or topic-level level) all
nil lowest)))
(or topic-level level) predicate
nil lowest regexp)))
(gnus-group-set-mode-line)
(setq gnus-group-list-mode (cons level all))
(setq gnus-group-list-mode (cons level predicate))
(gnus-run-hooks 'gnus-group-prepare-hook))))
(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent
lowest)
(defun gnus-topic-prepare-topic (topicl level &optional list-level
predicate silent
lowest regexp)
"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
(or all
(car type)
(if gnus-group-listed-groups
gnus-level-killed
list-level)
(or predicate gnus-group-listed-groups
(cdr (assq 'visible
(gnus-topic-hierarchical-parameters
(car type)))))
lowest))
(if gnus-group-listed-groups 0 lowest)))
(visiblep (and (eq (nth 1 type) 'visible) (not silent)))
(gnus-group-indentation
(make-string (* gnus-topic-indent-level level) ? ))
@ -458,32 +516,61 @@ articles in the topic and its subtopics."
(while topicl
(incf unread
(gnus-topic-prepare-topic
(pop topicl) (1+ level) list-level all
(not visiblep) lowest)))
(pop topicl) (1+ level) list-level predicate
(not visiblep) lowest regexp)))
(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)
gnus-level-zombie gnus-level-killed)
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)))
(when (if (stringp entry)
(gnus-group-prepare-logic
entry
(and
(or (not gnus-group-listed-groups)
(if (< list-level gnus-level-zombie) nil
(let ((entry-level
(if (member entry gnus-zombie-list)
gnus-level-zombie gnus-level-killed)))
(and (<= entry-level list-level)
(>= entry-level lowest)))))
(cond
((stringp regexp)
(string-match regexp entry))
((functionp regexp)
(funcall regexp entry))
((null regexp) t)
(t nil))))
(setq info (nth 2 entry))
(gnus-group-prepare-logic
(gnus-info-group info)
(and (or (not gnus-group-listed-groups)
(let ((entry-level (gnus-info-level info)))
(and (<= entry-level list-level)
(>= entry-level lowest))))
(or (not (functionp predicate))
(funcall predicate info))
(or (not (stringp regexp))
(string-match regexp (gnus-info-group info))))))
(when visiblep
(if (stringp entry)
;; Dead groups.
(gnus-group-insert-group-line
entry (if (member entry gnus-zombie-list)
gnus-level-zombie gnus-level-killed)
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)
@ -593,7 +680,7 @@ articles in the topic and its subtopics."
(when (and (eq major-mode 'gnus-group-mode)
gnus-topic-mode)
(let ((group (gnus-group-group-name))
(m (point-marker))
(m (point-marker))
(buffer-read-only nil))
(when (and group
(gnus-get-info group)
@ -611,7 +698,8 @@ articles in the topic and its subtopics."
(unfound t)
entry)
;; Try to jump to a visible group.
(while (and g (not (gnus-group-goto-group (car g) t)))
(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)
@ -623,20 +711,31 @@ articles in the topic and its subtopics."
(when (and unfound
topic
(not (gnus-topic-goto-missing-topic topic)))
(let* ((top (gnus-topic-find-topology topic))
(children (cddr top))
(type (cadr top))
(unread 0)
(entries (gnus-topic-find-groups
(car type) (car gnus-group-list-mode)
(cdr gnus-group-list-mode))))
(while children
(incf unread (gnus-topic-unread (caar (pop children)))))
(while (setq entry (pop entries))
(when (numberp (car entry))
(incf unread (car entry))))
(gnus-topic-insert-topic-line
topic t t (car (gnus-topic-find-topology topic)) nil unread))))))
(gnus-topic-display-missing-topic topic)))))
(defun gnus-topic-display-missing-topic (topic)
"Insert topic lines recursively for missing topics."
(let ((parent (gnus-topic-find-topology
(gnus-topic-parent-topic topic))))
(when (and parent
(not (gnus-topic-goto-missing-topic (caadr parent))))
(gnus-topic-display-missing-topic (caadr parent))))
(gnus-topic-goto-missing-topic topic)
(let* ((top (gnus-topic-find-topology topic))
(children (cddr top))
(type (cadr top))
(unread 0)
(entries (gnus-topic-find-groups
(car type) (car gnus-group-list-mode)
(cdr gnus-group-list-mode)))
entry)
(while children
(incf unread (gnus-topic-unread (caar (pop children)))))
(while (setq entry (pop entries))
(when (numberp (car entry))
(incf unread (car entry))))
(gnus-topic-insert-topic-line
topic t t (car (gnus-topic-find-topology topic)) nil unread)))
(defun gnus-topic-goto-missing-topic (topic)
(if (gnus-topic-goto-topic topic)
@ -830,8 +929,8 @@ articles in the topic and its subtopics."
? ))
(yanked (list group))
alist talist end)
;; Then we enter the yanked groups into the topics they belong
;; to.
;; Then we enter the yanked groups into the topics
;; they belong to.
(when (setq alist (assoc (save-excursion
(forward-line -1)
(or
@ -949,6 +1048,7 @@ articles in the topic and its subtopics."
"\r" gnus-topic-select-group
" " gnus-topic-read-group
"\C-c\C-x" gnus-topic-expire-articles
"c" gnus-topic-catchup-articles
"\C-k" gnus-topic-kill-group
"\C-y" gnus-topic-yank-group
"\M-g" gnus-topic-get-new-news-this-topic
@ -975,6 +1075,8 @@ articles in the topic and its subtopics."
"j" gnus-topic-jump-to-topic
"M" gnus-topic-move-matching
"C" gnus-topic-copy-matching
"\M-p" gnus-topic-goto-previous-topic
"\M-n" gnus-topic-goto-next-topic
"\C-i" gnus-topic-indent
[tab] gnus-topic-indent
"r" gnus-topic-rename
@ -987,6 +1089,7 @@ articles in the topic and its subtopics."
"a" gnus-topic-sort-groups-by-alphabet
"u" gnus-topic-sort-groups-by-unread
"l" gnus-topic-sort-groups-by-level
"e" gnus-topic-sort-groups-by-server
"v" gnus-topic-sort-groups-by-score
"r" gnus-topic-sort-groups-by-rank
"m" gnus-topic-sort-groups-by-method))
@ -998,21 +1101,23 @@ articles in the topic and its subtopics."
'("Topics"
["Toggle topics" gnus-topic-mode t]
("Groups"
["Copy" gnus-topic-copy-group t]
["Move" gnus-topic-move-group t]
["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])
["Copy matching..." gnus-topic-copy-matching t]
["Move matching..." gnus-topic-move-matching t])
("Topics"
["Goto" gnus-topic-jump-to-topic t]
["Goto..." gnus-topic-jump-to-topic t]
["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]
["Rename..." gnus-topic-rename t]
["Create..." gnus-topic-create-topic t]
["Mark" gnus-topic-mark-topic t]
["Indent" gnus-topic-indent t]
["Sort" gnus-topic-sort-topics t]
["Previous topic" gnus-topic-goto-previous-topic t]
["Next topic" gnus-topic-goto-next-topic 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]))))
@ -1027,7 +1132,7 @@ articles in the topic and its subtopics."
(> (prefix-numeric-value arg) 0)))
;; Infest Gnus with topics.
(if (not gnus-topic-mode)
(setq gnus-goto-missing-group-function nil)
(setq gnus-goto-missing-group-function nil)
(when (gnus-visual-p 'topic-menu 'menu)
(gnus-topic-make-menu-bar))
(gnus-set-format 'topic t)
@ -1050,8 +1155,9 @@ articles in the topic and its subtopics."
'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)
(gnus-make-local-hook 'gnus-check-bogus-groups-hook)
(add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist
nil 'local)
(setq gnus-topology-checked-p nil)
;; We check the topology.
(when gnus-newsrc-alist
@ -1070,11 +1176,14 @@ articles in the topic and its subtopics."
(defun gnus-topic-select-group (&optional all)
"Select this newsgroup.
No article is selected automatically.
If the group is opened, just switch the summary buffer.
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")
(when (and (eobp) (not (gnus-group-group-name)))
(forward-line -1))
(if (gnus-group-topic-p)
(let ((gnus-group-list-mode
(if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
@ -1097,10 +1206,27 @@ If performed over a topic line, toggle folding the topic."
(gnus-message 5 "Expiring groups in %s..." topic)
(let ((gnus-group-marked
(mapcar (lambda (entry) (car (nth 2 entry)))
(gnus-topic-find-groups topic gnus-level-killed t))))
(gnus-topic-find-groups topic gnus-level-killed t
nil t))))
(gnus-group-expire-articles nil))
(gnus-message 5 "Expiring groups in %s...done" topic))))
(defun gnus-topic-catchup-articles (topic)
"Catchup this topic or group.
Also see `gnus-group-catchup'."
(interactive (list (gnus-group-topic-name)))
(if (not topic)
(call-interactively 'gnus-group-catchup-current)
(save-excursion
(let* ((groups
(mapcar (lambda (entry) (car (nth 2 entry)))
(gnus-topic-find-groups topic gnus-level-killed t
nil t)))
(buffer-read-only nil)
(gnus-group-marked groups))
(gnus-group-catchup-current)
(mapcar 'gnus-topic-update-topics-containing-group groups)))))
(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
@ -1157,7 +1283,8 @@ When used interactively, PARENT will be the topic under point."
If COPYP, copy the groups instead."
(interactive
(list current-prefix-arg
(completing-read "Move to topic: " gnus-topic-alist nil t)))
(gnus-completing-read "Move to topic" gnus-topic-alist nil t
'gnus-topic-history)))
(let ((use-marked (and (not n) (not (gnus-region-active-p))
gnus-group-marked t))
(groups (gnus-group-process-prefix n))
@ -1303,9 +1430,9 @@ If PERMANENT, make it stay shown in subsequent sessions as well."
(setcar (cdr (cadr topic)) 'visible)
(gnus-group-list-groups)))))
(defun gnus-topic-mark-topic (topic &optional unmark recursive)
(defun gnus-topic-mark-topic (topic &optional unmark non-recursive)
"Mark all groups in the TOPIC with the process mark.
If RECURSIVE is t, mark its subtopics too."
If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics."
(interactive (list (gnus-group-topic-name)
nil
(and current-prefix-arg t)))
@ -1313,28 +1440,32 @@ If RECURSIVE is t, mark its subtopics too."
(call-interactively 'gnus-group-mark-group)
(save-excursion
(let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil
recursive)))
(not non-recursive))))
(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 dummy recursive)
(defun gnus-topic-unmark-topic (topic &optional dummy non-recursive)
"Remove the process mark from all groups in the TOPIC.
If RECURSIVE is t, unmark its subtopics too."
If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(interactive (list (gnus-group-topic-name)
nil
(and current-prefix-arg t)))
(if (not topic)
(call-interactively 'gnus-group-unmark-group)
(gnus-topic-mark-topic topic t recursive)))
(gnus-topic-mark-topic topic t non-recursive)))
(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) nil (and n t))
(gnus-group-get-new-news-this-group)))
(let* ((topic (gnus-group-topic-name))
(data (cadr (gnus-topic-find-topology topic))))
(save-excursion
(gnus-topic-mark-topic topic nil (and n t))
(gnus-group-get-new-news-this-group))
(gnus-topic-remove-topic (eq 'visible (cadr data))))))
(defun gnus-topic-move-matching (regexp topic &optional copyp)
"Move all groups that match REGEXP to some topic."
@ -1380,7 +1511,7 @@ If RECURSIVE is t, unmark its subtopics too."
(interactive
(let ((topic (gnus-current-topic)))
(list topic
(read-string (format "Rename %s to: " topic)))))
(read-string (format "Rename %s to: " topic) topic))))
;; Check whether the new name exists.
(when (gnus-topic-find-topology new-name)
(error "Topic '%s' already exists" new-name))
@ -1552,14 +1683,21 @@ If REVERSE, sort in reverse order."
(interactive "P")
(gnus-topic-sort-groups 'gnus-group-sort-by-method reverse))
(defun gnus-topic-sort-groups-by-server (&optional reverse)
"Sort the current topic alphabetically by server name.
If REVERSE, sort in reverse order."
(interactive "P")
(gnus-topic-sort-groups 'gnus-group-sort-by-server reverse))
(defun gnus-topic-sort-topics-1 (top reverse)
(if (cdr top)
(let ((subtop
(mapcar `(lambda (top)
(gnus-topic-sort-topics-1 top ,reverse))
(mapcar (gnus-byte-compile
`(lambda (top)
(gnus-topic-sort-topics-1 top ,reverse)))
(sort (cdr top)
'(lambda (t1 t2)
(string-lessp (caar t1) (caar t2)))))))
(lambda (t1 t2)
(string-lessp (caar t1) (caar t2)))))))
(setcdr top (if reverse (reverse subtop) subtop))))
top)
@ -1612,7 +1750,14 @@ If REVERSE, reverse the sorting order."
(gnus-subscribe-alphabetically newsgroup)
;; Add the group to the topic.
(nconc (assoc topic gnus-topic-alist) (list newsgroup))
(throw 'end t))))))
;; if this topic specifies a default level, use it
(let ((subscribe-level (cdr (assq 'subscribe-level
(gnus-topic-parameters topic)))))
(when subscribe-level
(gnus-group-change-level newsgroup subscribe-level
gnus-level-default-subscribed)))
(throw 'end t)))
nil)))
(provide 'gnus-topic)

4
lisp/gnus/gnus-undo.el
View File

@ -1,6 +1,6 @@
;;; gnus-undo.el --- minor mode for undoing in Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -114,7 +114,7 @@
(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)
(gnus-make-local-hook 'post-command-hook)
(add-hook 'post-command-hook 'gnus-undo-boundary nil t)
(gnus-run-hooks 'gnus-undo-mode-hook)))

916
lisp/gnus/gnus-util.el
View File

File diff suppressed because it is too large Load Diff

257
lisp/gnus/gnus-uu.el
View File

@ -1,6 +1,6 @@
;;; gnus-uu.el --- extract (uu)encoded files in Gnus
;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 2000,
;; 2001 Free Software Foundation, Inc.
;; 2001, 2002, 2003 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Created: 2 Oct 1993
@ -299,7 +299,8 @@ so I simply dropped them."
"^MIME-Version:" "^Content-Disposition:" "^Content-Description:"
"^Content-ID:")
"*List of regexps to match headers included in digested messages.
The headers will be included in the sequence they are matched."
The headers will be included in the sequence they are matched. If nil
include all headers."
:group 'gnus-extract
:type '(repeat regexp))
@ -321,7 +322,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defvar gnus-uu-saved-article-name nil)
(defvar gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$")
(defvar gnus-uu-begin-string "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+\\(.*\\)$")
(defvar gnus-uu-end-string "^end[ \t]*$")
(defvar gnus-uu-body-line "^M")
@ -336,7 +337,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defvar gnus-uu-shar-file-name nil)
(defvar gnus-uu-shar-name-marker
"begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)")
"begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)")
(defvar gnus-uu-postscript-begin-string "^%!PS-")
(defvar gnus-uu-postscript-end-string "^%%EOF$")
@ -353,56 +354,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defvar gnus-uu-digest-from-subject nil)
(defvar gnus-uu-digest-buffer 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
"g" gnus-uu-unmark-region
"R" gnus-uu-mark-by-regexp
"G" gnus-uu-unmark-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-summary-save-parts
"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)
@ -529,43 +480,44 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(if (and n (not (numberp n)))
(setq message-forward-as-mime (not message-forward-as-mime)
n nil))
(gnus-setup-message 'forward
(setq gnus-uu-digest-from-subject nil)
(setq gnus-uu-digest-buffer
(gnus-get-buffer-create " *gnus-uu-forward*"))
(gnus-uu-decode-save n file)
(switch-to-buffer gnus-uu-digest-buffer)
(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))
(let ((message-forward-decoded-p t))
(message-forward post t)))
(let ((gnus-article-reply (gnus-summary-work-articles n)))
(gnus-setup-message 'forward
(setq gnus-uu-digest-from-subject nil)
(setq gnus-uu-digest-buffer
(gnus-get-buffer-create " *gnus-uu-forward*"))
(gnus-uu-decode-save n file)
(switch-to-buffer gnus-uu-digest-buffer)
(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))
(let ((message-forward-decoded-p t))
(message-forward post t))))
(setq gnus-uu-digest-from-subject nil)))
(defun gnus-uu-digest-post-forward (&optional n)
@ -575,17 +527,40 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
;; Process marking.
(defun gnus-message-process-mark (unmarkp new-marked)
(let ((old (- (length gnus-newsgroup-processable) (length new-marked))))
(message "%d mark%s %s%s"
(length new-marked)
(if (= (length new-marked) 1) "" "s")
(if unmarkp "removed" "added")
(cond
((and (zerop old)
(not unmarkp))
"")
(unmarkp
(format ", %d remain marked"
(length gnus-newsgroup-processable)))
(t
(format ", %d already marked" old))))))
(defun gnus-new-processable (unmarkp articles)
(if unmarkp
(gnus-intersection gnus-newsgroup-processable articles)
(gnus-set-difference articles gnus-newsgroup-processable)))
(defun gnus-uu-mark-by-regexp (regexp &optional unmark)
"Set the process mark on articles whose subjects match REGEXP.
When called interactively, prompt for REGEXP.
Optional UNMARK non-nil means unmark instead of mark."
(interactive "sMark (regexp): \nP")
(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 ""))
(save-excursion
(let* ((articles (gnus-uu-find-articles-matching regexp))
(new-marked (gnus-new-processable unmark articles)))
(while articles
(if unmark
(gnus-summary-remove-process-mark (pop articles))
(gnus-summary-set-process-mark (pop articles))))
(gnus-message-process-mark unmark new-marked)))
(gnus-summary-position-point))
(defun gnus-uu-unmark-by-regexp (regexp)
@ -597,11 +572,12 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-mark-series ()
"Mark the current series with the process mark."
(interactive)
(let ((articles (gnus-uu-find-articles-matching)))
(let* ((articles (gnus-uu-find-articles-matching))
(l (length articles)))
(while articles
(gnus-summary-set-process-mark (car articles))
(setq articles (cdr articles)))
(message ""))
(message "Marked %d articles" l))
(gnus-summary-position-point))
(defun gnus-uu-mark-region (beg end &optional unmark)
@ -862,9 +838,7 @@ When called interactively, prompt for REGEXP."
"Date: %s\nFrom: %s\nSubject: %s Digest\n\n"
(current-time-string) name name))
(when (and message-forward-as-mime gnus-uu-digest-buffer)
;; The default part in multipart/digest is message/rfc822.
;; Subject is a fake head.
(insert "<#part type=text/plain>\nSubject: Topics\n\n"))
(insert "<#part type=message/rfc822>\nSubject: Topics\n\n"))
(insert "Topics:\n")))
(when (not (eq in-state 'end))
(setq state (list 'middle))))
@ -896,7 +870,7 @@ When called interactively, prompt for REGEXP."
(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)))
(setq sorthead (buffer-string))
(while headers
(setq headline (car headers))
(setq headers (cdr headers))
@ -1116,7 +1090,7 @@ When called interactively, prompt for REGEXP."
(while (re-search-forward "[ \t]+" nil t)
(replace-match "[ \t]+" t t))
(buffer-substring (point-min) (point-max))))
(buffer-string)))
(defun gnus-uu-get-list-of-articles (n)
;; If N is non-nil, the article numbers of the N next articles
@ -1208,11 +1182,12 @@ When called interactively, prompt for REGEXP."
;; 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 (point-min) (point-max)))
(ignore-errors
(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))
@ -1377,27 +1352,27 @@ When called interactively, prompt for REGEXP."
(setq process-state (list 'error))
(gnus-message 2 "No begin part at the beginning")
(sleep-for 2))
(setq state 'middle)))
(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)))))
(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))))
;; The original article buffer is hosed, shoot it down.
(gnus-kill-buffer gnus-original-article-buffer)
(setq gnus-current-article nil)
result-files))
(defun gnus-uu-grab-view (file)
@ -1463,10 +1438,10 @@ When called interactively, prompt for REGEXP."
;; 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)
(gnus-map-function
mm-file-name-rewrite-functions
(file-name-nondirectory (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)
@ -1655,7 +1630,7 @@ Gnus might fail to display all of it.")
(gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path))
(if (= 0 (call-process shell-file-name nil
(if (eq 0 (call-process shell-file-name nil
(gnus-get-buffer-create gnus-uu-output-buffer-name)
nil shell-command-switch command))
(message "")
@ -1820,9 +1795,13 @@ Gnus might fail to display all of it.")
(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 ""))
(condition-case err
(delete-file file)
(error (gnus-message 3 "Deleting file %s failed... %s" file err))))))
(condition-case err
(delete-directory dir)
(error (gnus-message 3 "Deleting directory %s failed... %s" file err))))
(gnus-message 7 "")))
;; Initializing
@ -1900,7 +1879,7 @@ is t."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map (current-local-map))
(use-local-map map))
(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
;;(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)
@ -1933,8 +1912,8 @@ The user will be asked for a file name."
;; Encodes with base64 and adds MIME headers
(defun gnus-uu-post-encode-mime (path file-name)
(when (zerop (call-process shell-file-name nil t nil shell-command-switch
(format "%s %s -o %s" "mmencode" path file-name)))
(when (eq 0 (call-process shell-file-name nil t nil shell-command-switch
(format "%s %s -o %s" "mmencode" path file-name)))
(gnus-uu-post-make-mime file-name "base64")
t))
@ -1959,8 +1938,8 @@ The user will be asked for a file name."
;; 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))))
(eq 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.

2
lisp/gnus/gnus-vm.el
View File

@ -1,6 +1,6 @@
;;; gnus-vm.el --- vm interface for Gnus
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
;; Free Software Foundation, Inc.
;; Author: Per Persson <pp@gnu.ai.mit.edu>

69
lisp/gnus/gnus-win.el
View File

@ -1,5 +1,5 @@
;;; gnus-win.el --- window configuration functions for Gnus
;; Copyright (C) 1996, 97, 98, 1999, 2000, 02, 2004
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -29,6 +29,7 @@
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-util)
(defgroup gnus-windows nil
"Window configuration."
@ -57,6 +58,13 @@
:group 'gnus-windows
:type 'boolean)
(defcustom gnus-use-frames-on-any-display nil
"*If non-nil, frames on all displays will be considered useable by Gnus.
When nil, only frames on the same display as the selected frame will be
used to display Gnus windows."
:group 'gnus-windows
:type 'boolean)
(defvar gnus-buffer-configuration
'((group
(vertical 1.0
@ -68,17 +76,6 @@
(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)
@ -126,7 +123,7 @@
(post 1.0 point)))
(reply
(vertical 1.0
(article-copy 0.5)
(article 0.5)
(message 1.0 point)))
(forward
(vertical 1.0
@ -165,7 +162,10 @@
(compose-bounce
(vertical 1.0
(article 0.5)
(message 1.0 point))))
(message 1.0 point)))
(display-term
(vertical 1.0
("*display*" 1.0))))
"Window configuration for all possible Gnus buffers.
See the Gnus manual for an explanation of the syntax used.")
@ -187,7 +187,6 @@ See the Gnus manual for an explanation of the syntax used.")
(mail . gnus-message-buffer)
(post-news . gnus-message-buffer)
(faq . gnus-faq-buffer)
(picons . gnus-picons-buffer-name)
(tree . gnus-tree-buffer)
(score-trace . "*Score Trace*")
(split-trace . "*Split Trace*")
@ -197,6 +196,11 @@ See the Gnus manual for an explanation of the syntax used.")
(draft . gnus-draft-buffer))
"Mapping from short symbols to buffer names or buffer variables.")
(defcustom gnus-configure-windows-hook nil
"*A hook called when configuring windows."
:group 'gnus-windows
:type 'hook)
;;; Internal variables.
(defvar gnus-current-window-configuration nil
@ -301,7 +305,7 @@ See the Gnus manual for an explanation of the syntax used.")
;; 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)))
(functionp (car split)))
(setq split (eval split)))
(let* ((type (car split))
(subs (cddr split))
@ -364,7 +368,7 @@ See the Gnus manual for an explanation of the syntax used.")
(while subs
(setq sub (append (pop subs) nil))
(while (and (not (assq (car sub) gnus-window-to-buffer))
(gnus-functionp (car sub)))
(functionp (car sub)))
(setq sub (eval sub)))
(when sub
(push sub comp-subs)
@ -447,7 +451,7 @@ See the Gnus manual for an explanation of the syntax used.")
;; 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
;; This is a `frame' split, so we delete all windows
;; on all frames.
(gnus-delete-windows-in-gnusey-frames))
;; Just remove some windows.
@ -462,6 +466,7 @@ See the Gnus manual for an explanation of the syntax used.")
(switch-to-buffer nntp-server-buffer)
(set-buffer nntp-server-buffer))
(gnus-configure-frame split)
(run-hooks 'gnus-configure-windows-hook)
(when gnus-window-frame-focus
(select-frame (window-frame gnus-window-frame-focus))))))))
@ -502,7 +507,7 @@ should have point."
;; 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)))
(functionp (car split)))
(setq split (eval split)))
(setq type (elt split 0))
@ -516,7 +521,7 @@ should have point."
(unless buffer
(error "Invalid buffer type: %s" type))
(if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
(setq win (get-buffer-window buf 0)))
(setq win (gnus-get-buffer-window buf t)))
(if (memq 'point split)
(setq all-visible win))
(setq all-visible nil)))
@ -548,7 +553,29 @@ should have point."
(if (featurep 'xemacs)
(switch-to-buffer nntp-server-buffer)
(set-buffer nntp-server-buffer)))
(mapcar (lambda (b) (delete-windows-on b t)) bufs))))
(mapcar (lambda (b) (delete-windows-on b t))
(delq lowest-buf bufs)))))
(eval-and-compile
(cond
((fboundp 'frames-on-display-list)
(defalias 'gnus-frames-on-display-list 'frames-on-display-list))
((and (featurep 'xemacs) (fboundp 'frame-device))
(defun gnus-frames-on-display-list ()
(apply 'filtered-frame-list 'identity (list (frame-device nil)))))
(t
(defalias 'gnus-frames-on-display-list 'frame-list))))
(defun gnus-get-buffer-window (buffer &optional frame)
(cond ((and (null gnus-use-frames-on-any-display)
(memq frame '(t 0 visible)))
(car
(let ((frames (gnus-frames-on-display-list)))
(gnus-remove-if (lambda (win) (not (memq (window-frame win)
frames)))
(get-buffer-window-list buffer nil frame)))))
(t
(get-buffer-window buffer frame))))
(provide 'gnus-win)

1794
lisp/gnus/gnus.el
View File

File diff suppressed because it is too large Load Diff

622
lisp/gnus/gnus.xbm Normal file
View File

@ -0,0 +1,622 @@
#define noname_width 271
#define noname_height 273
static char noname_bits[] = {
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x49,0xe0,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x97,0xaa,0x8a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x57,0x2a,0x41,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa9,0x52,0x16,0xfe,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0x49,0x05,
0xf9,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0x95,0xaa,0x58,0xf4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x7f,0xa5,0x54,0x26,0xe1,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x54,0x49,0x49,0xe4,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x2a,0xa5,
0x2a,0xd1,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xaf,0x52,0x95,0x54,0xc4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,
0x24,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x57,0x29,0xa9,0x92,0x11,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x57,0xd5,0xfa,0xff,0xff,0xab,0xea,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x4a,0x55,0x2a,0x41,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x25,0x29,0xe5,0xff,0xff,0x95,0xa4,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0xa4,
0x24,0xa5,0x14,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0xa5,0xd4,0xff,
0x3f,0x52,0xa9,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x29,0x55,0x55,0x55,0x41,0x7e,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xa9,0x54,0xea,0xff,0xdf,0x2a,0x55,0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x55,0x4a,0x49,0x12,0x7e,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0x55,0xa5,0x92,0xff,0x23,0xa5,0x4a,0xd6,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5,0xa4,0x94,0xaa,0x42,
0x7d,0xff,0xff,0xff,0xff,0xff,0xff,0x9f,0x4a,0x2a,0xa9,0xff,0xad,0x92,0x24,
0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a,
0x95,0x52,0x52,0x29,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x52,0x49,0x55,
0xfe,0x91,0x54,0x55,0x55,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0x49,0x29,0x55,0x25,0x85,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,
0x4f,0x95,0xaa,0x92,0x7e,0x55,0x55,0xa9,0x4a,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a,0x50,0x95,0xaa,0x24,0x7e,0xff,0xff,
0xff,0xff,0xff,0xff,0x57,0x2a,0x95,0x54,0x79,0x95,0x92,0x92,0x94,0xfc,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb9,0x62,0x29,0x49,
0x85,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x49,0x49,0x95,0xba,0xa4,0x54,
0xaa,0x52,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,
0x1a,0xf8,0xa7,0xaa,0x22,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x55,0x52,
0x2a,0x75,0x55,0xa5,0x24,0xa5,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xbf,0x5a,0xfd,0x57,0x92,0x94,0x7e,0xff,0xff,0xff,0xff,0xff,
0xff,0x4a,0x4a,0x55,0x49,0x89,0x92,0x94,0xaa,0x94,0xf4,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x1a,0xfc,0x2f,0x55,0x05,0x7c,0xff,
0xff,0xff,0xff,0xff,0xff,0x55,0xa9,0x4a,0x55,0x2a,0x55,0x55,0x55,0x55,0xe5,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x4e,0xfd,0x5f,
0x29,0xa5,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0xa4,0x54,0x52,0x4a,0x55,0xa9,
0xa4,0x24,0xa5,0x94,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x2f,0x1d,0xfe,0x3f,0x95,0x04,0x7c,0xff,0xfd,0xff,0xff,0xff,0x3f,0x49,0xa5,
0x54,0xa9,0xa4,0x92,0x4a,0x49,0x4a,0x55,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xaf,0x44,0xfe,0x5f,0xa9,0x52,0x7d,0xff,0xe5,0xff,0xff,
0xff,0x5f,0x55,0x92,0x2a,0x95,0x52,0x4a,0x52,0xaa,0x52,0x4a,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x16,0xff,0xbf,0x4a,0x05,0x7c,
0xff,0xd9,0xff,0xff,0xff,0x5f,0x95,0x42,0xa5,0x52,0x95,0xaa,0xaa,0xaa,0x94,
0x54,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x43,0xfe,
0xbf,0x54,0x52,0x7d,0x7f,0x25,0xff,0xff,0xff,0xa7,0xa4,0x28,0x92,0x54,0x4a,
0xa5,0x4a,0x92,0xaa,0x4a,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xab,0x12,0xfe,0x7f,0xa5,0x02,0x7c,0x7f,0x55,0xfd,0xff,0xff,0x95,0x2a,
0x82,0x54,0xa5,0x54,0x2a,0xa9,0x2a,0xa5,0x52,0xf5,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x27,0x4b,0xff,0xff,0x4a,0x29,0x7d,0xff,0x92,0xfe,
0xff,0xff,0x55,0x92,0x20,0xa8,0x94,0x2a,0xa5,0x94,0x52,0x29,0xa9,0xf4,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x01,0xff,0x7f,0x52,0x42,
0x7c,0xff,0x25,0xf9,0xff,0x7f,0xaa,0x02,0x8a,0x40,0x29,0x49,0x09,0x41,0x4a,
0x55,0x25,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x57,
0xff,0xff,0x95,0x12,0x7d,0xff,0xa9,0xfa,0xff,0x7f,0x25,0xa9,0x20,0x2a,0xa5,
0xaa,0x42,0x92,0x54,0x92,0x54,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xaf,0x83,0xff,0xff,0xa9,0x42,0x7e,0xff,0xaa,0xf4,0xff,0xaf,0x54,
0x01,0x82,0x80,0xaa,0x54,0x14,0x08,0xa2,0xaa,0x4a,0xd2,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xef,0xcf,0xd7,0xff,0xff,0x52,0x12,0x7f,0xff,0x4a,
0xea,0xff,0x57,0x92,0xaa,0x28,0x24,0x29,0x25,0x81,0x82,0x08,0x49,0x52,0x55,
0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xdf,0xef,0xe7,0xff,0xff,0x2a,
0x05,0x7e,0xff,0x55,0xd5,0xff,0xa5,0x2a,0x00,0x8e,0x10,0x4a,0x89,0x24,0x28,
0xa0,0xaa,0x2a,0x49,0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xe7,0xff,
0xef,0xff,0xff,0xa5,0x50,0x7e,0xff,0x25,0xe5,0xff,0x2a,0xa5,0x52,0x7f,0x85,
0x54,0x35,0x08,0x82,0x0a,0x55,0x95,0xaa,0xfc,0xff,0xff,0xff,0xcf,0xff,0xff,
0xff,0xff,0xd7,0xff,0xff,0xff,0x7f,0x52,0x85,0x7e,0xff,0xab,0x94,0x1e,0x55,
0x2a,0xc8,0xff,0x10,0x90,0x92,0xa0,0x08,0x20,0x24,0x52,0x25,0xfd,0xff,0xff,
0xff,0xef,0xff,0xff,0xff,0xff,0xe9,0xff,0xff,0xff,0xff,0x94,0x10,0x7e,0xff,
0x93,0xaa,0x6a,0x49,0x49,0xf2,0xff,0x85,0x52,0x09,0x0a,0xa2,0x4a,0x92,0x29,
0xa9,0xf2,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0x7f,
0x55,0x25,0x7f,0xff,0x55,0x49,0x49,0x95,0x0a,0xf9,0xff,0x17,0x48,0x26,0x50,
0x08,0x00,0xa9,0x4a,0x95,0xfa,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xf2,
0xff,0xff,0xff,0xff,0x92,0x80,0x7e,0xff,0xa7,0x54,0xaa,0xa4,0x52,0xfc,0xff,
0xaf,0x42,0x89,0xfa,0xbf,0x54,0x20,0xa9,0xa4,0xd4,0xff,0xff,0xff,0xcb,0xff,
0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff,0x54,0x29,0x7f,0xff,0x4b,0xa5,0x92,
0x2a,0x01,0xff,0xff,0x1f,0xa8,0x22,0xff,0xff,0x01,0xa5,0x2a,0x55,0xa9,0xff,
0xff,0xff,0xd4,0xff,0xff,0xff,0x7f,0xfa,0xff,0xff,0xff,0x7f,0xa5,0x04,0x7f,
0xff,0x57,0x2a,0x55,0xa9,0x54,0xfe,0xff,0x3f,0x05,0x89,0xff,0xff,0x5f,0x48,
0x92,0x2a,0x95,0xff,0xff,0xff,0xea,0xff,0xff,0xff,0xff,0xd2,0xff,0xff,0xff,
0x7f,0x2a,0x91,0x7f,0xff,0xa9,0x54,0x4a,0x52,0x02,0xff,0xff,0xff,0x50,0xd1,
0xff,0xff,0x1f,0x81,0xaa,0xa4,0x52,0xfe,0xff,0x3f,0xe9,0xff,0xff,0xff,0x7f,
0x1d,0xff,0xff,0xff,0xff,0x54,0x41,0x7f,0xff,0x93,0x92,0x52,0x95,0xc8,0xff,
0xff,0xff,0x8b,0xc4,0xff,0xff,0x7f,0x24,0xa5,0x2a,0x49,0xf9,0xff,0x7f,0xd5,
0xff,0xff,0xff,0xbf,0x4a,0xff,0xff,0xff,0xff,0x4a,0x14,0x7f,0xff,0x28,0xa5,
0x94,0x2a,0xa0,0xff,0xff,0x7f,0x22,0xf0,0xff,0xff,0x7f,0x12,0x94,0xa4,0xaa,
0xea,0xff,0xaf,0xea,0xff,0xff,0xff,0x5f,0x8e,0xff,0xff,0xff,0x7f,0xa9,0x40,
0x7f,0xff,0x48,0x55,0x55,0x12,0xca,0xff,0xff,0xff,0x0a,0xf5,0xff,0xff,0xff,
0x80,0x52,0x95,0x54,0xaa,0xfe,0x55,0xc4,0xff,0xff,0xff,0x5f,0xa5,0xff,0xff,
0xff,0xff,0x94,0x14,0x7f,0xff,0x52,0x2a,0xa9,0x4a,0xe1,0xff,0xff,0xbf,0x24,
0xf0,0xff,0xff,0xff,0x0b,0x28,0xa9,0x92,0x24,0x55,0x49,0xe5,0xd7,0xff,0xff,
0xa7,0x8a,0xff,0xff,0xff,0x7f,0xa5,0xc0,0x7f,0xff,0x50,0x49,0x95,0x04,0xf8,
0xff,0xff,0x5f,0x1f,0xfd,0xff,0xff,0xff,0x47,0x45,0x55,0xaa,0xaa,0x4a,0xaa,
0xea,0xaf,0xff,0xff,0x2b,0xc3,0xff,0xff,0xff,0x7f,0x55,0x94,0x7f,0x7f,0x4a,
0x55,0x52,0x51,0xfe,0xff,0xff,0x5f,0x4e,0xf8,0xff,0xff,0xff,0x1f,0x50,0x92,
0x52,0x49,0xa9,0x92,0xe4,0xd3,0xff,0xff,0x4b,0xd5,0xff,0xff,0xff,0xff,0x94,
0xc0,0x7f,0x3f,0xa0,0xa4,0xaa,0x04,0xfe,0xff,0xff,0xa7,0x1d,0xfd,0xff,0xff,
0xff,0x9f,0x84,0xaa,0x4a,0xaa,0x24,0x55,0xf2,0x2b,0xff,0x7f,0xa9,0xc1,0xff,
0xff,0xff,0x7f,0x4a,0x95,0x7f,0xbf,0x2a,0x95,0x24,0x50,0xff,0xff,0xff,0x97,
0x5e,0xfe,0xff,0xff,0xff,0x3f,0x92,0x24,0x95,0x92,0xaa,0xa4,0xf2,0xcb,0xff,
0x5f,0xd5,0xe5,0xff,0xff,0xff,0xff,0x52,0x80,0x7f,0x3f,0xa0,0x52,0x15,0x85,
0xff,0xff,0xff,0xd7,0x38,0xfe,0xff,0xff,0xff,0xff,0x20,0xaa,0x52,0x55,0x55,
0x55,0xf9,0x29,0xfd,0xab,0xa4,0xf0,0xff,0xff,0xff,0x7f,0x29,0xa9,0x7f,0xff,
0x42,0x25,0x49,0xe8,0xff,0xff,0xff,0x69,0x7a,0xff,0xff,0xff,0xff,0xff,0x82,
0x52,0xaa,0x24,0x89,0x4a,0xf8,0x55,0x2a,0x49,0x95,0xf5,0xff,0xff,0xff,0xbf,
0x2a,0xc4,0x7f,0x7f,0x90,0x54,0x15,0xe2,0xff,0xff,0xff,0x25,0xbc,0xff,0xff,
0xff,0xff,0xff,0x29,0x48,0x49,0xaa,0xaa,0xa4,0xfa,0x95,0x92,0x54,0x52,0xf0,
0xff,0xff,0xff,0xbf,0x4a,0xd1,0x7f,0xff,0x05,0xaa,0x40,0xf8,0xff,0xff,0x7f,
0xaa,0xfc,0xff,0xff,0xff,0xff,0xff,0x43,0xa9,0xaa,0x4a,0x52,0xa9,0xf8,0xa4,
0xaa,0x52,0x95,0xfc,0xff,0xff,0xff,0x7f,0x52,0xc0,0x7f,0xff,0xa1,0x00,0x24,
0xfa,0xff,0xff,0xff,0x0a,0xfe,0xff,0xff,0xff,0xff,0xff,0x17,0x92,0x24,0xa5,
0x2a,0x55,0xfe,0xaa,0xa4,0x2a,0x29,0xf9,0xff,0xff,0xff,0xbf,0x2a,0xea,0x7f,
0xff,0x05,0x92,0x90,0xfc,0xff,0xff,0xbf,0xa4,0xff,0xff,0xff,0xff,0xff,0xff,
0x4f,0xa0,0xaa,0x54,0x49,0x25,0x7c,0x49,0x95,0xa4,0x12,0xfc,0xff,0xff,0xff,
0x7f,0x8a,0xe0,0x7f,0xff,0xa3,0x04,0x05,0xfe,0xff,0xff,0xbf,0x06,0xff,0xff,
0xff,0xff,0xff,0xff,0x1f,0x49,0x95,0x52,0xaa,0x12,0x7f,0x55,0x52,0x55,0x0a,
0xfd,0xff,0xff,0xff,0x3f,0x29,0xe8,0x7f,0xff,0x0f,0x50,0x50,0xff,0xff,0xff,
0x5f,0xca,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x04,0xa9,0x4a,0x25,0x45,0x3e,
0xa9,0x2a,0xa9,0xa2,0xfc,0xff,0xff,0xff,0x7f,0x55,0xe1,0x7f,0xff,0x27,0x05,
0xc4,0xff,0xff,0xff,0x9f,0x91,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x41,0x4a,
0x29,0xa9,0x12,0x5e,0x95,0x94,0x4a,0x0a,0xfe,0xff,0xff,0xff,0xbf,0x12,0xf4,
0x7f,0xff,0x8f,0x50,0xf1,0xff,0xff,0xff,0xa7,0xc2,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x14,0x92,0xaa,0x4a,0xa2,0xbf,0xa4,0x52,0x95,0x22,0xff,0xff,0xff,
0xff,0x3f,0x45,0xf2,0x7f,0xff,0x3f,0x04,0xf4,0xff,0xff,0xff,0xd7,0xe8,0xff,
0xff,0xff,0xff,0x5f,0xff,0xff,0x83,0xa8,0x94,0x54,0x09,0x2f,0x55,0x4a,0x52,
0x49,0xff,0xff,0xff,0xff,0x5f,0x99,0xf0,0x7f,0xff,0x7f,0x51,0xfc,0xff,0xff,
0xff,0x6b,0xf1,0xff,0xff,0xff,0xff,0x5f,0xfd,0xff,0x2b,0x2a,0xa9,0x12,0x20,
0x5f,0xa9,0xaa,0x54,0x00,0xff,0xff,0xff,0xff,0x5f,0x15,0xf2,0x7f,0xff,0xff,
0x8f,0xff,0xff,0xff,0xff,0x2b,0xfc,0xff,0xff,0xff,0xff,0x2f,0xfd,0xff,0x87,
0xa0,0x4a,0xaa,0x8a,0x9f,0x4a,0x52,0x15,0xa9,0xff,0xff,0xff,0xff,0x5f,0x8a,
0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xf8,0xff,0xff,0xff,0xff,
0x57,0xf2,0xff,0x2f,0x82,0x52,0x05,0xd0,0x2f,0x95,0x4a,0x49,0x84,0xff,0xff,
0xff,0xff,0xbf,0x24,0xf8,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x12,0xfd,
0xff,0xff,0xff,0xff,0x4b,0xd5,0xff,0x9f,0x28,0x54,0x48,0xc5,0xbf,0x52,0x55,
0x0a,0xe1,0xff,0xff,0xff,0xff,0x9f,0x4a,0xfa,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x1a,0xfe,0xff,0xff,0xff,0xff,0x57,0xa9,0xff,0x3f,0x82,0x00,0x21,
0xf0,0x5f,0x2a,0x49,0x21,0xc4,0xff,0xff,0xff,0xff,0xaf,0x1a,0xfd,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0x3f,0x85,0xff,0xff,0xff,0xff,0xff,0x29,0xa5,0xff,
0xff,0x24,0x52,0x88,0xfc,0xbf,0x92,0x2a,0x09,0xf1,0xff,0xff,0xff,0xff,0x9f,
0x4c,0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x15,0xff,0xff,0xff,0x7f,
0xff,0xa5,0x4a,0xff,0xff,0x90,0x08,0x01,0xfe,0x3f,0x55,0x52,0x24,0xf4,0xff,
0xff,0xff,0xff,0xaf,0x02,0xfd,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xc6,
0xff,0xff,0xff,0xbf,0xfe,0x95,0x54,0xff,0xff,0x05,0x42,0xa8,0xfe,0xbf,0xa4,
0x2a,0x41,0xf9,0xff,0xff,0xff,0xff,0x5f,0x55,0xfc,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0x4f,0xd0,0xff,0xff,0xff,0xbf,0x7c,0xaa,0x92,0xfc,0xff,0x53,0x08,
0x01,0xff,0x1f,0x4a,0x01,0x04,0xfc,0xff,0xff,0xff,0xff,0x27,0x05,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xc5,0xff,0xff,0xff,0x4f,0xbf,0x52,0xaa,
0xfe,0xff,0x07,0x42,0xea,0xff,0xbf,0x50,0x54,0x51,0xff,0xff,0xff,0xff,0xff,
0x97,0x56,0xfe,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xf0,0xff,0xff,0xff,
0x2f,0x7f,0xa5,0x54,0xfd,0xff,0x3f,0x09,0xe0,0xff,0x1f,0x02,0x01,0x04,0xff,
0xff,0xff,0xff,0xff,0xaf,0x02,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,
0xf5,0xff,0xff,0xff,0xab,0x9f,0x94,0x92,0xfc,0xff,0xff,0x40,0xfd,0xff,0x9f,
0x48,0x48,0xa1,0xff,0xff,0xff,0xff,0xff,0xa7,0x56,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0x6b,0xf8,0xff,0xff,0xff,0xa4,0x5f,0xa9,0x2a,0xfd,0xff,0xff,
0xff,0xff,0xff,0x3f,0x22,0x21,0xc4,0xff,0xff,0xff,0xff,0xff,0x2f,0x03,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0xfa,0xff,0xff,0x7f,0xd5,0x2f,0xa5,
0xa4,0xfa,0xff,0xff,0xff,0xff,0xff,0xbf,0x08,0x08,0xf9,0xff,0xff,0xff,0xff,
0xff,0x97,0x4a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xfc,0xff,0xff,
0x7f,0x69,0xac,0x2a,0x55,0xf9,0xff,0xff,0xff,0xff,0xff,0x7f,0xa2,0x22,0xf8,
0xff,0xff,0xff,0xff,0xff,0x53,0x21,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0x15,0xfe,0xff,0xff,0x9f,0x2a,0x95,0x94,0x92,0xf4,0xff,0xff,0xff,0xff,0xff,
0xff,0x08,0x88,0xfe,0xff,0xff,0xff,0xff,0xff,0x57,0x8b,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0x7f,0xa9,0xfe,0xff,0xff,0x5f,0x52,0xbc,0x52,0x55,0xf5,0xff,
0xff,0xff,0xff,0xff,0xff,0x21,0x21,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xa1,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x7f,0x0d,0xff,0xff,0xff,0x57,0x15,0x3f,
0x55,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xc8,0xff,0xff,0xff,0xff,
0xff,0xff,0xd7,0x89,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xbf,0xd6,0xff,0xff,
0xff,0x4b,0x45,0x3f,0x49,0xaa,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0xf9,
0xff,0xff,0xff,0xff,0xff,0xff,0xc9,0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0x3f,0x81,0xff,0xff,0xff,0x29,0x11,0x5f,0x28,0x55,0xf5,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xc8,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0x5f,0xd6,0xff,0xff,0x7f,0xaa,0xc2,0x0f,0x55,0x49,0xea,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5,
0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x9f,0xe1,0xff,0xff,0xbf,0x4a,0xd1,
0x5f,0x48,0xa5,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xe9,0xe0,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x27,0xf4,0xff,
0xff,0xbf,0x94,0xc4,0x07,0x91,0x2a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xea,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xaf,0xf1,0xff,0xff,0x9f,0x52,0xe0,0x4b,0x44,0x52,0xe9,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x6a,0xe0,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0x4b,0xfc,0xff,0xff,0xab,0x2a,0xf5,0x0f,0x51,0xa5,
0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0x69,0xe5,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x55,0xf8,0xff,0xff,0x95,0x14,
0xf0,0x5f,0x84,0x54,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0x75,0xf0,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x13,0xfd,
0xff,0xff,0xa5,0x42,0xf9,0x7f,0x91,0x4a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xb2,0xfa,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0x54,0xfe,0xff,0x7f,0x52,0x12,0xfa,0xff,0x20,0xa5,0xe4,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x34,0xf8,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0x25,0xff,0xff,0xaf,0xaa,0x48,0xfc,0xff,0x0b,
0x29,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xb5,0xf8,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x52,0xff,0xff,0x2f,0x49,
0x02,0xfe,0xff,0x43,0xaa,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x3f,0x3a,0xfa,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x4a,
0xff,0xff,0xa5,0x2a,0xa9,0xff,0xff,0x17,0x25,0xe9,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x9a,0xfc,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0x2a,0xff,0x7f,0x95,0x54,0x80,0xff,0xff,0x07,0xa9,0xea,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x1d,0xfc,
0xff,0x7f,0xff,0xff,0xff,0xff,0x3f,0xa9,0xfe,0x7f,0xa9,0x12,0xe5,0xff,0xff,
0x5f,0x4a,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x5f,0xad,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x95,0xea,0x97,0x54,
0x4a,0xf0,0xff,0xff,0x1f,0xa8,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x5f,0x0e,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,
0x52,0x55,0xa9,0x92,0x02,0xfd,0xff,0xff,0x5f,0x53,0xf5,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x5e,0xfe,0xff,0x7f,0xff,
0xff,0xff,0xff,0xbf,0x2a,0x49,0x4a,0x55,0x49,0xfc,0xff,0xff,0x3f,0x94,0xf8,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x0f,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f,0xa5,0xaa,0x92,0xa4,0x20,0xff,0xff,
0xff,0xbf,0xa4,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x5f,0x57,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x52,0x52,0xaa,
0x2a,0x0a,0xff,0xff,0xff,0x7f,0x54,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0x07,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xa7,0x94,0x4a,0x55,0x4a,0xa0,0xff,0xff,0xff,0xff,0xa8,0xfa,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x57,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0x2f,0x55,0xa9,0x92,0x12,0xe9,0xff,0xff,0xff,0x7f,0x24,
0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,
0x87,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0xa5,0x4a,0xaa,0x44,0xf4,0xff,
0xff,0xff,0xff,0x55,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xa7,0xab,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xab,0x94,0xa4,
0x92,0x12,0xf9,0xff,0xff,0xff,0xff,0xa8,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xab,0x83,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0x47,0xa9,0x2a,0x55,0x40,0xfc,0xff,0xff,0xff,0xff,0x25,0xf5,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff,0xff,0xd7,0x97,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0x33,0x55,0xa9,0x24,0x15,0xfe,0xff,0xff,0xff,0xff,
0x95,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xff,
0x93,0xc3,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x25,0xa5,0x2a,0x40,0xff,
0xff,0xff,0xff,0xff,0xa9,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xff,
0xff,0xff,0xff,0xff,0xe7,0xd5,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4b,0x92,
0x54,0x92,0xd4,0xff,0xff,0xff,0xff,0xff,0x55,0xf5,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xe9,0xff,0xff,0xff,0xff,0xff,0xd5,0xc1,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0x97,0xaa,0x4a,0x05,0xe2,0xff,0xff,0xff,0xff,0xff,0x25,0xf1,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xfd,0xff,0xff,0xff,0xff,0xd5,0xea,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x55,0x25,0xa1,0xf0,0xff,0xff,0xff,0xff,
0xff,0x95,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe8,0xfa,0xff,0xff,0xff,
0xff,0xea,0xe0,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xa7,0x24,0x59,0x04,0xfa,
0xff,0xff,0xff,0xff,0xff,0xa9,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe2,
0xfd,0xff,0xff,0xff,0xff,0xc9,0xe9,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f,
0x52,0x05,0xa1,0xfc,0xff,0xff,0xff,0xff,0xff,0xa5,0xfa,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x70,0xf9,0xff,0xff,0xff,0xff,0x74,0xe2,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0x47,0x95,0x92,0x04,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xf8,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe2,0xfa,0xff,0xff,0xff,0xff,0x72,0xe8,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x97,0xaa,0x20,0xd0,0xff,0xff,0xff,0xff,
0xff,0xff,0x55,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb8,0xfc,0xff,0xff,
0xff,0xff,0xea,0xe2,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x07,0x04,0x82,0xc2,
0xff,0xff,0xff,0xff,0xff,0xff,0x29,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0x71,0xfd,0xff,0xff,0xff,0x7f,0x2a,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0x4f,0x91,0x28,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xfc,0xff,0xff,0xff,
0xff,0xff,0xff,0x1f,0x54,0xfe,0xff,0xff,0xff,0x7f,0x75,0xf2,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0x27,0x44,0x82,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x29,
0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xb8,0xfc,0xff,0xff,0xff,0xbf,0x14,
0xf1,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x0f,0x11,0x20,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x55,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x9a,0xfe,0xff,
0xff,0xff,0x7f,0x5a,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x40,0x85,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x09,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x4f,0x2d,0xfd,0xff,0xff,0xff,0x9f,0x12,0xf9,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0x3f,0x14,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfe,0xff,0xff,
0xff,0xff,0xff,0xff,0x07,0xa6,0xfe,0xff,0xff,0xff,0x5f,0x4d,0xfa,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0x40,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x09,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x4b,0xfe,0xff,0xff,0xff,0xbf,
0x2c,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x43,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x57,0xff,
0xff,0xff,0xff,0x5f,0x0a,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x89,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xd5,0xa9,0xff,0xff,0xff,0xff,0xaf,0x5a,0xfc,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa3,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x81,0x95,0xff,0xff,0xff,0xff,0x9f,0x06,0xfd,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xa5,0xff,0xff,0xff,0xff,
0x2f,0x95,0xfc,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe0,0xea,
0xff,0xff,0xff,0xff,0xaf,0x26,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd5,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xf5,0xf4,0xff,0xff,0xff,0xff,0xaf,0x86,0xfe,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc1,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0x70,0xe5,0xff,0xff,0xff,0xff,0x4f,0x2e,0xfe,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xb2,0xfa,0xff,0xff,0xff,
0xff,0x57,0x83,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x78,
0xf2,0xff,0xff,0xff,0xff,0xa7,0x22,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x5f,0x5d,0xfd,0xff,0xff,0xff,0xff,0x97,0x87,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x3c,0xfd,0xff,0xff,0xff,0xff,0x53,0xa3,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xac,0xfe,0xff,0xff,
0xff,0xff,0x57,0x95,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,
0x9e,0xfe,0xff,0xff,0xff,0xff,0x97,0x81,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xa7,0x57,0xfe,0xff,0xff,0xff,0xff,0xa9,0xa5,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0xaf,0xff,0xff,0xff,0xff,0xff,0x4b,
0x89,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x93,0xff,0xff,
0xff,0xff,0xff,0x95,0xa2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x83,0xab,0xff,0xff,0xff,0xff,0xff,0xd3,0xc8,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xff,
0xff,0xff,0xff,0xff,0xe9,0xa5,0xff,0xff,0xff,0xff,0xff,0xa5,0xe1,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0xd5,0xff,0xff,0xff,0xff,0xff,
0xd5,0xc8,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xea,0xea,0xff,
0xff,0xff,0xff,0xff,0x14,0xc1,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,
0xff,0xe0,0xe4,0xff,0xff,0xff,0xff,0xff,0x65,0xe8,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xcf,
0xff,0xff,0xff,0xff,0x3f,0x72,0xe9,0xff,0xff,0xff,0xff,0xff,0x6a,0xe1,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,0xbf,0xb8,0xfa,0xff,0xff,0xff,0xff,
0xff,0x52,0xea,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0x1f,0x7a,0xf5,
0xff,0xff,0xff,0xff,0x7f,0x2a,0xe0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,
0xff,0x8f,0x58,0xfa,0xff,0xff,0xff,0xff,0x7f,0x25,0xf5,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xb5,0xff,0xff,0xdf,0xff,0x57,0x5e,0xfd,0xff,0xff,0xff,0xff,0xff,0x34,0xe0,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xca,0xff,0xff,0x8f,0xff,0x07,0xac,0xfc,0xff,0xff,0xff,
0xff,0x7f,0x2a,0xf5,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd4,0xff,0xff,0x57,0xff,0x2b,0x2d,
0xfd,0xff,0xff,0xff,0xff,0xff,0xb2,0xf0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd2,0xff,0xff,
0x07,0xff,0x43,0x4a,0xff,0xff,0xff,0xff,0xff,0xbf,0x2a,0xf8,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x3f,0xc5,0xff,0xff,0x2b,0xfe,0x08,0xab,0xfe,0xff,0xff,0xff,0xff,0x7f,0xaa,
0xf2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xbf,0xea,0xff,0xff,0x83,0x36,0x20,0x55,0xff,0xff,0xff,
0xff,0xff,0x3f,0x15,0xf0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xc2,0xff,0xff,0x48,0x4a,0x85,
0x49,0xff,0xff,0xff,0xff,0xff,0x7f,0x59,0xfa,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xf5,0xff,
0x7f,0x10,0x29,0x50,0xa5,0xff,0xff,0xff,0xff,0xff,0x3f,0x15,0xf9,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x97,0xe4,0xff,0x7f,0x05,0x95,0x42,0xd5,0xff,0xff,0xff,0xff,0xff,0x7f,
0x35,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xab,0xea,0xff,0xbf,0xa0,0x24,0xa8,0xd4,0xff,0xff,
0xff,0xff,0xff,0x7f,0x19,0xf9,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x27,0xe5,0xff,0x3f,0x92,0xaa,
0x50,0xe9,0xff,0xff,0xff,0xff,0xff,0x9f,0x4a,0xfc,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa9,0xe2,
0xff,0x9f,0xa0,0xaa,0x2a,0xf5,0xff,0xff,0xff,0xff,0xff,0x5f,0x1a,0xf9,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x95,0xf8,0xff,0x5f,0x4a,0x92,0x4a,0xf5,0xff,0xff,0xff,0xff,0xff,
0xbf,0x4a,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0x52,0xf2,0xff,0x1f,0x20,0x49,0xa5,0xfa,0xff,
0xff,0xff,0xff,0xff,0x5f,0x1a,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaa,0xf8,0xff,0x47,0xa9,
0x2a,0x29,0xf9,0xff,0xff,0xff,0xff,0xff,0xbf,0x0a,0xfc,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x49,
0xf2,0xff,0x17,0x92,0xaa,0xaa,0xfe,0xff,0xff,0xff,0xff,0xff,0x9f,0xac,0xfe,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x9f,0x2a,0xf8,0xff,0x43,0xa8,0x24,0x25,0xff,0xff,0xff,0xff,0xff,
0xff,0xaf,0x0a,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x94,0xfa,0xff,0x91,0x54,0xaa,0x52,0xff,
0xff,0xff,0xff,0xff,0xff,0x2f,0x4d,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x45,0xfc,0xff,0x03,
0x92,0x52,0xaa,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x06,0xfc,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,
0x12,0xfe,0xff,0x50,0xaa,0x2a,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xa5,
0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xa7,0x44,0xff,0xff,0x0a,0x25,0xa5,0xa4,0xff,0xff,0xff,0xff,
0xff,0xff,0x97,0x06,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x15,0xff,0xff,0x40,0xa9,0x92,0xea,
0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x55,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xa1,0xff,0x7f,
0x92,0x4a,0xaa,0xd4,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x06,0xfc,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x95,0x8a,0xff,0x3f,0x84,0x54,0xa9,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,
0x25,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x52,0xe0,0xff,0xbf,0x50,0xa9,0x4a,0xf2,0xff,0xff,0xff,
0xff,0xff,0xff,0xa7,0x8e,0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa9,0xea,0xff,0x3f,0x24,0x95,0x54,
0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x23,0xfe,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x4a,0xf0,0xff,
0x9f,0x50,0x69,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x8b,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xa5,0xf4,0xff,0x0f,0x2d,0x75,0xaa,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,
0xaf,0x03,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x9f,0x14,0xfa,0xff,0x2f,0xa8,0xfa,0x25,0xfd,0xff,0xff,
0xff,0xff,0xff,0xff,0x97,0xd7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xaa,0xfc,0xff,0x0f,0x4d,0xfd,
0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xcf,0x83,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x12,0xfc,
0xff,0x27,0x92,0xfe,0xcb,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd7,0xd7,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x97,0x0a,0xff,0xff,0x83,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xef,0xc7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xab,0x24,0xff,0xff,0x2b,0xaa,0xfe,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xe7,0xef,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x45,0xff,0xff,0x05,0x95,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x82,
0xff,0xff,0x51,0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7,
0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xa9,0xe8,0xff,0xff,0x85,0xca,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0x52,0xc1,0xff,0xff,0x90,0xd5,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x4d,0xe8,0xff,0xff,0xa5,
0xe4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x51,
0xf2,0xff,0x7f,0x40,0xd5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x3f,0x95,0xf8,0xff,0x7f,0xa9,0xea,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x15,0xfa,0xff,0x3f,0xa4,0xf4,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xa4,0xfc,0xff,0x7f,
0x71,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,
0x15,0xfe,0xff,0x3f,0x94,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xa7,0x0a,0xff,0xff,0x1f,0x79,0xf2,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xa4,0xff,0xff,0x5f,0x8c,0xfa,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x82,0xff,0xff,
0x1f,0x5c,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xa4,0x92,0xff,0xff,0xbf,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x9a,0xc4,0xff,0xff,0x0f,0x2e,0xfd,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa2,0xf0,0xff,0xff,0xaf,0xa7,0xfe,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x55,0xe4,0xff,
0xff,0x0f,0x57,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xbf,0x54,0xf2,0xff,0xff,0x9f,0x4b,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x9f,0x92,0xf8,0xff,0xff,0xc7,0xab,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x15,0xfe,0xff,0xff,0x97,0xd7,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0x94,0xfc,
0xff,0xff,0xc7,0xe3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x2f,0x05,0xfe,0xff,0xff,0xcf,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x53,0xa9,0xff,0xff,0xff,0xd3,0xeb,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x05,0xff,0xff,0xff,0xe3,
0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0xc2,
0xff,0xff,0xff,0xeb,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x95,0xc8,0xff,0xff,0xff,0xf3,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xd2,0xff,0xff,0xff,0xff,0xf5,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xaa,0xe0,0xff,0xff,0xff,
0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x49,
0xf8,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x9f,0x2a,0xf5,0xff,0xff,0xff,0xff,0xfd,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x4a,0xf8,0xff,0xff,0xff,0xff,0xfc,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x14,0xfd,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,
0x4a,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xab,0x04,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x52,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x85,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x54,0xa2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x4a,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xe0,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x94,0xe4,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x5f,0x55,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xbf,0x12,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x54,0xfa,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x0a,0xfc,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x53,0x45,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x97,0x14,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x45,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0x82,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x4a,0xe9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x52,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x55,0xe8,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24,
0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0x55,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x15,0xfe,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,
0x49,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x2f,0x95,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x01,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x57,0x81,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x97,0xd4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xe0,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x93,0xf4,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x57,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x2b,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x89,0xfc,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfc,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x05,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x49,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x22,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x89,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xe9,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,
0xff,0xff,0xff,0x9f,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfc,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,
0x6f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xbf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,
0xff,0x9f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,
0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,
0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f};

3
etc/gnus.xpm → lisp/gnus/gnus.xpm
View File

@ -5,7 +5,7 @@ static char *gnus[] = {
/* colors */
". s thing c #bf9900",
"# s shadow c #ffcc00",
"a s background c None",
"a s None c None",
/* pixels */
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
@ -281,3 +281,4 @@ static char *gnus[] = {
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
};

21
lisp/gnus/grin.xpm Normal file
View File

@ -0,0 +1,21 @@
/* XPM */
static char * grin_xpm[] = {
"13 14 4 1",
" c None",
". c #000000",
"+ c #FFDD00",
"@ c #FFFFFF",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".+++++++++++.",
".++..+++..++.",
".++..+++..++.",
".+++++++++++.",
".+.........+.",
".+.@@@@@@@.+.",
".++.@@@@@.++.",
".+++.....+++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

74
lisp/gnus/hex-util.el Normal file
View File

@ -0,0 +1,74 @@
;;; hex-util.el --- Functions to encode/decode hexadecimal string.
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Keywords: data
;; This file is part of FLIM (Faithful Library about Internet Message).
;; This program 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.
;; This program 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 this program; 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
(defmacro hex-char-to-num (chr)
(` (let ((chr (, chr)))
(cond
((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
(t (error "Invalid hexadecimal digit `%c'" chr))))))
(defmacro num-to-hex-char (num)
(` (aref "0123456789abcdef" (, num)))))
(defun decode-hex-string (string)
"Decode hexadecimal STRING to octet string."
(let* ((len (length string))
(dst (make-string (/ len 2) 0))
(idx 0)(pos 0))
(while (< pos len)
;;; logior and lsh are not byte-coded.
;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4)
;;; (hex-char-to-num (aref string (1+ pos)))))
(aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16)
(hex-char-to-num (aref string (1+ pos)))))
(setq idx (1+ idx)
pos (+ 2 pos)))
dst))
(defun encode-hex-string (string)
"Encode octet STRING to hexadecimal string."
(let* ((len (length string))
(dst (make-string (* len 2) 0))
(idx 0)(pos 0))
(while (< pos len)
;;; logand and lsh are not byte-coded.
;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15)))
(aset dst idx (num-to-hex-char (/ (aref string pos) 16)))
(setq idx (1+ idx))
;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15)))
(aset dst idx (num-to-hex-char (% (aref string pos) 16)))
(setq idx (1+ idx)
pos (1+ pos)))
dst))
(provide 'hex-util)
;;; arch-tag: fe8aaa79-6c86-400e-813f-5a8cc4cb3859
;;; hex-util.el ends here

550
lisp/gnus/html2text.el Normal file
View File

@ -0,0 +1,550 @@
;;; html2text.el --- a simple html to plain text converter
;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
;; Author: Joakim Hove <hove@phys.ntnu.no>
;; 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 functions provide a simple way to wash/clean html infected
;; mails. Definitely do not work in all cases, but some improvement
;; in readability is generally obtained. Formatting is only done in
;; the buffer, so the next time you enter the article it will be
;; "re-htmlized".
;;
;; The main function is "html2text"
;;; Code:
;;
;; <Global variables>
;;
(eval-when-compile
(require 'cl))
(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr)))
(defvar html2text-replace-list
'(("&nbsp;" . " ") ("&gt;" . ">") ("&lt;" . "<") ("&quot;" . "\""))
"The map of entity to text.
This is an alist were each element is a dotted pair consisting of an
old string, and a replacement string. This replacement is done by the
function \"html2text-substitute\" which basically performs a
replace-string operation for every element in the list. This is
completely verbatim - without any use of REGEXP.")
(defvar html2text-remove-tag-list
'("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta")
"A list of removable tags.
This is a list of tags which should be removed, without any
formatting. Observe that if you the tags in the list are presented
*without* any \"<\" or \">\". All occurences of a tag appearing in
this list are removed, irrespective of whether it is a closing or
opening tag, or if the tag has additional attributes. The actual
deletion is done by the function \"html2text-remove-tags\".
For instance the text:
\"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\"
will be reduced to:
\"Here comes something big.\"
If this list contains the element \"font\".")
(defvar html2text-format-tag-list
'(("b" . html2text-clean-bold)
("u" . html2text-clean-underline)
("i" . html2text-clean-italic)
("blockquote" . html2text-clean-blockquote)
("a" . html2text-clean-anchor)
("ul" . html2text-clean-ul)
("ol" . html2text-clean-ol)
("dl" . html2text-clean-dl)
("center" . html2text-clean-center))
"An alist of tags and processing functions.
This is an alist where each dotted pair consists of a tag, and then
the name of a function to be called when this tag is found. The
function is called with the arguments p1, p2, p3 and p4. These are
demontrated below:
\"<b> This is bold text </b>\"
^ ^ ^ ^
| | | |
p1 p2 p3 p4
Then the called function will typically format the text somewhat and
remove the tags.")
(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta")
"Another list of removable tags.
This is a list of tags which are removed similarly to the list
`html2text-remove-tag-list' - but these tags are retained for the
formatting, and then moved afterward.")
;;
;; </Global variables>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; <Utility functions>
;;
(defun html2text-buffer-head ()
(if (string= mode-name "Article")
(beginning-of-buffer)
(beginning-of-buffer)
)
)
(defun html2text-replace-string (from-string to-string p1 p2)
(goto-char p1)
(let ((delta (- (string-width to-string) (string-width from-string)))
(change 0))
(while (search-forward from-string p2 t)
(replace-match to-string)
(setq change (+ change delta))
)
change
)
)
;;
;; </Utility functions>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; <Functions related to attributes> i.e. <font size=+3>
;;
(defun html2text-attr-value (attr-list attr)
(nth 1 (assoc attr attr-list))
)
(defun html2text-get-attr (p1 p2 tag)
(goto-char p1)
(re-search-forward " +[^ ]" p2 t)
(let* ((attr-string (buffer-substring-no-properties (1- (point)) (1- p2)))
(tmp-list (split-string attr-string))
(attr-list)
(counter 0)
(prev (car tmp-list))
(this (nth 1 tmp-list))
(next (nth 2 tmp-list))
(index 1))
(cond
;; size=3
((string-match "[^ ]=[^ ]" prev)
(let ((attr (nth 0 (split-string prev "=")))
(value (nth 1 (split-string prev "="))))
(setq attr-list (cons (list attr value) attr-list))
)
)
;; size= 3
((string-match "[^ ]=\\'" prev)
(setq attr-list (cons (list (substring prev 0 -1) this) attr-list))
)
)
(while (< index (length tmp-list))
(cond
;; size=3
((string-match "[^ ]=[^ ]" this)
(let ((attr (nth 0 (split-string this "=")))
(value (nth 1 (split-string this "="))))
(setq attr-list (cons (list attr value) attr-list))
)
)
;; size =3
((string-match "\\`=[^ ]" this)
(setq attr-list (cons (list prev (substring this 1)) attr-list)))
;; size= 3
((string-match "[^ ]=\\'" this)
(setq attr-list (cons (list (substring this 0 -1) next) attr-list))
)
;; size = 3
((string= "=" this)
(setq attr-list (cons (list prev next) attr-list))
)
)
(setq index (1+ index))
(setq prev this)
(setq this next)
(setq next (nth (1+ index) tmp-list))
)
;;
;; Tags with no accompanying "=" i.e. value=nil
;;
(setq prev (car tmp-list))
(setq this (nth 1 tmp-list))
(setq next (nth 2 tmp-list))
(setq index 1)
(if (not (string-match "=" prev))
(progn
(if (not (string= (substring this 0 1) "="))
(setq attr-list (cons (list prev nil) attr-list))
)
)
)
(while (< index (1- (length tmp-list)))
(if (not (string-match "=" this))
(if (not (or (string= (substring next 0 1) "=")
(string= (substring prev -1) "=")))
(setq attr-list (cons (list this nil) attr-list))
)
)
(setq index (1+ index))
(setq prev this)
(setq this next)
(setq next (nth (1+ index) tmp-list))
)
(if this
(progn
(if (not (string-match "=" this))
(progn
(if (not (string= (substring prev -1) "="))
(setq attr-list (cons (list this nil) attr-list))
)
)
)
)
)
attr-list ;; return - value
)
)
;;
;; </Functions related to attributes>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; <Functions to be called to format a tag-pair>
;;
(defun html2text-clean-list-items (p1 p2 list-type)
(goto-char p1)
(let ((item-nr 0)
(items 0))
(while (re-search-forward "<li>" p2 t)
(setq items (1+ items)))
(goto-char p1)
(while (< item-nr items)
(setq item-nr (1+ item-nr))
(re-search-forward "<li>" (point-max) t)
(cond
((string= list-type "ul") (insert " o "))
((string= list-type "ol") (insert (format " %s: " item-nr)))
(t (insert " x ")))
)
)
)
(defun html2text-clean-dtdd (p1 p2)
(goto-char p1)
(let ((items 0)
(item-nr 0))
(while (re-search-forward "<dt>" p2 t)
(setq items (1+ items)))
(goto-char p1)
(while (< item-nr items)
(setq item-nr (1+ item-nr))
(re-search-forward "<dt>\\([ ]*\\)" (point-max) t)
(when (match-string 1)
(delete-region (point) (- (point) (string-width (match-string 1)))))
(let ((def-p1 (point))
(def-p2 0))
(re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t)
(if (match-string 1)
(progn
(let* ((mw1 (string-width (match-string 1)))
(mw2 (string-width (match-string 2)))
(mw (+ mw1 mw2)))
(goto-char (- (point) mw))
(delete-region (point) (+ (point) mw1))
(setq def-p2 (point))))
(setq def-p2 (- (point) (string-width (match-string 2)))))
(put-text-property def-p1 def-p2 'face 'bold)))))
(defun html2text-delete-tags (p1 p2 p3 p4)
(delete-region p1 p2)
(delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1))))
(defun html2text-delete-single-tag (p1 p2)
(delete-region p1 p2))
(defun html2text-clean-hr (p1 p2)
(html2text-delete-single-tag p1 p2)
(goto-char p1)
(newline 1)
(insert (make-string fill-column ?-))
)
(defun html2text-clean-ul (p1 p2 p3 p4)
(html2text-delete-tags p1 p2 p3 p4)
(html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")
)
(defun html2text-clean-ol (p1 p2 p3 p4)
(html2text-delete-tags p1 p2 p3 p4)
(html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")
)
(defun html2text-clean-dl (p1 p2 p3 p4)
(html2text-delete-tags p1 p2 p3 p4)
(html2text-clean-dtdd p1 (- p3 (- p1 p2)))
)
(defun html2text-clean-center (p1 p2 p3 p4)
(html2text-delete-tags p1 p2 p3 p4)
(center-region p1 (- p3 (- p2 p1)))
)
(defun html2text-clean-bold (p1 p2 p3 p4)
(put-text-property p2 p3 'face 'bold)
(html2text-delete-tags p1 p2 p3 p4)
)
(defun html2text-clean-title (p1 p2 p3 p4)
(put-text-property p2 p3 'face 'bold)
(html2text-delete-tags p1 p2 p3 p4)
)
(defun html2text-clean-underline (p1 p2 p3 p4)
(put-text-property p2 p3 'face 'underline)
(html2text-delete-tags p1 p2 p3 p4)
)
(defun html2text-clean-italic (p1 p2 p3 p4)
(put-text-property p2 p3 'face 'italic)
(html2text-delete-tags p1 p2 p3 p4)
)
(defun html2text-clean-font (p1 p2 p3 p4)
(html2text-delete-tags p1 p2 p3 p4)
)
(defun html2text-clean-blockquote (p1 p2 p3 p4)
(html2text-delete-tags p1 p2 p3 p4)
)
(defun html2text-clean-anchor (p1 p2 p3 p4)
;; If someone can explain how to make the URL clickable I will
;; surely improve upon this.
(let* ((attr-list (html2text-get-attr p1 p2 "a"))
(href (html2text-attr-value attr-list "href")))
(delete-region p1 p4)
(when href
(goto-char p1)
(insert (substring href 1 -1 ))
(put-text-property p1 (point) 'face 'bold))))
;;
;; </Functions to be called to format a tag-pair>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; <Functions to be called to fix up paragraphs>
;;
(defun html2text-fix-paragraph (p1 p2)
(goto-char p1)
(let ((has-br-line)
(refill-start)
(refill-stop))
(if (re-search-forward "<br>$" p2 t)
(setq has-br-line t)
)
(if has-br-line
(progn
(goto-char p1)
(if (re-search-forward ".+[^<][^b][^r][^>]$" p2 t)
(progn
(beginning-of-line)
(setq refill-start (point))
(goto-char p2)
(re-search-backward ".+[^<][^b][^r][^>]$" refill-start t)
(next-line 1)
(end-of-line)
;; refill-stop should ideally be adjusted to
;; accomodate the "<br>" strings which are removed
;; between refill-start and refill-stop. Can simply
;; be returned from my-replace-string
(setq refill-stop (+ (point)
(html2text-replace-string
"<br>" ""
refill-start (point))))
;; (message "Point = %s refill-stop = %s" (point) refill-stop)
;; (sleep-for 4)
(fill-region refill-start refill-stop)
)
)
)
)
)
(html2text-replace-string "<br>" "" p1 p2)
)
;;
;; This one is interactive ...
;;
(defun html2text-fix-paragraphs ()
"This _tries_ to fix up the paragraphs - this is done in quite a ad-hook
fashion, quite close to pure guess-work. It does work in some cases though."
(interactive)
(html2text-buffer-head)
(replace-regexp "^<br>$" "")
;; Removing lonely <br> on a single line, if they are left intact we
;; dont have any paragraphs at all.
(html2text-buffer-head)
(while (not (eobp))
(let ((p1 (point)))
(forward-paragraph 1)
;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5)
(html2text-fix-paragraph p1 (1- (point)))
(goto-char p1)
(when (not (eobp))
(forward-paragraph 1)))))
;;
;; </Functions to be called to fix up paragraphs>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; <Interactive functions>
;;
(defun html2text-remove-tags (tag-list)
"Removes the tags listed in the list \"html2text-remove-tag-list\".
See the documentation for that variable."
(interactive)
(dolist (tag tag-list)
(html2text-buffer-head)
(while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t)
(delete-region (match-beginning 0) (match-end 0)))))
(defun html2text-format-tags ()
"See the variable \"html2text-format-tag-list\" for documentation"
(interactive)
(dolist (tag-and-function html2text-format-tag-list)
(let ((tag (car tag-and-function))
(function (cdr tag-and-function)))
(html2text-buffer-head)
(while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
(point-max) t)
(let ((p1)
(p2 (point))
(p3) (p4)
(attr (match-string 1)))
(search-backward "<" (point-min) t)
(setq p1 (point))
(re-search-forward (format "</%s>" tag) (point-max) t)
(setq p4 (point))
(search-backward "</" (point-min) t)
(setq p3 (point))
(funcall function p1 p2 p3 p4)
(goto-char p1)
)
)
)
)
)
(defun html2text-substitute ()
"See the variable \"html2text-replace-list\" for documentation"
(interactive)
(dolist (e html2text-replace-list)
(html2text-buffer-head)
(let ((old-string (car e))
(new-string (cdr e)))
(html2text-replace-string old-string new-string (point-min) (point-max))
)
)
)
(defun html2text-format-single-elements ()
""
(interactive)
(dolist (tag-and-function html2text-format-single-element-list)
(let ((tag (car tag-and-function))
(function (cdr tag-and-function)))
(html2text-buffer-head)
(while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
(point-max) t)
(let ((p1)
(p2 (point)))
(search-backward "<" (point-min) t)
(setq p1 (point))
(funcall function p1 p2)
)
)
)
)
)
;;
;; Main function
;;
;;;###autoload
(defun html2text ()
"Convert HTML to plain text in the current buffer."
(interactive)
(save-excursion
(let ((case-fold-search t)
(buffer-read-only))
(html2text-remove-tags html2text-remove-tag-list)
(html2text-format-tags)
(html2text-remove-tags html2text-remove-tag-list2)
(html2text-substitute)
(html2text-format-single-elements)
(html2text-fix-paragraphs))))
;;
;; </Interactive functions>
;;
;;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e
;;; html2text.el ends here

77
lisp/gnus/ietf-drums.el
View File

@ -1,5 +1,5 @@
;;; ietf-drums.el --- functions for parsing RFC822bis headers
;; Copyright (C) 1998, 1999, 2000, 2002
;;; ietf-drums.el --- Functions for parsing RFC822bis headers
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@ -27,6 +27,16 @@
;; Messages". This library is based on
;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
;; Pending a real regression self test suite, Simon Josefsson added
;; various self test expressions snipped from bug reports, and their
;; expected value, below. I you believe it could be useful, please
;; add your own test cases, or write a real self test suite, or just
;; remove this.
;; <m3oekvfd50.fsf@whitebox.m5r.de>
;; (ietf-drums-parse-address "'foo' <foo@example.com>")
;; => ("foo@example.com" . "'foo'")
;;; Code:
(eval-when-compile (require 'cl))
@ -64,10 +74,14 @@ backslash and doublequote.")
(modify-syntax-entry ?> ")" table)
(modify-syntax-entry ?@ "w" table)
(modify-syntax-entry ?/ "w" table)
(modify-syntax-entry ?= " " table)
(modify-syntax-entry ?* " " table)
(modify-syntax-entry ?\; " " table)
(modify-syntax-entry ?\' " " table)
(modify-syntax-entry ?* "_" table)
(modify-syntax-entry ?\; "_" table)
(modify-syntax-entry ?\' "_" table)
(if (featurep 'xemacs)
(let ((i 128))
(while (< i 256)
(modify-syntax-entry i "w" table)
(setq i (1+ i)))))
table))
(defun ietf-drums-token-to-list (token)
@ -200,25 +214,38 @@ backslash and doublequote.")
(defun ietf-drums-parse-addresses (string)
"Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
(with-temp-buffer
(ietf-drums-init string)
(let ((beg (point))
pairs c)
(while (not (eobp))
(setq c (char-after))
(cond
((memq c '(?\" ?< ?\())
(forward-sexp 1))
((eq c ?,)
(push (ietf-drums-parse-address (buffer-substring beg (point)))
pairs)
(forward-char 1)
(setq beg (point)))
(t
(forward-char 1))))
(push (ietf-drums-parse-address (buffer-substring beg (point)))
pairs)
(nreverse pairs))))
(if (null string)
nil
(with-temp-buffer
(ietf-drums-init string)
(let ((beg (point))
pairs c address)
(while (not (eobp))
(setq c (char-after))
(cond
((memq c '(?\" ?< ?\())
(condition-case nil
(forward-sexp 1)
(error
(skip-chars-forward "^,"))))
((eq c ?,)
(setq address
(condition-case nil
(ietf-drums-parse-address
(buffer-substring beg (point)))
(error nil)))
(if address (push address pairs))
(forward-char 1)
(setq beg (point)))
(t
(forward-char 1))))
(setq address
(condition-case nil
(ietf-drums-parse-address
(buffer-substring beg (point)))
(error nil)))
(if address (push address pairs))
(nreverse pairs)))))
(defun ietf-drums-unfold-fws ()
"Unfold folding white space in the current buffer."

732
lisp/gnus/imap.el
View File

File diff suppressed because it is too large Load Diff

32
lisp/gnus/important.xpm Normal file
View File

@ -0,0 +1,32 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 2 1",
"! c red",
"w c Gray75",
/* pixels */
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwww!!!wwwwwwwwwwww",
"wwwwwwwww!!!wwwwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwww!!!!!!!wwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwwwww!!!wwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwww!!!wwwwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwwww!!!!!wwwwwwwwwww",
"wwwwwwwww!!!wwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww",
"wwwwwwwwwwwwwwwwwwwwwwww"
};

20
lisp/gnus/indifferent.xpm Normal file
View File

@ -0,0 +1,20 @@
/* XPM */
static char * indifferent_xpm[] = {
"13 14 3 1",
" c None",
". c #000000",
"+ c #FFDD00",
" ....... ",
" ..+++++.. ",
" .+++++++++. ",
".+++++++++++.",
".++..+++..++.",
".++..+++..++.",
".+++++++++++.",
".+++++++++++.",
".+++++++++++.",
".++.......++.",
".+++++++++++.",
" .+++++++++. ",
" ..+++++.. ",
" ....... "};

78
lisp/gnus/kill-group.xpm
View File

@ -1,50 +1,30 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 20 1",
" c Gray0",
". c Gray6",
"X c Gray12",
"o c #2ff42ff42ff4",
"O c #3fff3fff3fff",
"+ c Gray28",
"@ c #53e353e353e3",
"# c #5fe25fe25fe2",
"$ c #67e767e767e7",
"% c #6fff6fff6fff",
"& c #77d777d777d7",
"* c Gray50",
"= c Gray56",
"- c #9fff9fff9fff",
"; c Gray70",
": c Gray75",
"> c Gray81",
", c #dfffdfffdfff",
"< c #efffefffefff",
"1 c Gray100",
/* pixels */
"::::::::::::::::::::::::",
"::::::::::::::::::::::::",
"::::::::::::::::::::::::",
"::::#oOOOOOOOOOo+;::::::",
"::::#:111111111:O$::::::",
"::::#:1111-O%11:*>@:::::",
"::::#:111=X.o#<>OOo#::::",
"::::#:111 OX# :111:#::::",
"::::#:111 = :111:#::::",
"::::#:111>Xo.-1111:#::::",
"::::#:1111*:O11111:#::::",
"::::#:11%1*oO->111:#::::",
"::::#:1-O:,1:*O111:#::::",
"::::#:111****:1111:#::::",
"::::#:1111* 111111:#::::",
"::::#:1,:O-1O*:111:#::::",
"::::#:1:X1111*#111:#::::",
"::::#:11>1111,<111:#::::",
"::::#:111111111111:#::::",
"::::#:111111111111:#::::",
"::::#:111111111111:#::::",
"::::&oooooooooooooo&::::",
"::::::::::::::::::::::::",
"::::::::::::::::::::::::"
};
static char * kill_group_xpm[] = {
"24 24 3 1",
". c None",
"o c #000000000000",
"+ c #9A9A6C6C4E4E",
"o..o..o..o..o..o..o..o..",
"........................",
"........................",
"o..o..o..o..o..o..o..o..",
"........................",
"........................",
"o..o..o..o..++.o..o..o..",
".......++..++++.........",
"........++.+++..........",
"o..o..o.+++++..o..o..o..",
".........+++............",
".........++++...........",
"o..o..o.++++++.o..o..o..",
"........++.++++.........",
".......++...++++........",
"o..o...+.o...++o..o..o..",
"........................",
"........................",
"o..o..o..o..o..o..o..o..",
"........................",
"........................",
"o..o..o..o..o..o..o..o..",
"........................",
"........................"};

13
lisp/gnus/mail-parse.el
View File

@ -1,4 +1,4 @@
;;; mail-parse.el --- interface functions for parsing mail
;;; mail-parse.el --- Interface functions for parsing mail
;; Copyright (C) 1998, 1999, 2000
;; Free Software Foundation, Inc.
@ -43,10 +43,11 @@
(require 'rfc2047)
(require 'rfc2045)
(defalias 'mail-header-parse-content-type 'rfc2231-parse-string)
(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-string)
(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string)
(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string)
(defalias 'mail-content-type-get 'rfc2231-get-value)
(defalias 'mail-header-encode-parameter 'rfc2045-encode-string)
;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string)
(defalias 'mail-header-encode-parameter 'rfc2231-encode-string)
(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments)
(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace)
@ -58,7 +59,11 @@
(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header)
(defalias 'mail-quote-string 'ietf-drums-quote-string)
(defalias 'mail-header-fold-field 'rfc2047-fold-field)
(defalias 'mail-header-unfold-field 'rfc2047-unfold-field)
(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field)
(defalias 'mail-header-field-value 'rfc2047-field-value)
(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region)
(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header)
(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string)

2
lisp/gnus/mail-prsvr.el
View File

@ -1,4 +1,4 @@
;;; mail-prsvr.el --- interface variables for parsing mail
;;; mail-prsvr.el --- Interface variables for parsing mail
;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>

81
lisp/gnus/mail-reply.xpm
View File

@ -1,51 +1,32 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 21 1",
" c Gray0",
". c Gray6",
"X c Gray12",
"o c #2ff02ff02ff0",
"O c #3fff3fff3fff",
"+ c Gray28",
"@ c #53f353f353f3",
"# c #5ff95ff95ff9",
"$ c #67e767e767e7",
"% c #6fff6fff6fff",
"& c #77dc77dc77dc",
"* c Gray50",
"= c Gray56",
"- c #9beb9beb9beb",
"; c #9fff9fff9fff",
": c Gray70",
"> c Gray75",
", c Gray81",
"< c #dfffdfffdfff",
"1 c #efffefffefff",
"2 c Gray100",
/* pixels */
">>>>>>>>>>>>>>>==:>>>>>>",
">>>>>>>>>>>>>>&**$&>>>>>",
">>>>>>>>>>>>>&-22,-o->>>",
">>>>>>>>>=$O@$,,2222O>>>",
">>>>>>>=#*>2*>2O222>$>>>",
">>>>>>o&>222O2%,22,$:>>>",
">>>:$O2222<#2*>222=+:>>>",
">>&$>;;2;2*>2><22;**$&>>",
">>o.;,,2,,*1%222;;,O;o>>",
">>o2;O><2O2,%221#o%22o>>",
">>o222***O2;22;**<222o>>",
">>o2222<>.;2,O;,22222o>>",
">>o2221>#2;O%;;,22222o>>",
">>o222**<22222;*>2222o>>",
">>o22%,222222221*,222o>>",
">>o;O,22222222222%#<2o>>",
">>o;22222222222222<**o>>",
">>oOOOOOOOOOOOOOOOOX o>>",
">>>>>>>>>>>>>>>>>>>>>>>>",
">>>>>>>>>>>>>>>>>>>>>>>>",
">>>>>>>>>>>>>>>>>>>>>>>>",
">>>>>>>>>>>>>>>>>>>>>>>>",
">>>>>>>>>>>>>>>>>>>>>>>>",
">>>>>>>>>>>>>>>>>>>>>>>>"
};
static char * mail_reply_xpm[] = {
"24 24 5 1",
" c None",
". c #000000000000",
"X c #E1E1E0E0E0E0",
"O c #FFFFFFFFFFFF",
"o c #C7C7C6C6C6C6",
" .. ",
" .X. ",
" ..XX. ",
" ......XoXX.. ",
" ...OOO.XooXXX. ",
" ..OOOO.XooXXX. ",
" ...OOOOO.XooXXX... ",
" ..OOOOOO.XXooXX.OO.. ",
" ...OOOO.oooXXX...... ",
" .O...O.oXooXXX...OO. ",
" .OOO...oXoXX...OOOO. ",
" .OOOOO...X...OOOOOO. ",
" .OOOOO.O...OO.OOOOO. ",
" .OOO..OOOOOOOO..OOO. ",
" .OO.OOOOOOOOOOOO.OO. ",
" .O.OOOOOOOOOOOOOO.O. ",
" ..OOOOOOOOOOOOOOOO.. ",
" .................... ",
" ",
" ",
" ",
" ",
" ",
" "};

291
lisp/gnus/mail-source.el
View File

@ -1,5 +1,6 @@
;;; mail-source.el --- functions for fetching mail
;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@ -32,9 +33,11 @@
(eval-and-compile
(autoload 'pop3-movemail "pop3")
(autoload 'pop3-get-message-count "pop3")
(autoload 'nnheader-cancel-timer "nnheader"))
(autoload 'nnheader-cancel-timer "nnheader")
(autoload 'nnheader-run-at-time "nnheader"))
(require 'format-spec)
(require 'mm-util)
(require 'message) ;; for `message-directory'
(defgroup mail-source nil
"The mail-fetching library."
@ -58,6 +61,7 @@
This variable is a list of mail source specifiers.
See Info node `(gnus)Mail Source Specifiers'."
:group 'mail-source
:link '(custom-manual "(gnus)Mail Source Specifiers")
:type `(repeat
(choice :format "%[Value Menu%] %v"
:value (file)
@ -81,10 +85,16 @@ See Info node `(gnus)Mail Source Specifiers'."
(function :tag "Predicate"))
(group :inline t
(const :format "" :value :prescript)
(string :tag "Prescript"))
(choice :tag "Prescript"
:value nil
(string :format "%v")
(function :format "%v")))
(group :inline t
(const :format "" :value :postscript)
(string :tag "Postscript"))
(choice :tag "Postscript"
:value nil
(string :format "%v")
(function :format "%v")))
(group :inline t
(const :format "" :value :plugged)
(boolean :tag "Plugged"))))
@ -111,10 +121,16 @@ See Info node `(gnus)Mail Source Specifiers'."
(string :tag "Program"))
(group :inline t
(const :format "" :value :prescript)
(string :tag "Prescript"))
(choice :tag "Prescript"
:value nil
(string :format "%v")
(function :format "%v")))
(group :inline t
(const :format "" :value :postscript)
(string :tag "Postscript"))
(choice :tag "Postscript"
:value nil
(string :format "%v")
(function :format "%v")))
(group :inline t
(const :format "" :value :function)
(function :tag "Function"))
@ -159,6 +175,9 @@ See Info node `(gnus)Mail Source Specifiers'."
(choice :tag "Stream"
:value network
,@mail-source-imap-streams))
(group :inline t
(const :format "" :value :program)
(string :tag "Program"))
(group :inline t
(const :format ""
:value :authenticator)
@ -213,18 +232,28 @@ See Info node `(gnus)Mail Source Specifiers'."
(const :format "" :value :plugged)
(boolean :tag "Plugged")))))))
(defcustom mail-source-ignore-errors nil
"*Ignore errors when querying mail sources.
If nil, the user will be prompted when an error occurs. If non-nil,
the error will be ignored.")
(defcustom mail-source-primary-source nil
"*Primary source for incoming mail.
If non-nil, this maildrop will be checked periodically for new mail."
:group 'mail-source
:type 'sexp)
(defcustom mail-source-flash t
"*If non-nil, flash periodically when mail is available."
:group 'mail-source
:type 'boolean)
(defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
"File where mail will be stored while processing it."
:group 'mail-source
:type 'file)
(defcustom mail-source-directory "~/Mail/"
(defcustom mail-source-directory message-directory
"Directory where files (if any) will be stored."
:group 'mail-source
:type 'directory)
@ -235,7 +264,23 @@ If non-nil, this maildrop will be checked periodically for new mail."
:type 'integer)
(defcustom mail-source-delete-incoming t
"*If non-nil, delete incoming files after handling."
"*If non-nil, delete incoming files after handling.
If t, delete immediately, if nil, never delete. If a positive number, delete
files older than number of days."
;; Note: The removing happens in `mail-source-callback', i.e. no old
;; incoming files will be deleted, unless you receive new mail.
;;
;; You may also set this to `nil' and call `mail-source-delete-old-incoming'
;; from a hook or interactively.
:group 'mail-source
:type '(choice (const :tag "immediately" t)
(const :tag "never" nil)
(integer :tag "days")))
(defcustom mail-source-delete-old-incoming-confirm t
"*If non-nil, ask for for confirmation before deleting old incoming files.
This variable only applies when `mail-source-delete-incoming' is a positive
number."
:group 'mail-source
:type 'boolean)
@ -254,6 +299,11 @@ If non-nil, this maildrop will be checked periodically for new mail."
:group 'mail-source
:type 'number)
(defcustom mail-source-movemail-program nil
"If non-nil, name of program for fetching new mail."
:group 'mail-source
:type '(choice (const nil) string))
;;; Internal variables.
(defvar mail-source-string ""
@ -295,18 +345,22 @@ Common keywords should be listed here.")
(:authentication password))
(maildir
(:path (or (getenv "MAILDIR") "~/Maildir/"))
(:subdirs ("new" "cur"))
(:subdirs ("cur" "new"))
(:function))
(imap
(:server (getenv "MAILHOST"))
(:port)
(:stream)
(:program)
(:authentication)
(:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
(:password)
(:mailbox "INBOX")
(:predicate "UNSEEN UNDELETED")
(:fetchflag "\\Deleted")
(:prescript)
(:prescript-delay)
(:postscript)
(:dontexpunge))
(webmail
(:subtype hotmail)
@ -365,7 +419,7 @@ the `mail-source-keyword-map' variable."
,@body))
(put 'mail-source-bind 'lisp-indent-function 1)
(put 'mail-source-bind 'edebug-form-spec '(form body))
(put 'mail-source-bind 'edebug-form-spec '(sexp body))
(defun mail-source-set-1 (source)
(let* ((type (pop source))
@ -408,7 +462,7 @@ See `mail-source-bind'."
,@body))
(put 'mail-source-bind-common 'lisp-indent-function 1)
(put 'mail-source-bind-common 'edebug-form-spec '(form body))
(put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
(defun mail-source-value (value)
"Return the value of VALUE."
@ -442,24 +496,52 @@ Return the number of files that were found."
(setq found (mail-source-callback
callback mail-source-crash-box)))
(+ found
(condition-case err
(if (or debug-on-quit debug-on-error)
(funcall function source callback)
(error
(unless (yes-or-no-p
(format "Mail source error (%s). Continue? " err))
(error "Cannot get new mail"))
0))))))))
(condition-case err
(funcall function source callback)
(error
(if (and (not mail-source-ignore-errors)
(not
(yes-or-no-p
(format "Mail source %s error (%s). Continue? "
(if (memq ':password source)
(let ((s (copy-sequence source)))
(setcar (cdr (memq ':password s))
"********")
s)
source)
(cadr err)))))
(error "Cannot get new mail"))
0)))))))))
(eval-and-compile
(if (fboundp 'make-temp-file)
(defalias 'mail-source-make-complex-temp-name 'make-temp-file)
(defun mail-source-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))))
(defun mail-source-delete-old-incoming (&optional age confirm)
"Remove incoming files older than AGE days.
If CONFIRM is non-nil, ask for confirmation before removing a file."
(interactive "P")
(let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
(low2days (/ 1.0 65536.0)) ;; convert low bits to days
(diff (if (natnump age) age 30));; fallback, if no valid AGE given
currday files)
(setq files (directory-files
mail-source-directory t
(concat mail-source-incoming-file-prefix "*"))
currday (* (car (current-time)) high2days)
currday (+ currday (* low2days (nth 1 (current-time)))))
(while files
(let* ((ffile (car files))
(bfile (gnus-replace-in-string
ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
(filetime (nth 5 (file-attributes ffile)))
(fileday (* (car filetime) high2days))
(fileday (+ fileday (* low2days (nth 1 filetime)))))
(setq files (cdr files))
(when (and (> (- currday fileday) diff)
(gnus-message 8 "File `%s' is older than %s day(s)"
bfile diff)
(or (not confirm)
(y-or-n-p (concat "Remove file `" bfile "'? "))))
(delete-file ffile))))))
(defun mail-source-callback (callback info)
"Call CALLBACK on the mail file, and then remove the mail file.
@ -474,16 +556,21 @@ Pass INFO on to CALLBACK."
(funcall callback mail-source-crash-box info)
(when (file-exists-p mail-source-crash-box)
;; Delete or move the incoming mail out of the way.
(if mail-source-delete-incoming
(if (eq mail-source-delete-incoming t)
(delete-file mail-source-crash-box)
(let ((incoming
(mail-source-make-complex-temp-name
(mm-make-temp-file
(expand-file-name
mail-source-incoming-file-prefix
mail-source-directory))))
(unless (file-exists-p (file-name-directory incoming))
(make-directory (file-name-directory incoming) t))
(rename-file mail-source-crash-box incoming t)))))))
(rename-file mail-source-crash-box incoming t)
;; remove old incoming files?
(when (natnump mail-source-delete-incoming)
(mail-source-delete-old-incoming
mail-source-delete-incoming
mail-source-delete-old-incoming-confirm))))))))
(defun mail-source-movemail (from to)
"Move FROM to TO using movemail."
@ -518,12 +605,15 @@ Pass INFO on to CALLBACK."
'call-process
(append
(list
(expand-file-name "movemail" exec-directory)
(or mail-source-movemail-program
(expand-file-name "movemail" exec-directory))
nil errors nil from to)))))
(when (file-exists-p to)
(set-file-modes to mail-source-default-file-modes))
(if (and (not (buffer-modified-p errors))
(zerop result))
(if (and (or (not (buffer-modified-p errors))
(zerop (buffer-size errors)))
(and (numberp result)
(zerop result)))
;; No output => movemail won.
t
(set-buffer errors)
@ -540,8 +630,9 @@ Pass INFO on to CALLBACK."
(goto-char (point-min))
(when (looking-at "movemail: ")
(delete-region (point-min) (match-end 0)))
;; Result may be a signal description string.
(unless (yes-or-no-p
(format "movemail: %s (%d return). Continue? "
(format "movemail: %s (%s return). Continue? "
(buffer-string) result))
(error "%s" (buffer-string)))
(setq to nil)))))))
@ -557,29 +648,13 @@ Pass INFO on to CALLBACK."
(not (zerop (nth 7 (file-attributes from))))
(delete-file from)))
(defvar mail-source-read-passwd nil)
(defun mail-source-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 mail-source-read-passwd
(if (or (fboundp 'read-passwd) (load "passwd" t))
(setq mail-source-read-passwd 'read-passwd)
(unless (fboundp 'ange-ftp-read-passwd)
(autoload 'ange-ftp-read-passwd "ange-ftp"))
(setq mail-source-read-passwd 'ange-ftp-read-passwd)))
(funcall mail-source-read-passwd prompt)))
(defun mail-source-fetch-with-program (program)
(zerop (call-process shell-file-name nil nil nil
shell-command-switch program)))
(eq 0 (call-process shell-file-name nil nil nil
shell-command-switch program)))
(defun mail-source-run-script (script spec &optional delay)
(when script
(if (and (symbolp script) (fboundp script))
(if (functionp script)
(funcall script)
(mail-source-call-script
(format-spec script spec))))
@ -616,8 +691,7 @@ If ARGS, PROMPT is used as an argument to `format'."
"Fetcher for directory sources."
(mail-source-bind (directory source)
(mail-source-run-script
prescript (format-spec-make ?t path)
prescript-delay)
prescript (format-spec-make ?t path) prescript-delay)
(let ((found 0)
(mail-source-string (format "directory:%s" path)))
(dolist (file (directory-files
@ -626,8 +700,7 @@ If ARGS, PROMPT is used as an argument to `format'."
(funcall predicate file)
(mail-source-movemail file mail-source-crash-box))
(incf found (mail-source-callback callback file))))
(mail-source-run-script
postscript (format-spec-make ?t path))
(mail-source-run-script postscript (format-spec-make ?t path))
found)))
(defun mail-source-fetch-pop (source callback)
@ -645,7 +718,7 @@ If ARGS, PROMPT is used as an argument to `format'."
(setq password
(or password
(cdr (assoc from mail-source-password-cache))
(mail-source-read-passwd
(read-passwd
(format "Password for %s at %s: " user server)))))
(when server
(setenv "MAILHOST" server))
@ -667,7 +740,17 @@ If ARGS, PROMPT is used as an argument to `format'."
(pop3-port port)
(pop3-authentication-scheme
(if (eq authentication 'apop) 'apop 'pass)))
(save-excursion (pop3-movemail mail-source-crash-box))))))
(if (or debug-on-quit debug-on-error)
(save-excursion (pop3-movemail mail-source-crash-box))
(condition-case err
(save-excursion (pop3-movemail mail-source-crash-box))
(error
;; We nix out the password in case the error
;; was because of a wrong password being given.
(setq mail-source-password-cache
(delq (assoc from mail-source-password-cache)
mail-source-password-cache))
(signal (car err) (cdr err)))))))))
(if result
(progn
(when (eq authentication 'password)
@ -699,7 +782,7 @@ If ARGS, PROMPT is used as an argument to `format'."
(setq password
(or password
(cdr (assoc from mail-source-password-cache))
(mail-source-read-passwd
(read-passwd
(format "Password for %s at %s: " user server))))
(unless (assoc from mail-source-password-cache)
(push (cons from password) mail-source-password-cache)))
@ -718,7 +801,17 @@ If ARGS, PROMPT is used as an argument to `format'."
(pop3-port port)
(pop3-authentication-scheme
(if (eq authentication 'apop) 'apop 'pass)))
(save-excursion (pop3-get-message-count))))))
(if (or debug-on-quit debug-on-error)
(save-excursion (pop3-get-message-count))
(condition-case err
(save-excursion (pop3-get-message-count))
(error
;; We nix out the password in case the error
;; was because of a wrong password being given.
(setq mail-source-password-cache
(delq (assoc from mail-source-password-cache)
mail-source-password-cache))
(signal (car err) (cdr err)))))))))
(if result
;; Inform display-time that we have new mail.
(setq mail-source-new-mail-available (> result 0))
@ -729,8 +822,31 @@ If ARGS, PROMPT is used as an argument to `format'."
mail-source-password-cache)))
result)))
(defun mail-source-touch-pop ()
"Open and close a POP connection shortly.
POP server should be defined in `mail-source-primary-source' (which is
preferred) or `mail-sources'. You may use it for the POP-before-SMTP
authentication. To do that, you need to set the
`message-send-mail-function' variable as `message-smtpmail-send-it'
and put the following line in your ~/.gnus.el file:
\(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
See the Gnus manual for details."
(let ((sources (if mail-source-primary-source
(list mail-source-primary-source)
mail-sources)))
(while sources
(if (eq 'pop (car (car sources)))
(mail-source-check-pop (car sources)))
(setq sources (cdr sources)))))
(defun mail-source-new-mail-p ()
"Handler for `display-time' to indicate when new mail is available."
;; Flash (ie. ring the visible bell) if mail is available.
(if (and mail-source-flash mail-source-new-mail-available)
(let ((visible-bell t))
(ding)))
;; Only report flag setting; flag is updated on a different schedule.
mail-source-new-mail-available)
@ -753,8 +869,9 @@ If ARGS, PROMPT is used as an argument to `format'."
mail-source-idle-time-delay
nil
(lambda ()
(setq mail-source-report-new-mail-idle-timer nil)
(mail-source-check-pop mail-source-primary-source))))
(unwind-protect
(mail-source-check-pop mail-source-primary-source)
(setq mail-source-report-new-mail-idle-timer nil)))))
;; Since idle timers created when Emacs is already in the idle
;; state don't get activated until Emacs _next_ becomes idle, we
;; need to force our timer to be considered active now. We do
@ -785,8 +902,10 @@ This only works when `display-time' is enabled."
(setq display-time-mail-function #'mail-source-new-mail-p)
;; Set up the main timer.
(setq mail-source-report-new-mail-timer
(run-at-time t (* 60 mail-source-report-new-mail-interval)
#'mail-source-start-idle-timer))
(nnheader-run-at-time
(* 60 mail-source-report-new-mail-interval)
(* 60 mail-source-report-new-mail-interval)
#'mail-source-start-idle-timer))
;; When you get new mail, clear "Mail" from the mode line.
(add-hook 'nnmail-post-get-new-mail-hook
'display-time-event-handler)
@ -817,13 +936,13 @@ This only works when `display-time' is enabled."
(with-temp-file mail-source-crash-box
(insert-file-contents file)
(goto-char (point-min))
;;; ;; Unix mail format
;;; (unless (looking-at "\n*From ")
;;; (insert "From maildir "
;;; (current-time-string) "\n"))
;;; (while (re-search-forward "^From " nil t)
;;; (replace-match ">From "))
;;; (goto-char (point-max))
;;; ;; Unix mail format
;;; (unless (looking-at "\n*From ")
;;; (insert "From maildir "
;;; (current-time-string) "\n"))
;;; (while (re-search-forward "^From " nil t)
;;; (replace-match ">From "))
;;; (goto-char (point-max))
;;; (insert "\n\n")
;; MMDF mail format
(insert "\001\001\001\001\n"))
@ -852,10 +971,15 @@ This only works when `display-time' is enabled."
(defun mail-source-fetch-imap (source callback)
"Fetcher for imap sources."
(mail-source-bind (imap source)
(mail-source-run-script
prescript (format-spec-make ?p password ?t mail-source-crash-box
?s server ?P port ?u user)
prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(found 0)
(buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
(buf (generate-new-buffer " *imap source*"))
(mail-source-string (format "imap:%s:%s" server mailbox))
(imap-shell-program (or (list program) imap-shell-program))
remove)
(if (and (imap-open server port stream authentication buf)
(imap-authenticate
@ -870,12 +994,16 @@ This only works when `display-time' is enabled."
(mm-disable-multibyte)
;; remember password
(with-current-buffer buf
(when (or imap-password
(assoc from mail-source-password-cache))
(when (and imap-password
(not (assoc from mail-source-password-cache)))
(push (cons from imap-password) mail-source-password-cache)))
;; if predicate is nil, use all uids
(dolist (uid (imap-search (or predicate "1:*") buf))
(when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
(when (setq str
(if (imap-capability 'IMAP4rev1 buf)
(caddar (imap-fetch uid "BODY.PEEK[]"
'BODYDETAIL nil buf))
(imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
(push uid remove)
(insert "From imap " (current-time-string) "\n")
(save-excursion
@ -886,12 +1014,13 @@ This only works when `display-time' is enabled."
(nnheader-ms-strip-cr))
(incf found (mail-source-callback callback server))
(when (and remove fetchflag)
(setq remove (nreverse remove))
(imap-message-flags-add
(imap-range-to-message-set (gnus-compress-sequence remove))
fetchflag nil buf))
(if dontexpunge
(imap-mailbox-unselect buf)
(imap-mailbox-close buf))
(imap-mailbox-close nil buf))
(imap-close buf))
(imap-close buf)
;; We nix out the password in case the error
@ -899,8 +1028,12 @@ This only works when `display-time' is enabled."
(setq mail-source-password-cache
(delq (assoc from mail-source-password-cache)
mail-source-password-cache))
(error (imap-error-text buf)))
(error "IMAP error: %s" (imap-error-text buf)))
(kill-buffer buf)
(mail-source-run-script
postscript
(format-spec-make ?p password ?t mail-source-crash-box
?s server ?P port ?u user))
found)))
(eval-and-compile
@ -917,7 +1050,7 @@ This only works when `display-time' is enabled."
(or password
(cdr (assoc (format "webmail:%s:%s" subtype user)
mail-source-password-cache))
(mail-source-read-passwd
(read-passwd
(format "Password for %s at %s: " user subtype))))
(when (and password
(not (assoc (format "webmail:%s:%s" subtype user)

Some files were not shown because too many files have changed in this diff Show More