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

Update Gnus to No Gnus 0.7 from the Gnus CVS trunk

Browse Source 
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-911
This commit is contained in:
Miles Bader 2007-10-28 09:18:39 +00:00
parent ccae01a639
commit 01c52d3165
166 changed files with 27871 additions and 9376 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

453
doc/misc/ChangeLog
View File

@ -1,3 +1,456 @@
2007-10-28 Miles Bader <miles@gnu.org>
* gnus-news.texi, gnus-coding.texi, sasl.texi: New files.
2007-10-28 Emanuele Giaquinta <e.giaquinta@glauco.it> (tiny change)
* gnus-faq.texi ([5.12]): Remove reference to discontinued service.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Sorting the Summary Buffer): Remove
gnus-article-sort-by-date-reverse.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Non-ASCII Group Names): New node.
(Misc Group Stuff): Move gnus-group-name-charset-method-alist and
gnus-group-name-charset-group-alist to Non-ASCII Group Names node.
2007-10-28 Micha,Ak(Bl Cadilhac <michael@cadilhac.name>
* gnus.texi (Mail Source Specifiers, IMAP): Add a notice on the need to
clean the output of the program `imap-shell-program'.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (IMAP): Mention nnimap-logout-timeout.
2007-10-28 Tassilo Horn <tassilo@member.fsf.org>
* gnus.texi (Sticky Articles): Documentation for sticky article
buffers.
2007-10-28 Micha,Ak(Bl Cadilhac <michael@cadilhac.name>
* gnus.texi (RSS): Document nnrss-ignore-article-fields.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Various Various): Mention gnus-add-timestamp-to-message.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Archived Messages): Document
gnus-update-message-archive-method.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Limiting): Document gnus-summary-limit-to-address.
2007-10-28 Micha,Ak(Bl Cadilhac <michael@cadilhac.name>
* gnus.texi (Group Maneuvering): Document
`gnus-summary-next-group-on-exit'.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Really Various Summary Commands): Mention
gnus-auto-select-on-ephemeral-exit.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi, message.texi: Bump version number.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Group Line Specification, Misc Group Stuff)
(Server Commands): Parenthesize @pxref{Mail Spool}.
2007-10-28 Didier Verna <didier@xemacs.org>
New user option: message-signature-directory.
* message.texi (Insertion Variables): Document it.
* gnus.texi (Posting Styles): Ditto.
2007-10-28 Didier Verna <didier@xemacs.org>
* gnus.texi (Group Line Specification):
* gnus.texi (Misc Group Stuff):
* gnus.texi (Server Commands): Document the group compaction feature.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-faq.texi ([5.2]): Adjust for message-fill-column.
* message.texi (Various Message Variables): Add message-fill-column.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi: Untabify.
2007-10-28 Didier Verna <didier@xemacs.org>
* gnus.texi (Group Parameters): Document the posting-style merging
process in topic-mode.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Scoring On Other Headers): Add gnus-inhibit-slow-scoring.
2007-10-28 Romain Francoise <romain@orebokech.com>
* gnus.texi (Mail Spool): Fix typo.
Update copyright.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Limiting): Add gnus-summary-limit-to-singletons.
2007-10-28 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de>
* gnus.texi (Summary Generation Commands):
Add gnus-summary-insert-ticked-articles.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi
(SpamAssassin back end): Rename spam-spamassassin-path to
spam-spamassassin-program.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Mail and Post): Add gnus-message-highlight-citation.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Limiting): Add gnus-summary-limit-to-headers.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* message.texi (Mail Headers): Document `opportunistic'.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* emacs-mime.texi (Encoding Customization): Explain how to set
mm-coding-system-priorities per hierarchy.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Washing Mail): Add nnmail-ignore-broken-references and
nnmail-broken-references-mailers instead of nnmail-fix-eudora-headers.
2007-10-28 Didier Verna <didier@xemacs.org>
* message.texi (Wide Reply): Update documentation of
message-dont-reply-to-names (now allowing a list of regexps).
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Spam Package Introduction): Fix spam menu and links.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (SpamAssassin back end): Fix typo.
* sieve.texi (Examples): Fix grammar.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Searching for Articles): Document M-S and M-R.
(Limiting): Document / b.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Thread Commands): T M-^.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* message.texi (Mail Aliases): Document ecomplete.
(Mail Aliases): Fix typo.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Face): Restore xref to gnus-face-properties-alist;
fix typo.
2007-10-28 Romain Francoise <romain@orebokech.com>
* gnus.texi (Mail Spool): Grammar fix.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Mail Spool): nnml-use-compressed-files can be a
string.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Group Parameters): Fix description.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Gmane Spam Reporting): Fix
spam-report-gmane-use-article-number. Add
spam-report-user-mail-address.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* emacs-mime.texi (Non-MIME): x-gnus-verbatim -> x-verbatim.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Group Parameters): Add simplified sorting example based on
example for `Sorting the Summary Buffer' from Jari Aalto
<jari.aalto@cante.net>.
(Example Methods): Add example for an indirect connection.
2007-10-28 Kevin Greiner <kevin.greiner@compsol.cc>
* gnus.texi (nntp-open-via-telnet-and-telnet): Fixed grammar.
(Agent Parameters): Updated parameter names to match code.
(Group Agent Commands): Corrected 'gnus-agent-fetch-series' as
'gnus-agent-summary-fetch-series'.
(Agent and flags): New section providing a generalized discussion
of flag handling.
(Agent and IMAP): Removed flag discussion.
(Agent Variables): Added 'gnus-agent-synchronize-flags'
2007-10-28 Romain Francoise <romain@orebokech.com>
* gnus.texi (Exiting the Summary Buffer): Add new function
`gnus-summary-catchup-and-goto-prev-group', bound to `Z p'.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Conformity): Fix typo.
(Customizing Articles): Document `first'.
2007-10-28 Jari Aalto <jari.aalto@cante.net>
* gnus.texi (Sorting the Summary Buffer):
Add `gnus-thread-sort-by-date-reverse'. Add example
host to different sorting in NNTP and RSS groups.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* message.texi (Insertion): Describe prefix for
message-mark-inserted-region and message-mark-insert-file.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* emacs-mime.texi (Non-MIME): Add Slrn-style verbatim marks and
LaTeX documents. Describe "text/x-gnus-verbatim".
2007-10-28 Teodor Zlatanov <tzz@lifelogs.com>
* gnus.texi (Blacklists and Whitelists)
(Blacklists and Whitelists, BBDB Whitelists)
(Gmane Spam Reporting, Bogofilter, spam-stat spam filtering)
(spam-stat spam filtering, SpamOracle)
(Extending the Spam ELisp package): Removed extra quote symbol for
clarity.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (MIME Commands): Add gnus-article-save-part-and-strip,
gnus-article-delete-part and gnus-article-replace-part.
(Using MIME): Add gnus-mime-replace-part.
2007-10-28 Romain Francoise <romain@orebokech.com>
* gnus.texi (Mail Spool): Mention that `nnml-use-compressed-files'
requires `auto-compression-mode' to be enabled. Add new nnml
variable `nnml-compressed-files-size-threshold'.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Sorting the Summary Buffer): Added
gnus-thread-sort-by-recipient.
2007-10-28 Romain Francoise <romain@orebokech.com>
* message.texi (Insertion Variables): Mention new variable
`message-yank-empty-prefix'. Change `message-yank-cited-prefix'
documentation accordingly.
2007-10-28 Romain Francoise <romain@orebokech.com>
* gnus.texi (To From Newsgroups): Mention new variables
`gnus-summary-to-prefix' and `gnus-summary-newsgroup-prefix'.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Using MIME): gnus-mime-copy-part supports the charset
stuff; gnus-mime-inline-part does the automatic decompression.
2007-10-28 Teodor Zlatanov <tzz@lifelogs.com>
* gnus.texi (Spam ELisp Package Configuration Examples):
"training.ham" should be "training.spam"
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* message.texi (Mail Variables): Fix the default value for
message-send-mail-function.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (Optional Back End Functions): nntp-request-update-info
always returns nil exceptionally.
2007-10-28 Simon Josefsson <jas@extundo.com>
* gnus.texi (Article Washing): Add libidn URL. Suggested by
Michael Cook <michael@waxrat.com>.
2007-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Topic Commands): Fix next/previous.
2007-10-28 Simon Josefsson <jas@extundo.com>
* gnus.texi (Article Washing): Mention `W i'.
2007-10-28 Jochen K,A|(Bpper <jochen@fhi-berlin.mpg.de>
* gnus.texi (Group Parameters): Slight extension of sieve
parameter description.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Score Decays): `gnus-decay-scores' can be a regexp
matching score files as well.
(Picons): Describe `gnus-picon-style'.
2007-10-28 Romain Francoise <romain@orebokech.com>
* message.texi (Message Headers): Mention that headers are hidden
using narrowing, and how to expose them.
Update copyright.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnusref.tex: Mention `gnus-summary-limit-to-recipient' and
`gnus-summary-sort-by-recipient'.
2007-10-28 Romain Francoise <romain@orebokech.com>
* gnus.texi (NNTP marks): New node.
(NNTP): Move NNTP marks variables to the new node.
2007-10-28 Jesper Harder <harder@ifa.au.dk>
* gnus.texi, gnus-news.texi, pgg.texi, sasl.texi: backend -> back
end.
* gnus.texi (MIME Commands, Hashcash): Markup fix.
2007-10-28 Teodor Zlatanov <tzz@lifelogs.com>
* gnus.texi: replaced @file{spam.el} with @code{spam.el}
everywhere for consistency.
(Filtering Spam Using The Spam ELisp Package): admonish again.
(Spam ELisp Package Sequence of Events): this is Gnus, say so.
Say "regular expression" instead of "regex." Admonish. Pick
other words to sound better (s/so/thus/).
(Spam ELisp Package Filtering of Incoming Mail): mention
statistical filters. Remove old TODO.
(Spam ELisp Package Sorting and Score Display in Summary Buffer):
new section on sorting and displaying the spam score
(BBDB Whitelists): mention spam-use-BBDB-exclusive is not a
backend but an alias to spam-use-BBDB
(Extending the Spam ELisp package): rewrite the example using the
new backend functionality.
2007-10-28 Simon Josefsson <jas@extundo.com>
* gnus.texi (NNTP): Mention nntp-marks-is-evil and
nntp-marks-directory, from Romain Francoise
<romain@orebokech.com>.
2007-10-28 Magnus Henoch <mange@freemail.hu>
* gnus.texi (Hashcash): New default value of
hashcash-default-payment.
2007-10-28 Simon Josefsson <jas@extundo.com>
* gnus.texi (Hashcash): Fix URL. Add pref to spam section.
(Anti-spam Hashcash Payments): No need to load hashcash.el now.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Adaptive Scoring): Added gnus-adaptive-pretty-print.
2007-10-28 Simon Josefsson <jas@extundo.com>
* gnus.texi (documentencoding): Add, to avoid warnings.
2007-10-28 Simon Josefsson <jas@extundo.com>
* message.texi (Mail Headers): Add.
* gnus.texi (Hashcash): Fix.
2007-10-28 Teodor Zlatanov <tzz@lifelogs.com>
* gnus.texi (Hashcash): changed location of library, also mention
that payments can be verified and fix the name of the
hashcash-path variable
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi
(Article Display): Add `gnus-picon-style'.
2007-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus.texi (SpamAssassin backend): Add it to the detailmenu.
2007-10-28 Teodor Zlatanov <tzz@lifelogs.com>
* gnus.texi (Blacklists and Whitelists, BBDB Whitelists)
(Bogofilter, spam-stat spam filtering, SpamOracle): old incorrect
warning about ham processors in spam groups removed
2007-10-28 Teodor Zlatanov <tzz@lifelogs.com>
From Hubert Chan <hubert@uhoreg.ca>
* gnus.texi (SpamAssassin backend): added new node about SpamAssassin
2007-10-28 Jesper Harder <harder@ifa.au.dk>
* gnus.texi (Spam ELisp Package Sequence of Events): Index.
(Mailing List): Typo.
(Customizing Articles): Add gnus-treat-ansi-sequences.
(Article Washing): Index.
* message.texi: Use m-dash consistently.
2007-10-28 Jesper Harder <harder@ifa.au.dk>
* gnus.texi (GroupLens): Remove.
2007-10-28 Kevin Greiner <kgreiner@xpediantsolutions.com>
* gnus.texi (Outgoing Messages, Agent Variables): Add
gnus-agent-queue-mail and gnus-agent-prompt-send-queue.
Suggested by Gaute Strokkenes <gs234@srcf.ucam.org>
2007-10-28 Jesper Harder <harder@ifa.au.dk>
* gnus.texi (Limiting): Add gnus-summary-limit-to-replied.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.texi (Article Washing): Add `gnus-article-treat-ansi-sequences'.
* gnus.texi (No Gnus): New node. Includes `gnus-news.texi'.
2007-10-28 Simon Josefsson <jas@extundo.com>
* gnus.texi (Top): Add SASL.
2007-10-27 Jay Belanger <jay.p.belanger@gmail.com>
* calc.texi (Formulas, Composition Basics): Lower the

55
doc/misc/emacs-mime.texi
View File

@ -180,8 +180,27 @@ Patches. This is intended for groups where diffs of committed files
are automatically sent to. It only works in groups matching
@code{mm-uu-diff-groups-regexp}.
@item verbatim-marks
@cindex verbatim-marks
Slrn-style verbatim marks.
@item LaTeX
@cindex LaTeX
LaTeX documents. It only works in groups matching
@code{mm-uu-tex-groups-regexp}.
@end table
@cindex text/x-verbatim
@c Is @vindex suitable for a face?
@vindex mm-uu-extract
Some inlined non-@acronym{MIME} attachments are displayed using the face
@code{mm-uu-extract}. By default, no @acronym{MIME} button for these
parts is displayed. You can force displaying a button using @kbd{K b}
(@code{gnus-summary-display-buttonized}) or add @code{text/x-verbatim}
to @code{gnus-buttonized-mime-types}, @xref{MIME Commands, ,MIME
Commands, gnus, Gnus Manual}.
@node Handles
@section Handles
@ -849,6 +868,36 @@ ISO-8859-1 if possible, you can set this variable to
@code{(iso-8859-1)}. You can override this setting on a per-message
basis by using the @code{charset} @acronym{MML} tag (@pxref{MML Definition}).
As different hierarchies prefer different charsets, you may want to set
@code{mm-coding-system-priorities} according to the hierarchy in Gnus.
Here's an example:
@c Corrections about preferred charsets are welcome. de, fr and fj
@c should be correct, I don't know about the rest (so these are only
@c examples):
@lisp
(add-to-list 'gnus-newsgroup-variables 'mm-coding-system-priorities)
(setq gnus-parameters
(nconc
;; Some charsets are just examples!
'(("^cn\\." ;; Chinese
(mm-coding-system-priorities
'(iso-8859-1 cn-big5 chinese-iso-7bit utf-8)))
("^cz\\.\\|^pl\\." ;; Central and Eastern European
(mm-coding-system-priorities '(iso-8859-2 utf-8)))
("^de\\." ;; German language
(mm-coding-system-priorities '(iso-8859-1 iso-8859-15 utf-8)))
("^fr\\." ;; French
(mm-coding-system-priorities '(iso-8859-15 iso-8859-1 utf-8)))
("^fj\\." ;; Japanese
(mm-coding-system-priorities
'(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8)))
("^ru\\." ;; Cyrillic
(mm-coding-system-priorities
'(koi8-r iso-8859-5 iso-8859-1 utf-8))))
gnus-parameters))
@end lisp
@item mm-content-transfer-encoding-defaults
@vindex mm-content-transfer-encoding-defaults
Mapping from @acronym{MIME} types to encoding to use. This variable is usually
@ -1155,7 +1204,7 @@ Return the value of the field under point.
@item mail-encode-encoded-word-region
@findex mail-encode-encoded-word-region
Encode the non-@acronym{ASCII} words in the region. For instance,
@samp{Naïve} is encoded as @samp{=?iso-8859-1?q?Na=EFve?=}.
@samp{Na@"{@dotless{i}}ve} is encoded as @samp{=?iso-8859-1?q?Na=EFve?=}.
@item mail-encode-encoded-word-buffer
@findex mail-encode-encoded-word-buffer
@ -1168,7 +1217,7 @@ Encode the words that need encoding in a string, and return the result.
@example
(mail-encode-encoded-word-string
"This is naïve, baby")
"This is na@"{@dotless{i}}ve, baby")
@result{} "This is =?iso-8859-1?q?na=EFve,?= baby"
@end example
@ -1183,7 +1232,7 @@ Decode the encoded words in the string and return the result.
@example
(mail-decode-encoded-word-string
"This is =?iso-8859-1?q?na=EFve,?= baby")
@result{} "This is naïve, baby"
@result{} "This is na@"{@dotless{i}}ve, baby"
@end example
@end table

381
doc/misc/gnus-coding.texi Normal file
View File

@ -0,0 +1,381 @@
\input texinfo
@setfilename gnus-coding
@settitle Gnus Coding Style and Maintainance Guide
@syncodeindex fn cp
@syncodeindex vr cp
@syncodeindex pg cp
@copying
Copyright (c) 2004, 2005, 2007 Free Software Foundation, Inc.
@quotation
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.1 or
any later version published by the Free Software Foundation; with no
Invariant Sections, with the Front-Cover texts being ``A GNU
Manual'', and with the Back-Cover Texts as in (a) below. A copy of the
license is included in the section entitled ``GNU Free Documentation
License'' in the Emacs manual.
(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
this GNU Manual, like GNU software. Copies published by the Free
Software Foundation raise funds for GNU development.''
This document is part of a collection distributed under the GNU Free
Documentation License. If you want to distribute this document
separately from the collection, you can do so by adding a copy of the
license to the document, as described in section 6 of the license.
@end quotation
@end copying
@titlepage
@title Gnus Coding Style and Maintainance Guide
@author by Reiner Steib <Reiner.Steib@@gmx.de>
@insertcopying
@end titlepage
@c Obviously this is only a very rudimentary draft. We put it in CVS
@c anyway hoping that it might annoy someone enough to fix it. ;-)
@c Fixing only a paragraph also is appreciated.
@node Top
@top Gnus Coding Style and Maintainance Guide
This manual describes @dots{}
@menu
* Gnus Coding Style:: Gnus Coding Style
* Gnus Maintainance Guide:: Gnus Maintainance Guide
@end menu
@c @ref{Gnus Reference Guide, ,Gnus Reference Guide, gnus, The Gnus Newsreader}
@node Gnus Coding Style
@chapter Gnus Coding Style
@section Dependencies
The Gnus distribution contains a lot of libraries that have been written
for Gnus and used intensively for Gnus. But many of those libraries are
useful on their own. E.g. other Emacs Lisp packages might use the
@acronym{MIME} library @xref{Top, ,Top, emacs-mime, The Emacs MIME
Manual}.
@subsection General purpose libraries
@table @file
@item netrc.el
@file{.netrc} parsing functionality.
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item format-spec.el
Functions for formatting arbitrary formatting strings.
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item hex-util.el
Functions to encode/decode hexadecimal string.
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@end table
@subsection Encryption and security
@table @file
@item encrypt.el
File encryption routines
@c As of 2005-10-25...
There are no Gnus dependencies in this file.
@item password.el
Read passwords from user, possibly using a password cache.
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item tls.el
TLS/SSL support via wrapper around GnuTLS
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item pgg*.el
Glue for the various PGP implementations.
@c As of 2005-10-21...
There are no Gnus dependencies in these files.
@item sha1.el
SHA1 Secure Hash Algorithm.
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@end table
@subsection Networking
@table @file
@item dig.el
Domain Name System dig interface.
@c As of 2005-10-21...
There are no serious Gnus dependencies in this file. Uses
@code{gnus-run-mode-hooks} (a wrapper function).
@item dns.el, dns-mode.el
Domain Name Service lookups.
@c As of 2005-10-21...
There are no Gnus dependencies in these files.
@end table
@subsection Mail and News related RFCs
@table @file
@item pop3.el
Post Office Protocol (RFC 1460) interface.
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item imap.el
@acronym{IMAP} library.
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item ietf-drums.el
Functions for parsing RFC822bis headers.
@c As of 2005-10-21...
There are no Gnus dependencies in this file.
@item rfc1843.el
HZ (rfc1843) decoding. HZ is a data format for exchanging files of
arbitrarily mixed Chinese and @acronym{ASCII} characters.
@c As of 2005-10-21...
@code{rfc1843-gnus-setup} seem to be useful only for Gnus. Maybe this
function should be relocated to remove dependencies on Gnus. Other
minor dependencies: @code{gnus-newsgroup-name} could be eliminated by
using an optional argument to @code{rfc1843-decode-article-body}.
@item rfc2045.el
Functions for decoding rfc2045 headers
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@item rfc2047.el
Functions for encoding and decoding rfc2047 messages
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@c
Only a couple of tests for gnusy symbols.
@item rfc2104.el
RFC2104 Hashed Message Authentication Codes
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@item rfc2231.el
Functions for decoding rfc2231 headers
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@item flow-fill.el
Interpret RFC2646 "flowed" text.
@c As of 2005-10-27...
There are no Gnus dependencies in this file.
@item uudecode.el
Elisp native uudecode.
@c As of 2005-12-06...
There are no Gnus dependencies in this file.
@c ... but the custom group is gnus-extract.
@item canlock.el
Functions for Cancel-Lock feature
@c Cf. draft-ietf-usefor-cancel-lock-01.txt
@c Although this draft has expired, Canlock-Lock revived in 2007 when
@c major news providers (e.g. news.individual.org) started to use it.
@c As of 2007-08-25...
There are no Gnus dependencies in these files.
@end table
@subsection message
All message composition from Gnus (both mail and news) takes place in
Message mode buffers. Message mode is intended to be a replacement for
Emacs mail mode. There should be no Gnus dependencies in
@file{message.el}. Alas it is not anymore. Patches and suggestions to
remove the dependencies are welcome.
@c message.el requires nnheader which requires gnus-util.
@subsection Emacs @acronym{MIME}
The files @file{mml*.el} and @file{mm-*.el} provide @acronym{MIME}
functionality for Emacs.
@acronym{MML} (@acronym{MIME} Meta Language) is supposed to be
independent from Gnus. Alas it is not anymore. Patches and suggestions
to remove the dependencies are welcome.
@subsection Gnus backends
The files @file{nn*.el} provide functionality for accessing NNTP
(@file{nntp.el}), IMAP (@file{nnimap.el}) and several other Mail back
ends (probably @file{nnml.el}, @file{nnfolder.el} and
@file{nnmaildir.el} are the most widely used mail back ends).
@c mm-uu requires nnheader which requires gnus-util. message.el also
@c requires nnheader.
@section Compatibility
No Gnus and Gnus 5.10.10 and up should work on:
@itemize @bullet
@item
Emacs 21.1 and up.
@item
XEmacs 21.4 and up.
@end itemize
Gnus 5.10.8 and below should work on:
@itemize @bullet
@item
Emacs 20.7 and up.
@item
XEmacs 21.1 and up.
@end itemize
@node Gnus Maintainance Guide
@chapter Gnus Maintainance Guide
@section Stable and development versions
The development of Gnus normally is done on the CVS trunk, i.e. there
are no separate branches to develop and test new features. Most of the
time, the trunk is developed quite actively with more or less daily
changes. Only after a new major release, e.g. 5.10.1, there's usually a
feature period of several months. After the release of Gnus 5.10.6 the
development of new features started again on the trunk while the 5.10
series is continued on the stable branch (v5-10) from which more stable
releases will be done when needed (5.10.7, @dots{}).
@ref{Gnus Development, ,Gnus Development, gnus, The Gnus Newsreader}
Stable releases of Gnus finally become part of Emacs. E.g. Gnus 5.8
became a part of Emacs 21 (relabeled to Gnus 5.9). The 5.10 series
became part of Emacs 22 as Gnus 5.11.
@section Syncing
@c Some MIDs related to this follow. Use http://thread.gmane.org/MID
@c (and click on the subject) to get the thread on Gmane.
@c Some quotes from Miles Bader follow...
@c <v9eklyke6b.fsf@marauder.physik.uni-ulm.de>
@c <buovfd71nkk.fsf@mctpc71.ucom.lsi.nec.co.jp>
In the past, the inclusion of Gnus into Emacs was quite cumbersome. For
each change made to Gnus in Emacs repository, it had to be checked that
it was applied to the new Gnus version, too. Else, bug fixes done in
Emacs repository might have been lost.
With the inclusion of Gnus 5.10, Miles Bader has set up an Emacs-Gnus
gateway to ensure the bug fixes from Emacs CVS are propagated to Gnus
CVS semi-automatically. These bug fixes are installed on the stable
branch and on the trunk. Basically the idea is that the gateway will
cause all common files in Emacs and Gnus v5-10 to be identical except
when there's a very good reason (e.g., the Gnus version string in Emacs
says @samp{5.11}, but the v5-10 version string remains @samp{5.10.x}).
Furthermore, all changes in these files in either Emacs or the v5-10
branch will be installed into the Gnus CVS trunk, again except where
there's a good reason.
@c (typically so far the only exception has been that the changes
@c already exist in the trunk in modified form).
Because of this, when the next major version of Gnus will be included in
Emacs, it should be very easy -- just plonk in the files from the Gnus
trunk without worrying about lost changes from the Emacs tree.
The effect of this is that as hacker, you should generally only have to
make changes in one place:
@itemize
@item
If it's a file which is thought of as being outside of Gnus (e.g., the
new @file{encrypt.el}), you should probably make the change in the Emacs
tree, and it will show up in the Gnus tree a few days later.
If you don't have Emacs CVS access (or it's inconvenient), you can
change such a file in the v5-10 branch, and it should propagate to Emacs
CVS -- however, it will get some extra scrutiny (by Miles) to see if the
changes are possibly controversial and need discussion on the mailing
list. Many changes are obvious bug-fixes however, so often there won't
be any problem.
@item
If it's to a Gnus file, and it's important enough that it should be part
of Emacs and the v5-10 branch, then you can make the change on the v5-10
branch, and it will go into Emacs CVS and the Gnus CVS trunk (a few days
later). The most prominent examples for such changes are bug-fixed
including improvements on the documentation.
If you know that there will be conflicts (perhaps because the affected
source code is different in v5-10 and the Gnus CVS trunk), then you can
install your change in both places, and when I try to sync them, there
will be a conflict -- however, since in most such cases there would be a
conflict @emph{anyway}, it's often easier for me to resolve it simply if
I see two @samp{identical} changes, and can just choose the proper one,
rather than having to actually fix the code.
@item
For general Gnus development changes, of course you just make the
change on the Gnus CVS trunk and it goes into Emacs a few years
later... :-)
@end itemize
Of course in any case, if you just can't wait for me to sync your
change, you can commit it in more than one place and probably there will
be no problem; usually the changes are textually identical anyway, so
can be easily resolved automatically (sometimes I notice silly things in
such multiple commits, like whitespace differences, and unify those ;-).
@c I do Emacs->Gnus less often (than Gnus->Emacs) because it tends to
@c require more manual work.
@c By default I sync about once a week. I also try to follow any Gnus
@c threads on the mailing lists and make sure any changes being discussed
@c are kept more up-to-date (so say 1-2 days delay for "topical" changes).
@c <buovfd71nkk.fsf@mctpc71.ucom.lsi.nec.co.jp>
@c BTW, just to add even more verbose explanation about the syncing thing:
@section Miscellanea
@heading @file{GNUS-NEWS}
Starting from No Gnus, the @file{GNUS-NEWS} is created from
@file{texi/gnus-news.texi}. Don't edit @file{GNUS-NEWS}. Edit
@file{texi/gnus-news.texi}, type @command{make GNUS-NEWS} in the
@file{texi} directory and commit @file{GNUS-NEWS} and
@file{texi/gnus-news.texi}.
@heading Conventions for version information in defcustoms
For new customizable variables introduced in Oort Gnus (including the
v5-10 branch) use @code{:version "22.1" ;; Oort Gnus} (including the
comment) or e.g. @code{:version "22.2" ;; Gnus 5.10.10} if the feature
was added for Emacs 22.2 and Gnus 5.10.10.
@c
If the variable is new in No Gnus use @code{:version "23.0" ;; No Gnus}.
The same applies for customizable variables when its default value was
changed.
@c Local Variables:
@c mode: texinfo
@c coding: iso-8859-1
@c End:
@ignore
arch-tag: ab15234c-2c8a-4cbd-8111-1811bcc6f931
@end ignore

24
doc/misc/gnus-faq.texi
View File

@ -1286,18 +1286,23 @@ How to enable automatic word-wrap when composing messages?
@subsubheading Answer
Say
Starting from No Gnus, automatic word-wrap is already enabled by
default, see the variable message-fill-column.
For other versions of Gnus, say
@example
(add-hook 'message-mode-hook
(lambda ()
(setq fill-column 72)
(turn-on-auto-fill)))
(unless (boundp 'message-fill-column)
(add-hook 'message-mode-hook
(lambda ()
(setq fill-column 72)
(turn-on-auto-fill))))
@end example
@noindent
in ~/.gnus.el. You can reformat a paragraph by hitting
@samp{M-q} (as usual)
in ~/.gnus.el.
You can reformat a paragraph by hitting @samp{M-q} (as usual).
@node [5.3]
@subsubheading Question 5.3
@ -1676,10 +1681,7 @@ you to use something like
yourUserName.userfqdn.provider.net, or you can use
somethingUnique.yourdomain.tld if you own the domain
yourdomain.tld, or you can register at a service which
gives private users a FQDN for free, e.g.
@uref{http://www.stura.tu-freiberg.de/~dlx/addfqdn.html}.
(Sorry but this website is in German, if you know of an
English one offering the same, drop me a note).
gives private users a FQDN for free.
Finally you can tell Gnus not to generate a Message-ID
for News at all (and letting the server do the job) by saying

121
doc/misc/gnus-news.el Normal file
View File

@ -0,0 +1,121 @@
;;; gnus-news.el --- a hack to create GNUS-NEWS from texinfo source
;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Reiner Steib <Reiner.Steib@gmx.de>
;; Keywords: tools
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(defvar gnus-news-header-disclaimer
"GNUS NEWS -- history of user-visible changes.
Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007 Free Software Foundation, Inc.
See the end of the file for license conditions.
Please send Gnus bug reports to bugs@gnus.org.
For older news, see Gnus info node \"New Features\".\n\n")
(defvar gnus-news-trailer
"
* For older news, see Gnus info node \"New Features\".
----------------------------------------------------------------------
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 3, 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., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.
\nLocal variables:\nmode: outline
paragraph-separate: \"[ ]*$\"\nend:\n")
(defvar gnus-news-makeinfo-command "makeinfo")
(defvar gnus-news-fill-column 80)
(defvar gnus-news-makeinfo-switches
(concat " --no-headers --paragraph-indent=0"
" --no-validate" ;; Allow unresolved references.
" --fill-column=" (number-to-string
(+ 3 ;; will strip leading spaces later
(or gnus-news-fill-column 80)))))
(defun batch-gnus-news ()
"Make GNUS-NEWS in batch mode."
(let (infile outfile)
(setq infile (car command-line-args-left)
command-line-args-left (cdr command-line-args-left)
outfile (car command-line-args-left)
command-line-args-left nil)
(if (and infile outfile)
(message "Creating `%s' from `%s'..." outfile infile)
(error "Not enough files given."))
(gnus-news-translate-file infile outfile)))
(defun gnus-news-translate-file (infile outfile)
"Translate INFILE (texinfo) to OUTFILE (GNUS-NEWS)."
(let* ((dir (concat (or (getenv "srcdir") ".") "/"))
(infile (concat dir infile))
(buffer (find-file-noselect (concat dir outfile))))
(with-temp-buffer
;; Could be done using `texinfmt' stuff as in `infohack.el'.
(insert
(shell-command-to-string
(concat gnus-news-makeinfo-command " "
gnus-news-makeinfo-switches " " infile)))
(goto-char (point-max))
(delete-char -1)
(goto-char (point-min))
(save-excursion
(while (re-search-forward "^ \\* " nil t)
(replace-match "\f\n* ")))
(save-excursion
(while (re-search-forward "^ \\* " nil t)
(replace-match "** ")))
(save-excursion
(while (re-search-forward "^ " nil t)
(replace-match "")))
;; Avoid `*' from @ref at beginning of line:
(save-excursion
(while (re-search-forward "^\\*Note" nil t)
(replace-match " \\&")))
(goto-char (point-min))
(insert gnus-news-header-disclaimer)
(goto-char (point-max))
(insert gnus-news-trailer)
(write-region (point-min) (point-max) outfile))))
;;; arch-tag: e23cdd27-eafd-4ba0-816f-98f5edb0dc29
;;; gnus-news.el ends here

264
doc/misc/gnus-news.texi Normal file
View File

@ -0,0 +1,264 @@
@c -*-texinfo-*-
@c Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
@c Permission is granted to anyone to make or distribute verbatim copies
@c of this document as received, in any medium, provided that the
@c copyright notice and this permission notice are preserved,
@c thus giving the recipient permission to redistribute in turn.
@c Permission is granted to distribute modified versions
@c of this document, or of portions of it,
@c under the above conditions, provided also that they
@c carry prominent notices stating who last changed them.
@c This file contains a list of news features Gnus. It is supposed to be
@c included in `gnus.texi'. `GNUS-NEWS' is automatically generated from
@c this file (see `gnus-news.el').
@itemize @bullet
@item Installation changes
@itemize @bullet
@item Upgrading from previous (stable) version if you have used No Gnus.
If you have tried No Gnus (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 the
@file{~/News/marks} directory (perhaps selectively), so that flags are
read from your @file{~/.newsrc.eld} instead of from the stale marks
file, where this release will store flags for nntp. See a later entry
for more information about nntp marks. Note that downgrading isn't
safe in general.
@item Lisp files are now installed in @file{.../site-lisp/gnus/} by default.
It defaulted to @file{.../site-lisp/} formerly. In addition to this,
the new installer issues a warning if other Gnus installations which
will shadow the latest one are detected. You can then remove those
shadows manually or remove them using @code{make
remove-installed-shadows}.
@end itemize
@item New packages and libraries within Gnus
@itemize @bullet
@item Gnus includes the Emacs Lisp @acronym{SASL} library.
This provides a clean @acronym{API} to @acronym{SASL} mechanisms from
within Emacs. The user visible aspects of this, compared to the earlier
situation, include support for @acronym{DIGEST}-@acronym{MD5} and
@acronym{NTLM}. @xref{Top, ,Emacs SASL, sasl, Emacs SASL}.
@item ManageSieve connections uses the @acronym{SASL} library by default.
The primary change this brings is support for @acronym{DIGEST-MD5} and
@acronym{NTLM}, when the server supports it.
@item Gnus includes a password cache mechanism in password.el.
It is enabled by default (see @code{password-cache}), with a short
timeout of 16 seconds (see @code{password-cache-expiry}). If
@acronym{PGG} is used as the @acronym{PGP} back end, the @acronym{PGP}
passphrase is managed by this mechanism. Passwords for ManageSieve
connections are managed by this mechanism, after querying the user
about whether to do so.
@end itemize
@item Changes in summary and article mode
@itemize @bullet
@item Gnus now supports sticky article buffers. Those are article buffers
that are not reused when you select another article. @xref{Sticky
Articles}.
@item International host names (@acronym{IDNA}) can now be decoded
inside article bodies using @kbd{W i}
(@code{gnus-summary-idna-message}). This requires that GNU Libidn
(@url{http://www.gnu.org/software/libidn/}) has been installed.
@c FIXME: Also mention @code{message-use-idna}?
@item The non-@acronym{ASCII} group names handling has been much
improved. The back ends that fully support non-@acronym{ASCII} group
names are now @code{nntp}, @code{nnml}, and @code{nnrss}. Also the
agent, the cache, and the marks features work with those back ends.
@xref{Non-ASCII Group Names}.
@item Gnus now displays @acronym{DNS} master files sent as text/dns
using dns-mode.
@item Gnus supports new limiting commands in the Summary buffer:
@kbd{/ r} (@code{gnus-summary-limit-to-replied}) and @kbd{/ R}
(@code{gnus-summary-limit-to-recipient}). @xref{Limiting}.
@item You can now fetch all ticked articles from the server using
@kbd{Y t} (@code{gnus-summary-insert-ticked-articles}). @xref{Summary
Generation Commands}.
@item Gnus supports a new sort command in the Summary buffer:
@kbd{C-c C-s C-t} (@code{gnus-summary-sort-by-recipient}). @xref{Summary
Sorting}.
@item @acronym{S/MIME} now features @acronym{LDAP} user certificate searches.
You need to configure the server in @code{smime-ldap-host-list}.
@item URLs inside Open@acronym{PGP} headers are retrieved and imported
to your PGP key ring when you click on them.
@item
Picons can be displayed right from the textual address, see
@code{gnus-picon-style}. @xref{Picons}.
@item @acronym{ANSI} @acronym{SGR} control sequences can be transformed
using @kbd{W A}.
@acronym{ANSI} sequences are used in some Chinese hierarchies for
highlighting articles (@code{gnus-article-treat-ansi-sequences}).
@item Gnus now MIME decodes articles even when they lack "MIME-Version" header.
This changes the default of @code{gnus-article-loose-mime}.
@item @code{gnus-decay-scores} can be a regexp matching score files.
For example, set it to @samp{\\.ADAPT\\'} and only adaptive score files
will be decayed. @xref{Score Decays}.
@item Strings prefixing to the @code{To} and @code{Newsgroup} headers in
summary lines when using @code{gnus-ignored-from-addresses} can be
customized with @code{gnus-summary-to-prefix} and
@code{gnus-summary-newsgroup-prefix}. @xref{To From Newsgroups}.
@item You can replace @acronym{MIME} parts with external bodies.
See @code{gnus-mime-replace-part} and @code{gnus-article-replace-part}.
@xref{MIME Commands}, @ref{Using MIME}.
@item
The option @code{mm-fill-flowed} can be used to disable treatment of
format=flowed messages. Also, flowed text is disabled when sending
inline @acronym{PGP} signed messages. @xref{Flowed text, ,Flowed text,
emacs-mime, The Emacs MIME Manual}. (New in Gnus 5.10.7)
@c This entry is also present in the node "Oort Gnus".
@end itemize
@item Changes in Message mode
@itemize @bullet
@item Gnus now supports the ``hashcash'' client puzzle anti-spam mechanism.
Use @code{(setq message-generate-hashcash t)} to enable.
@xref{Hashcash}.
@item You can now drag and drop attachments to the Message buffer.
See @code{mml-dnd-protocol-alist} and @code{mml-dnd-attach-options}.
@xref{MIME, ,MIME, message, Message Manual}.
@item The option @code{message-yank-empty-prefix} now controls how
empty lines are prefixed in cited text. @xref{Insertion Variables,
,Insertion Variables, message, Message Manual}.
@item Gnus uses narrowing to hide headers in Message buffers.
The @code{References} header is hidden by default. To make all
headers visible, use @code{(setq message-hidden-headers nil)}.
@xref{Message Headers, ,Message Headers, message, Message Manual}.
@item You can highlight different levels of citations like in the
article buffer. See @code{gnus-message-highlight-citation}.
@item @code{auto-fill-mode} is enabled by default in Message mode.
See @code{message-fill-column}. @xref{Various Message Variables, ,
Message Headers, message, Message Manual}.
@item You can now store signature files in a special directory
named @code{message-signature-directory}.
@item The option @code{message-citation-line-format} controls the format
of the "Whomever writes:" line. You need to set
@code{message-citation-line-function} to
@code{message-insert-formated-citation-line} as well.
@end itemize
@item Changes in back ends
@itemize @bullet
@item The nntp back end stores article marks in @file{~/News/marks}.
The directory can be changed using the (customizable) variable
@code{nntp-marks-directory}, and marks can be disabled using the
(back end) variable @code{nntp-marks-is-evil}. The advantage of this
is that you can copy @file{~/News/marks} (using rsync, scp or
whatever) to another Gnus installation, and it will realize what
articles you have read and marked. The data in @file{~/News/marks}
has priority over the same data in @file{~/.newsrc.eld}.
@item
You can import and export your @acronym{RSS} subscriptions from
@acronym{OPML} files. @xref{RSS}.
@item @acronym{IMAP} identity (@acronym{RFC} 2971) is supported.
By default, Gnus does not send any information about itself, but you can
customize it using the variable @code{nnimap-id}.
@item The @code{nnrss} back end now supports multilingual text.
Non-@acronym{ASCII} group names for the @code{nnrss} groups are also
supported. @xref{RSS}.
@item Retrieving mail with @acronym{POP3} is supported over @acronym{SSL}/@acronym{TLS} and with StartTLS.
@item The nnml back end allows other compression programs beside @file{gzip}
for compressed message files. @xref{Mail Spool}.
@item The nnml back end supports group compaction.
This feature, accessible via the functions
@code{gnus-group-compact-group} (@kbd{G z} in the group buffer) and
@code{gnus-server-compact-server} (@kbd{z} in the server buffer)
renumbers all articles in a group, starting from 1 and removing gaps.
As a consequence, you get a correct total article count (until
messages are deleted again).
@end itemize
@item Appearance
@c Maybe it's not worth to separate this from "Miscellaneous"?
@itemize @bullet
@item The tool bar has been updated to use GNOME icons.
You can also customize the tool bar. There's no documentation in the
manual yet, but @kbd{M-x customize-apropos RET -tool-bar$} should get
you started. (Only for Emacs, not in XEmacs.)
@c FIXME: Document this in the manual
@item The tool bar icons are now (de)activated correctly
in the group buffer, see the variable @code{gnus-group-update-tool-bar}.
Its default value depends on your Emacs version.
@c FIXME: Document this in the manual
@item You can change the location of XEmacs' toolbars in Gnus buffers.
See @code{gnus-use-toolbar} and @code{message-use-toolbar}.
@end itemize
@item Miscellaneous changes
@itemize @bullet
@item Having edited the select-method for the foreign server in the
server buffer is immediately reflected to the subscription of the groups
which use the server in question. For instance, if you change
@code{nntp-via-address} into @samp{bar.example.com} from
@samp{foo.example.com}, Gnus will connect to the news host by way of the
intermediate host @samp{bar.example.com} from next time.
@item The @file{all.SCORE} file can be edited from the group buffer
using @kbd{W e}.
@end itemize
@end itemize
@c gnus-news.texi ends here.
@ignore
arch-tag: 872c7569-4340-4d73-9d1d-7826d9f94a51
@end ignore

1511
doc/misc/gnus.texi
View File

File diff suppressed because it is too large Load Diff

112
doc/misc/message.texi
View File

@ -71,14 +71,14 @@ Message mode buffers.
@c Adjust ../Makefile.in if you change the following lines:
Message is distributed with Gnus. The Gnus distribution
@c
corresponding to this manual is Gnus v5.11.
corresponding to this manual is No Gnus v0.7.
@node Interface
@chapter Interface
When a program (or a person) wants to respond to a message -- reply,
follow up, forward, cancel -- the program (or person) should just put
When a program (or a person) wants to respond to a message---reply,
follow up, forward, cancel---the program (or person) should just put
point in the buffer where the message is and call the required command.
@code{Message} will then pop up a new @code{message} mode buffer with
appropriate headers filled out, and the user can edit the message before
@ -179,7 +179,8 @@ but you can change the behavior to suit your needs by fiddling with the
@vindex message-dont-reply-to-names
Addresses that match the @code{message-dont-reply-to-names} regular
expression will be removed from the @code{Cc} header.
expression (or list of regular expressions) will be removed from the
@code{Cc} header. A value of @code{nil} means exclude your name only.
@vindex message-wide-reply-confirm-recipients
If @code{message-wide-reply-confirm-recipients} is non-@code{nil} you
@ -257,7 +258,7 @@ removed before popping up the new message buffer. The default is@*
^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|@*
Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|@*
^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|@*
^X-Payment:}.
^X-Payment:\\|^Approved:}.
@ -797,14 +798,18 @@ Insert the message headers (@code{message-insert-headers}).
@item C-c M-m
@kindex C-c M-m
@findex message-mark-inserted-region
Mark some region in the current article with enclosing tags.
See @code{message-mark-insert-begin} and @code{message-mark-insert-end}.
Mark some region in the current article with enclosing tags. See
@code{message-mark-insert-begin} and @code{message-mark-insert-end}.
When called with a prefix argument, use slrn style verbatim marks
(@samp{#v+} and @samp{#v-}).
@item C-c M-f
@kindex C-c M-f
@findex message-mark-insert-file
Insert a file in the current article with enclosing tags.
See @code{message-mark-insert-begin} and @code{message-mark-insert-end}.
When called with a prefix argument, use slrn style verbatim marks
(@samp{#v+} and @samp{#v-}).
@end table
@ -1159,6 +1164,11 @@ The text is killed and replaced with the contents of the variable
@code{message-elide-ellipsis}. The default value is to use an ellipsis
(@samp{[...]}).
@item C-c M-k
@kindex C-c M-k
@findex message-kill-address
Kill the address under point.
@item C-c C-z
@kindex C-c C-z
@findex message-kill-to-signature
@ -1244,11 +1254,13 @@ Kill the message buffer and exit (@code{message-kill-buffer}).
@section Mail Aliases
@cindex mail aliases
@cindex aliases
@cindex completion
@cindex ecomplete
@vindex message-mail-alias-type
The @code{message-mail-alias-type} variable controls what type of mail
alias expansion to use. Currently only one form is supported---Message
uses @code{mailabbrev} to handle mail aliases. If this variable is
alias expansion to use. Currently two forms are supported:
@code{mailabbrev} and @code{ecomplete}. If this variable is
@code{nil}, no mail alias expansion will be performed.
@code{mailabbrev} works by parsing the @file{/etc/mailrc} and
@ -1266,6 +1278,14 @@ on) headers and press @kbd{SPC} to expand the alias.
No expansion will be performed upon sending of the message---all
expansions have to be done explicitly.
If you're using @code{ecomplete}, all addresses from @code{To} and
@code{Cc} headers will automatically be put into the
@file{~/.ecompleterc} file. When you enter text in the @code{To} and
@code{Cc} headers, @code{ecomplete} will check out the values stored
there and ``electrically'' say what completions are possible. To
choose one of these completions, use the @kbd{M-n} command to move
down to the list. Use @kbd{M-n} and @kbd{M-p} to move down and up the
list, and @kbd{RET} to choose a completion.
@node Spelling
@section Spelling
@ -1334,7 +1354,7 @@ installed.
@section Message Headers
Message is quite aggressive on the message generation front. It has to
be -- it's a combined news and mail agent. To be able to send combined
be---it's a combined news and mail agent. To be able to send combined
messages, it has to generate all headers itself (instead of letting the
mail/news system do it) to ensure that mail and news copies of messages
look sufficiently similar.
@ -1373,7 +1393,7 @@ values:
@table @code
@item nil
Just the address -- @samp{king@@grassland.com}.
Just the address---@samp{king@@grassland.com}.
@item parens
@samp{king@@grassland.com (Elvis Parsley)}.
@ -1494,6 +1514,9 @@ hidden when composing a message.
'(not "From" "Subject" "To" "Cc" "Newsgroups"))
@end lisp
Headers are hidden using narrowing, you can use @kbd{M-x widen} to
expose them in the buffer.
@item message-header-synonyms
@vindex message-header-synonyms
A list of lists of header synonyms. E.g., if this list contains a
@ -1525,6 +1548,13 @@ Regexp of headers to be removed before mailing. The default is@*
This string is inserted at the end of the headers in all message
buffers that are initialized as mail.
@item message-generate-hashcash
@vindex message-generate-hashcash
Variable that indicates whether @samp{X-Hashcash} headers
should be computed for the message. @xref{Hashcash, ,Hashcash,gnus,
The Gnus Manual}. If @code{opportunistic}, only generate the headers
when it doesn't lead to the user having to wait.
@end table
@ -1541,10 +1571,10 @@ buffers that are initialized as mail.
@findex smtpmail-send-it
@findex feedmail-send-it
Function used to send the current buffer as mail. The default is
@code{message-send-mail-with-sendmail}. Other valid values include
@code{message-send-mail-with-sendmail}, or @code{smtpmail-send-it}
according to the system. Other valid values include
@code{message-send-mail-with-mh}, @code{message-send-mail-with-qmail},
@code{message-smtpmail-send-it}, @code{smtpmail-send-it} and
@code{feedmail-send-it}.
@code{message-smtpmail-send-it} and @code{feedmail-send-it}.
@item message-mh-deletable-headers
@vindex message-mh-deletable-headers
@ -1859,6 +1889,9 @@ that look like:
Hallvard B Furuseth <h.b.furuseth@@usit.uio.no> writes:
@end example
@c FIXME: Add `message-insert-formated-citation-line' and
@c `message-citation-line-format'
Point will be at the beginning of the body of the message when this
function is called.
@ -1873,21 +1906,29 @@ Article Highlighting, gnus, The Gnus Manual}, for details.
@cindex yanking
@cindex quoting
When you are replying to or following up an article, you normally want
to quote the person you are answering. Inserting quoted text is done
by @dfn{yanking}, and each line you yank will have
@code{message-yank-prefix} prepended to it (except for quoted and
empty lines which uses @code{message-yank-cited-prefix}). The default
is @samp{> }.
to quote the person you are answering. Inserting quoted text is done by
@dfn{yanking}, and each line you yank will have
@code{message-yank-prefix} prepended to it (except for quoted lines
which use @code{message-yank-cited-prefix} and empty lines which use
@code{message-yank-empty-prefix}). The default is @samp{> }.
@item message-yank-cited-prefix
@vindex message-yank-cited-prefix
@cindex yanking
@cindex cited
@cindex quoting
When yanking text from an article which contains no text or already
cited text, each line will be prefixed with the contents of this
variable. The default is @samp{>}. See also
@code{message-yank-prefix}.
When yanking text from an article which contains already cited text,
each line will be prefixed with the contents of this variable. The
default is @samp{>}. See also @code{message-yank-prefix}.
@item message-yank-empty-prefix
@vindex message-yank-empty-prefix
@cindex yanking
@cindex quoting
When yanking text from an article, each empty line will be prefixed with
the contents of this variable. The default is @samp{>}. You can set
this variable to an empty string to split the cited text into paragraphs
automatically. See also @code{message-yank-prefix}.
@item message-indentation-spaces
@vindex message-indentation-spaces
@ -1932,8 +1973,18 @@ If this variable is @code{nil}, no signature will be inserted at all.
@item message-signature-file
@vindex message-signature-file
File containing the signature to be inserted at the end of the buffer.
If a path is specified, the value of
@code{message-signature-directory} is ignored, even if set.
The default is @file{~/.signature}.
@item message-signature-directory
@vindex message-signature-directory
Name of directory containing signature files. Comes in handy if you
have many such files, handled via Gnus posting styles for instance.
If @code{nil} (the default), @code{message-signature-file} is expected
to specify the directory if needed.
@item message-signature-insert-empty-line
@vindex message-signature-insert-empty-line
If @code{t} (the default value) an empty line is inserted before the
@ -1968,6 +2019,13 @@ Emacsen.) @xref{Charset Translation, , Charset Translation, emacs-mime,
Emacs MIME Manual}, for details on the @sc{mule}-to-@acronym{MIME}
translation process.
@item message-fill-column
@vindex message-fill-column
@cindex auto-fill
Local value for the column beyond which automatic line-wrapping should
happen for message buffers. If non-nil (the default), also turn on
auto-fill in message buffers.
@item message-signature-separator
@vindex message-signature-separator
Regexp matching the signature separator. It is @samp{^-- *$} by
@ -2057,6 +2115,12 @@ Hook run when canceling news articles.
@vindex message-mode-syntax-table
Syntax table used in message mode buffers.
@item message-cite-articles-with-x-no-archive
@vindex message-cite-articles-with-x-no-archive
If non-@code{nil}, don't strip quoted text from articles that have
@samp{X-No-Archive} set. Even if this variable isn't set, you can
undo the stripping by hitting the @code{undo} keystroke.
@item message-strip-special-text-properties
@vindex message-strip-special-text-properties
Emacs has a number of special text properties which can break message
@ -2089,7 +2153,7 @@ the buffer where the message is.
@item function
A function to be called if @var{predicate} returns non-@code{nil}.
@var{function} is called with one parameter -- the prefix.
@var{function} is called with one parameter---the prefix.
@end table
The default is:

14
doc/misc/pgg.texi
View File

@ -345,11 +345,11 @@ singleton object wrapped with the luna object system.
Since PGG was designed for accessing and developing PGP functionality,
the architecture had to be designed not just for interoperability but
also for extensiblity. In this chapter we explore the architecture
while finding out how to write the PGG backend.
while finding out how to write the PGG back end.
@menu
* Initializing::
* Backend methods::
* Back end methods::
* Getting output::
@end menu
@ -373,12 +373,12 @@ variable @code{pgg-scheme-gpg-instance} and will be reused from now on.
@end lisp
The name of the function must follow the
regulation---@code{pgg-make-scheme-} follows the backend name.
regulation---@code{pgg-make-scheme-} follows the back end name.
@node Backend methods
@section Backend methods
@node Back end methods
@section Back end methods
In each backend, these methods must be present. The output of these
In each back end, these methods must be present. The output of these
methods is stored in special buffers (@ref{Getting output}), so that
these methods must tell the status of the execution.
@ -435,7 +435,7 @@ On success, it returns @code{t}, otherwise @code{nil}.
@node Getting output
@section Getting output
The output of the backend methods (@ref{Backend methods}) is stored in
The output of the back end methods (@ref{Back end methods}) is stored in
special buffers, so that these methods must tell the status of the
execution.

270
doc/misc/sasl.texi Normal file
View File

@ -0,0 +1,270 @@
\input texinfo @c -*-texinfo-*-
@setfilename sasl.info
@set VERSION 0.2
@dircategory Emacs
@direntry
* SASL: (sasl). The Emacs SASL library.
@end direntry
@settitle Emacs SASL Library @value{VERSION}
@ifinfo
This file describes the Emacs SASL library.
Copyright @copyright{} 2004, 2005, 2006 Free Software Foundation, Inc.
Copyright @copyright{} 2000 Daiki Ueno.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.2 or
any later version published by the Free Software Foundation; with no
Invariant Sections, with no Front-Cover Texts, and with no Back-Cover
Texts. A copy of the license is included in the section entitled "GNU
Free Documentation License".
@end ifinfo
@tex
@titlepage
@title Emacs SASL Library
@author by Daiki Ueno
@page
@vskip 0pt plus 1filll
Copyright @copyright{} 2000 Daiki Ueno.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.2 or
any later version published by the Free Software Foundation; with no
Invariant Sections, with no Front-Cover Texts, and with no Back-Cover
Texts. A copy of the license is included in the section entitled "GNU
Free Documentation License".
@end titlepage
@page
@end tex
@node Top
@top Emacs SASL
This manual describes the Emacs SASL library.
A common interface to share several authentication mechanisms between
applications using different protocols.
@menu
* Overview:: What Emacs SASL library is.
* How to use:: Adding authentication support to your applications.
* Data types::
* Back end drivers:: Writing your own drivers.
* Index::
* Function Index::
* Variable Index::
@end menu
@node Overview
@chapter Overview
@sc{sasl} is short for @dfn{Simple Authentication and Security Layer}.
This standard is documented in RFC2222. It provides a simple method for
adding authentication support to various application protocols.
The toplevel interface of this library is inspired by Java @sc{sasl}
Application Program Interface. It defines an abstraction over a series
of authentication mechanism drivers (@ref{Back end drivers}).
Back end drivers are designed to be close as possible to the
authentication mechanism. You can access the additional configuration
information anywhere from the implementation.
@node How to use
@chapter How to use
(Not yet written).
To use Emacs SASL library, please evaluate following expression at the
beginning of your application program.
@lisp
(require 'sasl)
@end lisp
If you want to check existence of sasl.el at runtime, instead you
can list autoload settings for functions you want.
@node Data types
@chapter Data types
There are three data types to be used for carrying a negotiated
security layer---a mechanism, a client parameter and an authentication
step.
@menu
* Mechanisms::
* Clients::
* Steps::
@end menu
@node Mechanisms
@section Mechanisms
A mechanism (@code{sasl-mechanism} object) is a schema of the @sc{sasl}
authentication mechanism driver.
@defvar sasl-mechanisms
A list of mechanism names.
@end defvar
@defun sasl-find-mechanism mechanisms
Retrieve an apropriate mechanism.
This function compares @var{mechanisms} and @code{sasl-mechanisms} then
returns apropriate @code{sasl-mechanism} object.
@example
(let ((sasl-mechanisms '("CRAM-MD5" "DIGEST-MD5")))
(setq mechanism (sasl-find-mechanism server-supported-mechanisms)))
@end example
@end defun
@defun sasl-mechanism-name mechanism
Return name of mechanism, a string.
@end defun
If you want to write an authentication mechanism driver (@ref{Back end
drivers}), use @code{sasl-make-mechanism} and modify
@code{sasl-mechanisms} and @code{sasl-mechanism-alist} correctly.
@defun sasl-make-mechanism name steps
Allocate a @code{sasl-mechanism} object.
This function takes two parameters---name of the mechanism, and a list
of authentication functions.
@example
(defconst sasl-anonymous-steps
'(identity ;no initial response
sasl-anonymous-response))
(put 'sasl-anonymous 'sasl-mechanism
(sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps))
@end example
@end defun
@node Clients
@section Clients
A client (@code{sasl-client} object) initialized with four
parameters---a mechanism, a user name, name of the service and name of
the server.
@defun sasl-make-client mechanism name service server
Prepare a @code{sasl-client} object.
@end defun
@defun sasl-client-mechanism client
Return the mechanism (@code{sasl-mechanism} object) of client.
@end defun
@defun sasl-client-name client
Return the authorization name of client, a string.
@end defun
@defun sasl-client-service client
Return the service name of client, a string.
@end defun
@defun sasl-client-server client
Return the server name of client, a string.
@end defun
If you want to specify additional configuration properties, please use
@code{sasl-client-set-property}.
@defun sasl-client-set-property client property value
Add the given property/value to client.
@end defun
@defun sasl-client-property client property
Return the value of the property of client.
@end defun
@defun sasl-client-set-properties client plist
Destructively set the properties of client.
The second argument is the new property list.
@end defun
@defun sasl-client-properties client
Return the whole property list of client configuration.
@end defun
@node Steps
@section Steps
A step (@code{sasl-step} object) is an abstraction of authentication
``step'' which holds the response value and the next entry point for the
authentication process (the latter is not accessible).
@defun sasl-step-data step
Return the data which @var{step} holds, a string.
@end defun
@defun sasl-step-set-data step data
Store @var{data} string to @var{step}.
@end defun
To get the initial response, you should call the function
@code{sasl-next-step} with the second argument @code{nil}.
@example
(setq name (sasl-mechanism-name mechanism))
@end example
At this point we could send the command which starts a SASL
authentication protocol exchange. For example,
@example
(process-send-string
process
(if (sasl-step-data step) ;initial response
(format "AUTH %s %s\r\n" name (base64-encode-string (sasl-step-data step) t))
(format "AUTH %s\r\n" name)))
@end example
To go on with the authentication process, all you have to do is call
@code{sasl-next-step} consecutively.
@defun sasl-next-step client step
Perform the authentication step.
At the first time @var{step} should be set to @code{nil}.
@end defun
@node Back end drivers
@chapter Back end drivers
(Not yet written).
@node Index
@chapter Index
@printindex cp
@node Function Index
@chapter Function Index
@printindex fn
@node Variable Index
@chapter Variable Index
@printindex vr
@summarycontents
@contents
@bye
@c End:
@ignore
arch-tag: dc9650be-a953-40bf-bc55-24fe5f19d875
@end ignore

6
doc/misc/sieve.texi
View File

@ -236,9 +236,9 @@ if address "sender" "owner-w3-beta@@xemacs.org" @{
@}
@end example
A few mailing lists do not use the @samp{Sender:} header, but does
contain some unique identifier in some other header. The following is
not a complete script, it assumes that @code{fileinto} has already been
A few mailing lists do not use the @samp{Sender:} header, but has a
unique identifier in some other header. The following is not a
complete script, it assumes that @code{fileinto} has already been
required.
@example

569
etc/GNUS-NEWS
View File

@ -10,15 +10,16 @@ For older news, see Gnus info node "New Features".
* Installation changes
** Upgrading from previous (stable) version if you have used Oort.
** Upgrading from previous (stable) version if you have used No Gnus.
If you have tried Oort (the unstable Gnus branch leading to this
If you have tried No Gnus (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 save in general.
this version. In particular, you will probably want to remove the
`~/News/marks' directory (perhaps selectively), so that flags are read
from your `~/.newsrc.eld' instead of from the stale marks file, where
this release will store flags for nntp. See a later entry for more
information about nntp marks. Note that downgrading isn't safe in
general.
** Lisp files are now installed in `.../site-lisp/gnus/' by default. It
defaulted to `.../site-lisp/' formerly. In addition to this, the new
@ -26,493 +27,191 @@ installer issues a warning if other Gnus installations which will shadow
the latest one are detected. You can then remove those shadows manually
or remove them using `make remove-installed-shadows'.
** 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, if 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' and `xemacs.mak' superfluous, so
they have been removed.
** `~/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.
** `(require 'gnus-load)'
If you use a stand-alone Gnus distribution, you'd better add `(require
'gnus-load)' into 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.
* New packages and libraries within Gnus
** The revised Gnus FAQ is included in the manual, *Note Frequently Asked
Questions::.
** Gnus includes the Emacs Lisp SASL library.
** TLS wrapper shipped with Gnus
This provides a clean API to SASL mechanisms from within Emacs. The
user visible aspects of this, compared to the earlier situation, include
support for DIGEST-MD5 and NTLM. *Note Emacs SASL: (sasl)Top.
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.
** ManageSieve connections uses the SASL library by default.
** Improved anti-spam features.
The primary change this brings is support for DIGEST-MD5 and NTLM, when
the server supports it.
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. *Note Thwarting Email Spam::.
** 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. *Note Sieve Commands::, and the new Sieve manual *Note Top:
(sieve)Top.
* Changes in group mode
** `gnus-group-read-ephemeral-group' can be called interactively, using `G
M'.
** Retrieval of charters and control messages
There are new commands for fetching newsgroup charters (`H c') and
control messages (`H C').
** 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 `~/.gnus.el' 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"))))
** 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
`nnimap-fixup-unread-after-getting-new-news' again. If you were happy
with the estimate and want to save some (minimal) time when getting new
mail, remove the function.
** 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.
** `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 includes a password cache mechanism in password.el.
It is enabled by default (see `password-cache'), with a short timeout of
16 seconds (see `password-cache-expiry'). If PGG is used as the PGP
back end, the PGP passphrase is managed by this mechanism. Passwords
for ManageSieve connections are managed by this mechanism, after
querying the user about whether to do so.
* Changes in summary and article mode
** `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 now supports sticky article buffers. Those are article buffers
that are not reused when you select another article. *Note Sticky
Articles::.
** In draft groups, `e' is now bound to `gnus-draft-edit-message'. Use `B
w' for `gnus-summary-edit-article' instead.
** International host names (IDNA) can now be decoded inside article bodies
using `W i' (`gnus-summary-idna-message'). This requires that GNU Libidn
(`http://www.gnu.org/software/libidn/') has been installed.
** Article Buttons
** The non-ASCII group names handling has been much improved. The back
ends that fully support non-ASCII group names are now `nntp', `nnml',
and `nnrss'. Also the agent, the cache, and the marks features work
with those back ends. *Note Non-ASCII Group Names::.
More buttons for URLs, mail addresses, Message-IDs, Info links, man
pages and Emacs or Gnus related references. *Note Article Buttons::.
The variables `gnus-button-*-level' can be used to control the
appearance of all article buttons. *Note Article Button Levels::.
** Gnus now displays DNS master files sent as text/dns using dns-mode.
** Single-part yenc encoded attachments can be decoded.
** Gnus supports new limiting commands in the Summary buffer: `/ r'
(`gnus-summary-limit-to-replied') and `/ R'
(`gnus-summary-limit-to-recipient'). *Note Limiting::.
** Picons
** You can now fetch all ticked articles from the server using `Y t'
(`gnus-summary-insert-ticked-articles'). *Note Summary Generation
Commands::.
The picons code has been reimplemented to work in GNU Emacs--some of the
previous options have been removed or renamed.
** Gnus supports a new sort command in the Summary buffer: `C-c C-s C-t'
(`gnus-summary-sort-by-recipient'). *Note Summary Sorting::.
Picons are small "personal icons" representing users, domain and
newsgroups, which can be displayed in the Article buffer. *Note
Picons::.
** S/MIME now features LDAP user certificate searches. You need to
configure the server in `smime-ldap-host-list'.
** If the new option `gnus-treat-body-boundary' is non-`nil', a boundary
line is drawn at the end of the headers.
** URLs inside OpenPGP headers are retrieved and imported to your PGP key
ring when you click on them.
** Signed article headers (X-PGP-Sig) can be verified with `W p'.
** Picons can be displayed right from the textual address, see
`gnus-picon-style'. *Note Picons::.
** The Summary Buffer uses an arrow in the fringe to indicate the current
article. Use `(setq gnus-summary-display-arrow nil)' to disable it.
** ANSI SGR control sequences can be transformed using `W A'.
** Warn about email replies to news
ANSI sequences are used in some Chinese hierarchies for highlighting
articles (`gnus-article-treat-ansi-sequences').
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.
** Gnus now MIME decodes articles even when they lack "MIME-Version" header.
This changes the default of `gnus-article-loose-mime'.
** If the new option `gnus-summary-display-while-building' is non-`nil',
the summary buffer is shown and updated as it's being built.
** `gnus-decay-scores' can be a regexp matching score files. For example,
set it to `\\.ADAPT\\'' and only adaptive score files will be decayed.
*Note Score Decays::.
** The new `recent' mark `.' indicates newly arrived messages (as opposed
to old but unread messages).
** Strings prefixing to the `To' and `Newsgroup' headers in summary lines
when using `gnus-ignored-from-addresses' can be customized with
`gnus-summary-to-prefix' and `gnus-summary-newsgroup-prefix'. *Note To
From Newsgroups::.
** Gnus supports RFC 2369 mailing list headers, and adds a number of
related commands in mailing list groups. *Note Mailing List::.
** You can replace MIME parts with external bodies. See
`gnus-mime-replace-part' and `gnus-article-replace-part'. *Note MIME
Commands::, *note Using MIME::.
** The Date header can be displayed in a format that can be read aloud in
English. *Note Article Date::.
** diffs are automatically highlighted in groups matching
`mm-uu-diff-groups-regexp'
** 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.
The new command `W Y f' (`gnus-article-outlook-deuglify-article') allows
deuglifying broken Outlook (Express) articles.
** `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.
** Smileys (`:-)', `;-)' etc) are now displayed graphically in Emacs too.
Put `(setq gnus-treat-display-smileys nil)' in `~/.gnus.el' to disable
it.
** Face headers handling. *Note Face::.
** 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'.
** `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.
** Deleting of attachments.
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 is determined from the `current-language-environment'
variable, instead of `iso-8859-1'. Also the `.*' item in
`gnus-group-charset-alist' is removed.
** 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.
** 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.
** Gnus inlines external parts (message/external).
** The option `mm-fill-flowed' can be used to disable treatment of
format=flowed messages. Also, flowed text is disabled when sending
inline PGP signed messages. *Note Flowed text: (emacs-mime)Flowed text.
(New in Gnus 5.10.7)
* Changes in Message mode and related Gnus features
* Changes in Message mode
** 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. *Note Delayed Articles::.
** If the new option `nnml-use-compressed-files' is non-`nil', the nnml
back end allows compressed message files.
** The new option `gnus-gcc-mark-as-read' automatically marks Gcc articles
as read.
** Externalizing of attachments
If `gnus-gcc-externalize-attachments' or
`message-fcc-externalize-attachments' is non-`nil', attach local files
as external parts.
** The envelope sender address can be customized when using Sendmail.
*Note Mail Variables: (message)Mail Variables.
** Gnus no longer generate the Sender: header automatically.
Earlier it was generated when 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-From headers are no longer generated when you
start composing messages and `message-generate-headers-first' is `nil'.
** Easy inclusion of X-Faces headers. *Note X-Face::.
** 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.
** `message-insinuate-rmail'
Adding `(message-insinuate-rmail)' and `(setq mail-user-agent
'gnus-user-agent)' in `.emacs' 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 [(tab)]
'bbdb-complete-name)
** `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 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.
** The option `mm-fill-flowed' can be used to disable treatment of
"format=flowed" messages. Also, flowed text is disabled when sending
inline PGP signed messages. (New in Gnus 5.10.7)
** Gnus supports the generation of RFC 2298 Disposition Notification
requests.
This is invoked with the `C-c M-n' key binding from message mode.
** 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 an article or not (for canceling and
superseding). Gnus generates a random password string the first time
you post a message, and saves it in your `~/.emacs' 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
behavior can be changed by customizing `message-insert-canlock'.
** 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'.
** 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 the symbol `best'.
The behavior for the `best' value is to show MML (i.e., convert to MIME)
when appropriate. MML will not be used when forwarding signed or
encrypted messages, as the conversion invalidate the digital signature.
** If `auto-compression-mode' is enabled, attachments are automatically
decompressed when activated.
** 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.
** Gnus now supports the "hashcash" client puzzle anti-spam mechanism. Use
`(setq message-generate-hashcash t)' to enable. *Note Hashcash::.
** You can now drag and drop attachments to the Message buffer. See
`mml-dnd-protocol-alist' and `mml-dnd-attach-options'. *Note MIME:
(message)MIME.
** The option `message-yank-empty-prefix' now controls how empty lines are
prefixed in cited text. *Note Insertion Variables: (message)Insertion
Variables.
** Gnus uses narrowing to hide headers in Message buffers. The
`References' header is hidden by default. To make all headers visible,
use `(setq message-hidden-headers nil)'. *Note Message Headers:
(message)Message Headers.
** You can highlight different levels of citations like in the article
buffer. See `gnus-message-highlight-citation'.
** `auto-fill-mode' is enabled by default in Message mode. See
`message-fill-column'. *Note Message Headers: (message)Various Message
Variables.
** You can now store signature files in a special directory named
`message-signature-directory'.
** The option `message-citation-line-format' controls the format of the
"Whomever writes:" line. You need to set
`message-citation-line-function' to
`message-insert-formated-citation-line' as well.
* Changes in back ends
** Gnus can display RSS newsfeeds as a newsgroup. *Note RSS::.
** The nntp back end stores article marks in `~/News/marks'.
** The nndoc back end now supports mailman digests and exim bounces.
The directory can be changed using the (customizable) variable
`nntp-marks-directory', and marks can be disabled using the (back end)
variable `nntp-marks-is-evil'. The advantage of this is that you can
copy `~/News/marks' (using rsync, scp or whatever) to another Gnus
installation, and it will realize what articles you have read and
marked. The data in `~/News/marks' has priority over the same data in
`~/.newsrc.eld'.
** Gnus supports Maildir groups.
** You can import and export your RSS subscriptions from OPML files. *Note
RSS::.
Gnus includes a new back end `nnmaildir.el'. *Note Maildir::.
** IMAP identity (RFC 2971) is supported.
** The nnml and nnfolder back ends store marks for each groups.
By default, Gnus does not send any information about itself, but you can
customize it using the variable `nnimap-id'.
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 `nnrss' back end now supports multilingual text. Non-ASCII group
names for the `nnrss' groups are also supported. *Note RSS::.
** Retrieving mail with POP3 is supported over SSL/TLS and with StartTLS.
** The nnml back end allows other compression programs beside `gzip' for
compressed message files. *Note Mail Spool::.
** The nnml back end supports group compaction.
This feature, accessible via the functions `gnus-group-compact-group'
(`G z' in the group buffer) and `gnus-server-compact-server' (`z' in the
server buffer) renumbers all articles in a group, starting from 1 and
removing gaps. As a consequence, you get a correct total article count
(until messages are deleted again).
* Appearance
** 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 (*note Security: (message)Security.).
** The tool bars have been updated to use GNOME icons in Group, Summary and
Message mode. You can also customize the tool bars. This is a new
feature in Gnus 5.10.9. (Only for Emacs, not in XEmacs.)
** The tool bar has been updated to use GNOME icons. You can also
customize the tool bar. There's no documentation in the manual yet, but
`M-x customize-apropos RET -tool-bar$' should get you started. (Only
for Emacs, not in XEmacs.)
** The tool bar icons are now (de)activated correctly in the group buffer,
see the variable `gnus-group-update-tool-bar'. Its default value
depends on your Emacs version. This is a new feature in Gnus 5.10.9.
depends on your Emacs version.
** You can change the location of XEmacs' toolbars in Gnus buffers. See
`gnus-use-toolbar' and `message-use-toolbar'.
* Miscellaneous changes
** `gnus-agent'
** Having edited the select-method for the foreign server in the server
buffer is immediately reflected to the subscription of the groups which
use the server in question. For instance, if you change
`nntp-via-address' into `bar.example.com' from `foo.example.com', Gnus
will connect to the news host by way of the intermediate host
`bar.example.com' from next time.
The Gnus Agent has seen a major updated and 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 back ends 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 behavior of having the Agent disabled
with `(setq gnus-agent nil)'. Note that putting `(gnus-agentize)' in
`~/.gnus.el' is not needed any more.
** 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. `(setq gnus-agent-cache
nil)' reverts to the old behavior.
** Dired integration
`gnus-dired-minor-mode' (see *Note Other modes::) installs key bindings
in dired buffers to send a file as an attachment, open a file using the
appropriate mailcap entry, and print a file using the mailcap entry.
** The format spec `%C' for positioning point has changed to `%*'.
** `gnus-slave-unplugged'
A new command which starts Gnus offline in slave mode.
** The `all.SCORE' file can be edited from the group buffer using `W e'.

51
etc/gnus/gnus-setup.ast Normal file
View File

@ -0,0 +1,51 @@
@title Configuring Gnus for the first time
@node What do you want to do with Gnus?
@variable outbound (:radio ((item :tag "Send mail via sendmail" "sendmail") (item :tag "Send mail via SMTP" "smtp"))) "sendmail"
@variable backends (:set ((item :tag "Read news via NNTP" "nntp") (item :tag "Read mail, store it locally" "nnml") (item :tag "Read mail and store it on an IMAP server" "nnimap"))) (list "nnml")
@result primary-mail-selections (list backends outbound)
@text
Welcome to Gnus. You need to tell us what you want to do with Gnus
before we go on to specific configurations.
Choose the tasks you want to set up:
@variable{backends}
Choose the method Gnus will use to send mail:
@variable{outbound}
@end text
@next (member "nnml" backends) "Setting up local mail storage (nnml)"
@next (member "nntp" backends) "Setting up a NNTP server"
@node Setting up local mail storage (nnml)
@variable mechanism (:radio ((item :tag "Get mail from your Unix mbox" "mbox") (item :tag "Use POP3 to retrieve mail" "pop3"))) "mbox"
@result nnml-mechanism (list mechanism)
@text
You are setting up local mail storage, using the nnml backend in Gnus terms.
Your mail can be downloaded into Gnus in several ways, choose one:
@variable{mechanism}
@end text
@node Setting up a NNTP server
@text
TODO: this will be a real link.
Run M-x assistant and use the news-server.ast file as input.
@end text
@c Local variables:
@c mode: texinfo
@c End:
@ignore
arch-tag: 6b7b200b-9169-4b44-8b32-b73773fa71af
@end ignore

64
etc/gnus/news-server.ast Normal file
View File

@ -0,0 +1,64 @@
@title Configuring Gnus for reading news
@node Setting up the news server name and port number
@variable server :string (gnus-getenv-nntpserver)
@variable port :number 119
@validate (assistant-validate-connect-to-server server port)
@result gnus-select-method (list 'nntp server (list 'nntp-server port))
@text
Usenet news is usually read from your Internet service prodider's news
server. If you don't know the name of this server, contact your ISP.
As a guess, the name of the server might be news.yourisp.com.
Server name: @variable{server}
Port number: @variable{port}
@end text
@next t "User name and password"
@node User name and password
@type interstitial
@next
(if (assistant-password-required-p)
"Enter user name and password"
"Want user name and password?")
@end next
@node Want user name and password?
@variable passwordp (:radio ((item "Yes") (item "No"))) "No"
@text
Some news servers require that you enter a user name and a password.
It doesn't look like your news server is one of them.
Do you want to enter user name and password anyway?
@variable{passwordp}
@end text
@next (equal passwordp "No") finish
@next (not (equal passwordp "No")) "Enter user name and password"
@node Enter user name and password
@variable user-name :string (user-login-name)
@variable password :password (or (assistant-authinfo-data server port 'password) "")
@text
It looks like your news server requires you to enter a user name
and a password:
User name: @variable{user-name}
Password: @variable{user-name}
@end text
@c Local variables:
@c mode: texinfo
@c End:
@c arch tag is missing

39
etc/images/gnus/mail_send.xpm Normal file
View File

@ -0,0 +1,39 @@
/* XPM */
static char *magick[] = {
/* columns rows colors chars-per-pixel */
"24 24 9 1",
" c Gray0",
". c #675e6580613e",
"X c #8c8c7c7c6969",
"o c #9b458d377822",
"O c #a941a6459f3e",
"+ c #c8c8b2b29898",
"@ c #dadac2c2a5a5",
"# c #eb4dea2fe4ad",
"$ c None",
/* pixels */
"$$$$$$$$$$$$$$$$$$$$$$$$",
"$$$$$$$$$$$$$$$$$$$$$$$$",
"$$$$$$$$$$$$$ $$$$$$$",
"$$$$$$$$ .@#+ $$$$$$",
"$$$ .+#####@O $$$$$$",
"$$ .+##########.+O $$$$$",
"$$ @..########O.+# $$$$$",
"$$ O@O..@#####.+## $$$$$",
"$$$ ###+O.O##...##O $$$$",
"$$$ @####@+..O#O.+# $$$$",
"$$$ O####.#######.O $$$$",
"$$$$ ###+O########.O $$$",
"$$$$ ###.########@O $$$",
"$$$$ +#+O#####@O $$$$$",
"$$$$$ #.###@O $$$$$$",
"$$$$$ .O@O $$ .. $$$$$",
"$$$$$ .. $$$$ .oo. $$$$",
"$$$$$$ $$$$$ oo $$$",
"$$$$$$$$$$$$$$$ Oo $$$$$",
"$$$$$$$$$$$$$$ oOOX $$$$",
"$$$$$$$$$$$$$$ ++++ $$$$",
"$$$$$$$$$$$$$ O@@@@O $$$",
"$$$$$$$$$$$$$ $$$",
"$$$$$$$$$$$$$$$$$$$$$$$$"
};

24
etc/images/smilies/grayscale/blink.xpm Normal file
View File

@ -0,0 +1,24 @@
/* XPM */
static char * blink_xpm[] = {
"14 14 7 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #6E6E6E",
"# c #515151",
"$ c #ABABAB",
"% c #737373",
" ",
" ",
" . ",
" + ",
" @#$$# + ",
" ++ + ",
" ",
" + + ",
" $+ +$ ",
" %+ +% ",
" %++++% ",
" $$$$ ",
" ",
" "};

23
etc/images/smilies/grayscale/braindamaged.xpm Normal file
View File

@ -0,0 +1,23 @@
/* XPM */
static char * braindamaged_xpm[] = {
"14 14 6 1",
" c None",
". c #ABABAB",
"+ c #000000",
"@ c #515151",
"# c #171717",
"$ c #737373",
" ",
" ",
" .++..++. ",
" +@.++.@+ ",
" +.@#@@.+ ",
" +@.#@.@+ ",
" .++. ++. ",
" + + ",
" .+ +. ",
" $+ +$ ",
" $++++$ ",
" .... ",
" ",
" "};

23
etc/images/smilies/grayscale/cry.xpm Normal file
View File

@ -0,0 +1,23 @@
/* XPM */
static char * cry_xpm[] = {
"14 14 6 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #ABABAB",
"# c #515151",
"$ c #6E6E6E",
" ",
" ",
" . ",
" .. .+. ",
" +++. +.+ ",
" +@+ ",
" @+# ",
" @@ ",
" $++++$ ",
" .+@ @+. ",
" @+@ @+@ ",
" @ @ ",
" ",
" "};

21
etc/images/smilies/grayscale/dead.xpm Normal file
View File

@ -0,0 +1,21 @@
/* XPM */
static char * dead_xpm[] = {
"14 14 4 1",
" c None",
". c #737373",
"+ c #ABABAB",
"@ c #000000",
" ",
" ",
" .+ +. + +. ",
" +@+@++@+@+ ",
" +@ @+ ",
" +@+@ @+@+ ",
" + +. + + ",
" ",
" +@ @+ ",
" .@ @. ",
" .@@@@. ",
" ++++ ",
" ",
" "};

23
etc/images/smilies/grayscale/evil.xpm Normal file
View File

@ -0,0 +1,23 @@
/* XPM */
static char * evil_xpm[] = {
"14 14 6 1",
" c None",
". c #6E6E6E",
"+ c #484848",
"@ c #ABABAB",
"# c #000000",
"$ c #737373",
" ",
" ",
" .+ +. ",
" @# #@ ",
" #+ @+# ",
" #+ @+# ",
" ",
" # # ",
" @# #@ ",
" $# #$ ",
" $####$ ",
" @@@@ ",
" ",
" "};

23
etc/images/smilies/grayscale/forced.xpm Normal file
View File

@ -0,0 +1,23 @@
/* XPM */
static char * forced_xpm[] = {
"14 14 6 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #6E6E6E",
"# c #ABABAB",
"$ c #171717",
" ",
" ",
" . . ",
" + + ",
" + + ",
" + + ",
" ",
" @ @ ",
" +# #+ ",
" @@# #@@ ",
" #$++++++$# ",
" ######## ",
" ",
" "};

22
etc/images/smilies/grayscale/frown.xpm Normal file
View File

@ -0,0 +1,22 @@
/* XPM */
static char * frown_xpm[] = {
"14 14 5 1",
" c None",
". c #6E6E6E",
"+ c #484848",
"@ c #ABABAB",
"# c #000000",
" ",
" ",
" .+ +. ",
" @# #@ ",
" #+ @+# ",
" #+@@+# ",
" ",
" @@ ",
" .####. ",
" +#@ @#+ ",
" @#@ @#@ ",
" + + ",
" ",
" "};

25
etc/images/smilies/grayscale/grin.xpm Normal file
View File

@ -0,0 +1,25 @@
/* XPM */
static char * grin_xpm[] = {
"14 14 8 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #515151",
"# c #6E6E6E",
"$ c #ABABAB",
"% c #FFFFFF",
"& c #737373",
" ",
" ",
" . . ",
" + + ",
" + + ",
" + + ",
" ",
" ++@@##@@++ ",
" $+%%%%%%+$ ",
" &+%%%%+& ",
" &++++& ",
" $$$$ ",
" ",
" "};

23
etc/images/smilies/grayscale/indifferent.xpm Normal file
View File

@ -0,0 +1,23 @@
/* XPM */
static char * indifferent_xpm[] = {
"14 14 6 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #515151",
"# c #ABABAB",
"$ c #6E6E6E",
" ",
" ",
" . . ",
" + + ",
" + + ",
" + + ",
" ",
" @ #@ ",
"#+$+$ $ + ",
"$ +#+$#++$+$ ",
" $ ++# ++ ",
" + ",
" ",
" "};

22
etc/images/smilies/grayscale/reverse-smile.xpm Normal file
View File

@ -0,0 +1,22 @@
/* XPM */
static char * reverse_smile_xpm[] = {
"14 14 5 1",
" c None",
". c #ABABAB",
"+ c #737373",
"@ c #000000",
"# c #484848",
" ",
" ",
" .... ",
" +@@@@+ ",
" +@ @+ ",
" .@ @. ",
" @ @ ",
" ",
" @ @ ",
" @ @ ",
" @ @ ",
" # # ",
" ",
" "};

22
etc/images/smilies/grayscale/sad.xpm Normal file
View File

@ -0,0 +1,22 @@
/* XPM */
static char * sad_xpm[] = {
"14 14 5 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #ABABAB",
"# c #6E6E6E",
" ",
" ",
" . . ",
" + + ",
" + + ",
" + + ",
" ",
" @@@@ ",
" #++++# ",
" .+@ @+. ",
" @+@ @+@ ",
" . . ",
" ",
" "};

22
etc/images/smilies/grayscale/smile.xpm Normal file
View File

@ -0,0 +1,22 @@
/* XPM */
static char * smile_xpm[] = {
"14 14 5 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #ABABAB",
"# c #737373",
" ",
" ",
" . . ",
" + + ",
" + + ",
" + + ",
" ",
" + + ",
" @+ +@ ",
" #+ +# ",
" #++++# ",
" @@@@ ",
" ",
" "};

23
etc/images/smilies/grayscale/wry.xpm Normal file
View File

@ -0,0 +1,23 @@
/* XPM */
static char * wry_xpm[] = {
"14 14 6 1",
" c None",
". c #484848",
"+ c #000000",
"@ c #515151",
"# c #ABABAB",
"$ c #6E6E6E",
" ",
" ",
" . . ",
" + + ",
" + + ",
" + + ",
" ",
" @ ",
" ## $@ ",
" #++++++# ",
" @$ ## ",
" @ ",
" ",
" "};

29
etc/images/smilies/medium/blink.xpm Normal file
View File

@ -0,0 +1,29 @@
/* XPM */
static char * blink_xpm[] = {
"16 16 10 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
"= c #8F7B00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&&&&&&*&&%. ",
" +$&&&&&&&.&&$+ ",
".@&@%##%&&.&&&@.",
".#&&&..&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$&.&&&&&&&&.&$.",
".#&#.&&&&&&.#&#.",
".@&&=.&&&&.=&&@.",
" +$&&=....=&&$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/braindamaged.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * braindamaged_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #8F7B00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&#..##..#&%. ",
" +$&.%#..#%.&$+ ",
".@&&.#%+%%#.&&@.",
".#&&.%#+%#%.&&#.",
".$&&#..#&..#&&$.",
".$&.&&&&&&&&.&$.",
".#&#.&&&&&&.#&#.",
".@&&*.&&&&.*&&@.",
" +$&&*....*&&$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/cry.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * cry_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&&&&&&*&&%. ",
" +$&&**&&*.*&$+ ",
".@&&...*&.*.&&@.",
".#&&&&&&&.#.&&#.",
".$&&&&&&&#.%&&$.",
".$&&&&&&&&&&&&$.",
".#&&&@....@&&&#.",
".@&&*.#&&#.*&&@.",
" +$#.#&&&&#.#$+ ",
" .%&*&&&&&&*&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/dead.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * dead_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #8F7B00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%*#&#*$#&#*%. ",
" +$#.#.##.#.#$+ ",
".@&&#.$&&$.#&&@.",
".#&#.#.$$.#.#&#.",
".$&*#&#*$#&#*&$.",
".$&.&&&&&&&&.&$.",
".#&#.&&&&&&.#&#.",
".@&&*.&&&&.*&&@.",
" +$&&*....*&&$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

29
etc/images/smilies/medium/evil.xpm Normal file
View File

@ -0,0 +1,29 @@
/* XPM */
static char * evil_xpm[] = {
"16 16 10 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
"= c #8F7B00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&@*&&&&*@&%. ",
" +$&#.&&&&.#&$+ ",
".@&&&.*&#*.&&&@.",
".#&&&.*##*.&&&#.",
".$&&&&&&&&&&&&$.",
".$&.&&&&&&&&.&$.",
".#&#.&&&&&&.#&#.",
".@&&=.&&&&.=&&@.",
" +$&&=....=&&$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/forced.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * forced_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&*&&&&*&&%. ",
" +$&&.&&&&.&&$+ ",
".@&&&.&&&&.&&&@.",
".#&&&.&&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$&@&&&&&&&&@&$.",
".#&.#&&&&&&#.&#.",
".@&@@#&&&&#@@&@.",
" +$#+......+#$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/frown.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * frown_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&@*&&&&*@&%. ",
" +$&#.&&&&.#&$+ ",
".@&&&.*&#*.&&&@.",
".#&&&.*##*.&&&#.",
".$&&&&&&&&&&&&$.",
".$&&&&&&&&&&&&$.",
".#&&&@....@&&&#.",
".@&&*.#&&#.*&&@.",
" +$#.#&&&&#.#$+ ",
" .%&*&&&&&&*&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

30
etc/images/smilies/medium/grin.xpm Normal file
View File

@ -0,0 +1,30 @@
/* XPM */
static char * grin_xpm[] = {
"16 16 11 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
"= c #FFFFFF",
"- c #8F7B00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&*&&&&*&&%. ",
" +$&&.&&&&.&&$+ ",
".@&&&.&&&&.&&&@.",
".#&&&.&&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$&..%%@@%%..&$.",
".#&#.======.#&#.",
".@&&-.====.-&&@.",
" +$&&-....-&&$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/indifferent.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * indifferent_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&*&&&&*&&%. ",
" +$&&.&&&&.&&$+ ",
".@&&&.&&&&.&&&@.",
".#&&&.&&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$%&&&&&&&&&#%$.",
".#.@.@&&&@&&.&#.",
".@&.#.@#..@.@&@.",
" +$@&&..#&..&$+ ",
" .%&&&&.&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

29
etc/images/smilies/medium/reverse-smile.xpm Normal file
View File

@ -0,0 +1,29 @@
/* XPM */
static char * reverse_smile_xpm[] = {
"16 16 10 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #8F7B00",
"= c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&&&&&&&&&%. ",
" +$&&*....*&&$+ ",
".@&&*.&&&&.*&&@.",
".#&#.&&&&&&.#&#.",
".$&.&&&&&&&&.&$.",
".$&&&&&&&&&&&&$.",
".#&&&.&&&&.&&&#.",
".@&&&.&&&&.&&&@.",
" +$&&.&&&&.&&$+ ",
" .%&&=&&&&=&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/sad.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * sad_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&*&&&&*&&%. ",
" +$&&.&&&&.&&$+ ",
".@&&&.&&&&.&&&@.",
".#&&&.&&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$&&&&&&&&&&&&$.",
".#&&&@....@&&&#.",
".@&&*.#&&#.*&&@.",
" +$#.#&&&&#.#$+ ",
" .%&*&&&&&&*&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

29
etc/images/smilies/medium/smile.xpm Normal file
View File

@ -0,0 +1,29 @@
/* XPM */
static char * smile_xpm[] = {
"16 16 10 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
"= c #8F7B00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&*&&&&*&&%. ",
" +$&&.&&&&.&&$+ ",
".@&&&.&&&&.&&&@.",
".#&&&.&&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$&.&&&&&&&&.&$.",
".#&#.&&&&&&.#&#.",
".@&&=.&&&&.=&&@.",
" +$&&=....=&&$+ ",
" .%&&&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

28
etc/images/smilies/medium/wry.xpm Normal file
View File

@ -0,0 +1,28 @@
/* XPM */
static char * wry_xpm[] = {
"16 16 9 1",
" c None",
". c #000000",
"+ c #1D1900",
"@ c #887500",
"# c #D3B600",
"$ c #FAD800",
"% c #645600",
"& c #FFDD00",
"* c #594D00",
" ...... ",
" .+@#$$#@+. ",
" .%$&&&&&&$%. ",
" .%&&*&&&&*&&%. ",
" +$&&.&&&&.&&$+ ",
".@&&&.&&&&.&&&@.",
".#&&&.&&&&.&&&#.",
".$&&&&&&&&&&&&$.",
".$&&&&&&&&&%&&$.",
".#&&&&&&&&@%&&#.",
".@&&#......#&&@.",
" +$&%@&&&&&&&$+ ",
" .%&%&&&&&&&&%. ",
" .%$&&&&&&$%. ",
" .+@#$$#@+. ",
" ...... "};

12
etc/refcards/gnus-refcard.tex
View File

@ -121,7 +121,12 @@
\newcommand{\Copyright}{%
\begin{center}
Copyright \copyright\ 1995, 2000, 2002, 2003, 2004,
2005, 2006, 2007 Free Software Foundation, Inc.
2005, 2006, 2007 Free Software Foundation, Inc.\\*
Copyright \copyright\ 2001, 2002, 2003, 2004, 2005 \author.\\*
Created from the Gnus manual Copyright \copyright\ 1994 Lars Magne
Ingebrigtsen.\\*
and the Emacs Help Bindings feature (C-h b).\\*
Gnus logo copyright \copyright\ 1995 Luis Fernandes.\\*
\end{center}
Permission is granted to make and distribute copies of this reference
@ -566,7 +571,7 @@
{\esamepage
\begin{keys}{C-c C-s C-a}
C-c C-s C-a & Sort the summary-buffer by {\bf author}.\\
% C-c C-s C-t & Sort the summary-buffer by {\bf recipient}.\\ % No Gnus
C-c C-s C-t & Sort the summary-buffer by {\bf recipient}.\\
C-c C-s C-d & Sort the summary-buffer by {\bf date}.\\
C-c C-s C-i & Sort the summary-buffer by article score.\\
C-c C-s C-l & Sort the summary-buffer by amount of {\bf lines}.\\
@ -876,6 +881,7 @@
\begin{keys}{/M}
// & (/s) Limit the summary-buffer to articles matching {\bf subject}.\\
/a & Limit the summary-buffer to articles matching {\bf author}.\\
/R & Limit the summary-buffer to articles matching {\bf recipient}.\\
/x & Limit depending on ``extra'' headers.\\
/u & (x) Limit to {\bf unread} articles.
[Prefix: also exclude ticked and dormant articles]\\
@ -900,7 +906,7 @@
/o & Insert all {\bf old} articles. [Prefix: how many]\\
/N & Insert all {\bf new} articles.\\
/p & Limit to articles {\bf predicated} in the `display' group parameter.\\
% /r & Limit to {\bf replied} articles. [Prefix: unreplied]\\ % No Gnus
/r & Limit to {\bf replied} articles. [Prefix: unreplied]\\
\end{keys}
}
}

9018
lisp/gnus/ChangeLog
View File

File diff suppressed because it is too large Load Diff

487
lisp/gnus/assistant.el Normal file
View File

@ -0,0 +1,487 @@
;;; assistant.el --- guiding users through Emacs setup
;; Copyright (C) 2004, 2005 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: util
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(eval-when-compile
(require 'cl))
(require 'widget)
(require 'wid-edit)
(autoload 'gnus-error "gnus-util")
(autoload 'netrc-get "netrc")
(autoload 'netrc-machine "netrc")
(autoload 'netrc-parse "netrc")
(defvar assistant-readers
'(("variable" assistant-variable-reader)
("validate" assistant-sexp-reader)
("result" assistant-list-reader)
("next" assistant-list-reader)
("text" assistant-text-reader)))
(defface assistant-field '((t (:bold t)))
"Face used for editable fields."
:group 'gnus-article-emphasis)
;; backward-compatibility alias
(put 'assistant-field-face 'face-alias 'assistant-field)
;;; Internal variables
(defvar assistant-data nil)
(defvar assistant-current-node nil)
(defvar assistant-previous-nodes nil)
(defvar assistant-widgets nil)
(defun assistant-parse-buffer ()
(let (results command value)
(goto-char (point-min))
(while (search-forward "@" nil t)
(if (not (looking-at "[^ \t\n]+"))
(error "Dangling @")
(setq command (downcase (match-string 0)))
(goto-char (match-end 0)))
(setq value
(if (looking-at "[ \t]*\n")
(let (start)
(forward-line 1)
(setq start (point))
(unless (re-search-forward (concat "^@end " command) nil t)
(error "No @end %s found" command))
(beginning-of-line)
(prog1
(buffer-substring start (point))
(forward-line 1)))
(skip-chars-forward " \t")
(prog1
(buffer-substring (point) (point-at-eol))
(forward-line 1))))
(push (list command (assistant-reader command value))
results))
(assistant-segment (nreverse results))))
(defun assistant-text-reader (text)
(with-temp-buffer
(insert text)
(goto-char (point-min))
(let ((start (point))
(sections nil))
(while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t)
(push (buffer-substring start (match-beginning 0))
sections)
(push (list (match-string 1) (match-string 2))
sections)
(setq start (point)))
(push (buffer-substring start (point-max))
sections)
(nreverse sections))))
;; Segment the raw assistant data into a list of nodes.
(defun assistant-segment (list)
(let ((ast nil)
(node nil)
(title (pop list)))
(dolist (elem list)
(when (and (equal (car elem) "node")
node)
(push (list "save" nil) node)
(push (nreverse node) ast)
(setq node nil))
(push elem node))
(when node
(push (list "save" nil) node)
(push (nreverse node) ast))
(cons title (nreverse ast))))
(defun assistant-reader (command value)
(let ((formatter (cadr (assoc command assistant-readers))))
(if (not formatter)
value
(funcall formatter value))))
(defun assistant-list-reader (value)
(car (read-from-string (concat "(" value ")"))))
(defun assistant-variable-reader (value)
(let ((section (car (read-from-string (concat "(" value ")")))))
(append section (list 'default))))
(defun assistant-sexp-reader (value)
(if (zerop (length value))
nil
(car (read-from-string value))))
(defun assistant-buffer-name (title)
(format "*Assistant %s*" title))
(defun assistant-get (ast command)
(cadr (assoc command ast)))
(defun assistant-set (ast command value)
(let ((elem (assoc command ast)))
(when elem
(setcar (cdr elem) value))))
(defun assistant-get-list (ast command)
(let ((result nil))
(dolist (elem ast)
(when (equal (car elem) command)
(push elem result)))
(nreverse result)))
;;;###autoload
(defun assistant (file)
"Assist setting up Emacs based on FILE."
(interactive "fAssistant file name: ")
(let ((ast
(with-temp-buffer
(insert-file-contents file)
(assistant-parse-buffer))))
(pop-to-buffer (assistant-buffer-name (assistant-get ast "title")))
(assistant-render ast)))
(defun assistant-render (ast)
(let ((first-node (assistant-get (nth 1 ast) "node")))
(set (make-local-variable 'assistant-data) ast)
(set (make-local-variable 'assistant-current-node) nil)
(set (make-local-variable 'assistant-previous-nodes) nil)
(assistant-render-node first-node)))
(defun assistant-find-node (node-name)
(let ((ast (cdr assistant-data)))
(while (and ast
(not (string= node-name (assistant-get (car ast) "node"))))
(pop ast))
(car ast)))
(defun assistant-node-name (node)
(assistant-get node "node"))
(defun assistant-previous-node-text (node)
(format "<< Go back to %s" node))
(defun assistant-next-node-text (node)
(if (and node
(not (eq node 'finish)))
(format "Proceed to %s >>" node)
"Finish"))
(defun assistant-set-defaults (node &optional forcep)
(dolist (variable (assistant-get-list node "variable"))
(setq variable (cadr variable))
(when (or (eq (nth 3 variable) 'default)
forcep)
(setcar (nthcdr 3 variable)
(assistant-eval (nth 2 variable))))))
(defun assistant-get-variable (node variable &optional type raw)
(let ((variables (assistant-get-list node "variable"))
(result nil)
elem)
(while (and (setq elem (pop variables))
(not result))
(setq elem (cadr elem))
(when (eq (intern variable) (car elem))
(if type
(setq result (nth 1 elem))
(setq result (if raw (nth 3 elem)
(format "%s" (nth 3 elem)))))))
result))
(defun assistant-set-variable (node variable value)
(let ((variables (assistant-get-list node "variable"))
elem)
(while (setq elem (pop variables))
(setq elem (cadr elem))
(when (eq (intern variable) (car elem))
(setcar (nthcdr 3 elem) value)))))
(defun assistant-render-text (text node)
(unless (and text node)
(gnus-error
5
"The assistant was asked to render invalid text or node data"))
(dolist (elem text)
(if (stringp elem)
;; Ordinary text
(insert elem)
;; A variable to be inserted as a widget.
(let* ((start (point))
(variable (cadr elem))
(type (assistant-get-variable node variable 'type)))
(cond
((eq (car-safe type) :radio)
(push
(apply
#'widget-create
'radio-button-choice
:assistant-variable variable
:assistant-node node
:value (assistant-get-variable node variable)
:notify (lambda (widget &rest ignore)
(assistant-set-variable
(widget-get widget :assistant-node)
(widget-get widget :assistant-variable)
(widget-value widget))
(assistant-render-node
(assistant-get
(widget-get widget :assistant-node)
"node")))
(cadr type))
assistant-widgets))
((eq (car-safe type) :set)
(push
(apply
#'widget-create
'set
:assistant-variable variable
:assistant-node node
:value (assistant-get-variable node variable nil t)
:notify (lambda (widget &rest ignore)
(assistant-set-variable
(widget-get widget :assistant-node)
(widget-get widget :assistant-variable)
(widget-value widget))
(assistant-render-node
(assistant-get
(widget-get widget :assistant-node)
"node")))
(cadr type))
assistant-widgets))
(t
(push
(widget-create
'editable-field
:value-face 'assistant-field
:assistant-variable variable
(assistant-get-variable node variable))
assistant-widgets)
;; The editable-field widget apparently inserts a newline;
;; remove it.
(delete-char -1)
(add-text-properties start (point)
(list
'bold t
'face 'assistant-field
'not-read-only t))))))))
(defun assistant-render-node (node-name)
(let ((node (assistant-find-node node-name))
(inhibit-read-only t)
(previous assistant-current-node)
(buffer-read-only nil))
(unless node
(gnus-error 5 "The node for %s could not be found" node-name))
(set (make-local-variable 'assistant-widgets) nil)
(assistant-set-defaults node)
(if (equal (assistant-get node "type") "interstitial")
(assistant-render-node (nth 0 (assistant-find-next-nodes node-name)))
(setq assistant-current-node node-name)
(when previous
(push previous assistant-previous-nodes))
(erase-buffer)
(insert (cadar assistant-data) "\n\n")
(insert node-name "\n\n")
(assistant-render-text (assistant-get node "text") node)
(insert "\n\n")
(when assistant-previous-nodes
(assistant-node-button 'previous (car assistant-previous-nodes)))
(widget-create
'push-button
:assistant-node node-name
:notify (lambda (widget &rest ignore)
(let* ((node (widget-get widget :assistant-node)))
(assistant-set-defaults (assistant-find-node node) 'force)
(assistant-render-node node)))
"Reset")
(insert "\n")
(dolist (nnode (assistant-find-next-nodes))
(assistant-node-button 'next nnode)
(insert "\n"))
(goto-char (point-min))
(assistant-make-read-only))))
(defun assistant-make-read-only ()
(let ((start (point-min))
end)
(while (setq end (text-property-any start (point-max) 'not-read-only t))
(put-text-property start end 'read-only t)
(put-text-property start end 'rear-nonsticky t)
(while (get-text-property end 'not-read-only)
(incf end))
(setq start end))
(put-text-property start (point-max) 'read-only t)))
(defun assistant-node-button (type node)
(let ((text (if (eq type 'next)
(assistant-next-node-text node)
(assistant-previous-node-text node))))
(widget-create
'push-button
:assistant-node node
:assistant-type type
:notify (lambda (widget &rest ignore)
(let* ((node (widget-get widget :assistant-node))
(type (widget-get widget :assistant-type)))
(if (eq type 'previous)
(progn
(setq assistant-current-node nil)
(pop assistant-previous-nodes))
(assistant-get-widget-values)
(assistant-validate))
(if (null node)
(assistant-finish)
(assistant-render-node node))))
text)
(use-local-map widget-keymap)))
(defun assistant-validate-types (node)
(dolist (variable (assistant-get-list node "variable"))
(setq variable (cadr variable))
(let ((type (nth 1 variable))
(value (nth 3 variable)))
(when
(cond
((eq type :number)
(string-match "[^0-9]" value))
(t
nil))
(error "%s is not of type %s: %s"
(car variable) type value)))))
(defun assistant-get-widget-values ()
(let ((node (assistant-find-node assistant-current-node)))
(dolist (widget assistant-widgets)
(assistant-set-variable
node (widget-get widget :assistant-variable)
(widget-value widget)))))
(defun assistant-validate ()
(let* ((node (assistant-find-node assistant-current-node))
(validation (assistant-get node "validate"))
result)
(assistant-validate-types node)
(when validation
(when (setq result (assistant-eval validation))
(unless (y-or-n-p (format "Error: %s. Continue? " result))
(error "%s" result))))
(assistant-set node "save" t)))
;; (defun assistant-find-next-node (&optional node)
;; (let* ((node (assistant-find-node (or node assistant-current-node)))
;; (node-name (assistant-node-name node))
;; (nexts (assistant-get-list node "next"))
;; next elem applicable)
;; (while (setq elem (pop nexts))
;; (when (assistant-eval (car (cadr elem)))
;; (setq applicable (cons elem applicable))))
;; ;; return the first thing we can
;; (cadr (cadr (pop applicable)))))
(defun assistant-find-next-nodes (&optional node)
(let* ((node (assistant-find-node (or node assistant-current-node)))
(nexts (assistant-get-list node "next"))
next elem applicable return)
(while (setq elem (pop nexts))
(when (assistant-eval (car (cadr elem)))
(setq applicable (cons elem applicable))))
;; return the first thing we can
(while (setq elem (pop applicable))
(push (cadr (cadr elem)) return))
return))
(defun assistant-get-all-variables ()
(let ((variables nil))
(dolist (node (cdr assistant-data))
(setq variables
(append (assistant-get-list node "variable")
variables)))
variables))
(defun assistant-eval (form)
(let ((bindings nil))
(dolist (variable (assistant-get-all-variables))
(setq variable (cadr variable))
(push (list (car variable)
(if (eq (nth 3 variable) 'default)
nil
(if (listp (nth 3 variable))
`(list ,@(nth 3 variable))
(nth 3 variable))))
bindings))
(eval
`(let ,bindings
,form))))
(defun assistant-finish ()
(let ((results nil)
result)
(dolist (node (cdr assistant-data))
(when (assistant-get node "save")
(setq result (assistant-get node "result"))
(push (list (car result)
(assistant-eval (cadr result)))
results)))
(message "Results: %s"
(nreverse results))))
;;; Validation functions.
(defun assistant-validate-connect-to-server (server port)
(let* ((error nil)
(stream
(condition-case err
(open-network-stream "nntpd" nil server port)
(error (setq error err)))))
(if (and (processp stream)
(memq (process-status stream) '(open run)))
(progn
(delete-process stream)
nil)
error)))
(defun assistant-authinfo-data (server port type)
(when (file-exists-p "~/.authinfo")
(netrc-get (netrc-machine (netrc-parse "~/.authinfo")
server port)
(if (eq type 'user)
"login"
"password"))))
(defun assistant-password-required-p ()
nil)
(provide 'assistant)
;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b
;;; assistant.el ends here

17
lisp/gnus/binhex.el
View File

@ -27,8 +27,6 @@
;;; Code:
(autoload 'executable-find "executable")
(eval-when-compile (require 'cl))
(eval-and-compile
@ -246,14 +244,13 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(setq file-name-length (char-after (point-min))
data-fork-start (+ (point-min)
file-name-length 22))))
(if (and (null header)
(with-current-buffer work-buffer
(>= (buffer-size) data-fork-start)))
(progn
(binhex-verify-crc work-buffer
(point-min) data-fork-start)
(setq header (binhex-header work-buffer))
(if header-only (setq tmp nil counter 0))))
(when (and (null header)
(with-current-buffer work-buffer
(>= (buffer-size) data-fork-start)))
(binhex-verify-crc work-buffer
(point-min) data-fork-start)
(setq header (binhex-header work-buffer))
(when header-only (setq tmp nil counter 0)))
(setq tmp (and tmp (not (eq inputpos end)))))
(cond
((= counter 3)

142
lisp/gnus/deuglify.el
View File

@ -315,71 +315,77 @@ You can control what lines will be unwrapped by frobbing
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 "]+.*\\)$")
(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)))
(let ((len12 (- (match-end 2) (match-beginning 1)))
(len3 (- (match-end 3) (match-beginning 3))))
(if (and (> len12 gnus-outlook-deuglify-unwrap-min)
(when (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)))))))))
(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)))))))
;; FIXME: 1. (*) text/plain ( ) text/html
(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
(when (< to attr-start)
(setq to (point-max)))
(save-excursion
(narrow-to-region attr-start to)
(goto-char attr-start)
(forward-line)
(unless (looking-at ">")
(message-indent-citation (point) (point-max) 'yank-only)
(goto-char (point-max))
(newline)
(setq to (point-max)))
(widen))
(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
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
(when (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)))))))
(gnus-kill-all-overlays)
(replace-match "\\1\\2\\4")
(match-beginning 0)))))
;; ----- Original Message -----
@ -390,42 +396,38 @@ NODISPLAY is non-nil, don't redisplay the article buffer."
(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"
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
(when (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)))))))
(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
(let ((case-fold-search nil)
(inhibit-read-only t)
(cite-marks gnus-outlook-deuglify-cite-marks))
(gnus-with-article-buffer
(article-goto-body)
(when (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)))))))
(gnus-kill-all-overlays)
(replace-match "\\4 \\5\\6\\7")
(match-beginning 0)))))
;;;###autoload
(defun gnus-article-outlook-repair-attribution (&optional nodisplay)

93
lisp/gnus/dns.el
View File

@ -51,11 +51,13 @@ If nil, /etc/resolv.conf will be consulted.")
(MR 9)
(NULL 10)
(WKS 11)
(PRT 12)
(PTR 12)
(HINFO 13)
(MINFO 14)
(MX 15)
(TXT 16)
(AAAA 28) ; RFC3596
(SRV 33) ; RFC2782
(AXFR 252)
(MAILB 253)
(MAILA 254)
@ -252,6 +254,12 @@ If TCP-P, the first two bytes of the package with be the length field."
(push (list slot qs) spec)))
(nreverse spec))))
(defun dns-read-int32 ()
;; Full 32 bit Integers can't be handled by Emacs. If we use
;; floats, it works.
(format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
(dns-read-bytes 3))))
(defun dns-read-type (string type)
(let ((buffer (current-buffer))
(point (point)))
@ -265,9 +273,27 @@ If TCP-P, the first two bytes of the package with be the length field."
(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)
((eq type 'AAAA)
(let (hextets)
(dotimes (i 8)
(push (dns-read-bytes 2) hextets))
(mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":")))
((eq type 'SOA)
(list (list 'mname (dns-read-name buffer))
(list 'rname (dns-read-name buffer))
(list 'serial (dns-read-int32))
(list 'refresh (dns-read-int32))
(list 'retry (dns-read-int32))
(list 'expire (dns-read-int32))
(list 'minimum (dns-read-int32))))
((eq type 'SRV)
(list (list 'priority (dns-read-bytes 2))
(list 'weight (dns-read-bytes 2))
(list 'port (dns-read-bytes 2))
(list 'target (dns-read-name buffer))))
((eq type 'MX)
(cons (dns-read-bytes 2) (dns-read-name buffer)))
((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
(dns-read-string-name string buffer))
(t string)))
(goto-char point))))
@ -281,17 +307,32 @@ If TCP-P, the first two bytes of the package with be the length field."
(push (match-string 1) dns-servers))
(setq dns-servers (nreverse dns-servers)))))
;;; Interface functions.
(eval-when-compile
(when (featurep 'xemacs)
(require 'gnus-xmas)))
(defun dns-read-txt (string)
(if (> (length string) 1)
(substring string 1)
string))
(defun dns-get-txt-answer (answers)
(let ((result "")
(do-next nil))
(dolist (answer answers)
(dolist (elem answer)
(when (consp elem)
(cond
((eq (car elem) 'type)
(setq do-next (eq (cadr elem) 'TXT)))
((eq (car elem) 'data)
(when do-next
(setq result (concat result (dns-read-txt (cadr elem))))))))))
result))
;;; Interface functions.
(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))
(open-network-stream "dns" (current-buffer)
,server "domain" 'udp))
`(let ((server ,server)
(coding-system-for-read 'binary)
(coding-system-for-write 'binary))
@ -308,13 +349,32 @@ If TCP-P, the first two bytes of the package with be the length field."
;; connection to the DNS server.
(open-network-stream "dns" (current-buffer) server "domain")))))
(defun query-dns (name &optional type fullp)
(defvar dns-cache (make-vector 4096 0))
(defun query-dns-cached (name &optional type fullp reversep)
(let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
(sym (intern-soft key dns-cache)))
(if (and sym
(boundp sym))
(symbol-value sym)
(let ((result (query-dns name type fullp reversep)))
(set (intern key dns-cache) result)
result))))
(defun query-dns (name &optional type fullp reversep)
"Query a DNS server for NAME of TYPE.
If FULLP, return the entire record returned."
If FULLP, return the entire record returned.
If REVERSEP, look up an IP address."
(setq type (or type 'A))
(unless dns-servers
(dns-parse-resolv-conf))
(when reversep
(setq name (concat
(mapconcat 'identity (nreverse (split-string name "\\.")) ".")
".in-addr.arpa")
type 'PTR))
(if (not dns-servers)
(message "No DNS server configuration found")
(mm-with-unibyte-buffer
@ -339,6 +399,7 @@ If FULLP, return the entire record returned."
tcp-p))
(while (and (zerop (buffer-size))
(> times 0))
(sit-for (/ step 1000.0))
(accept-process-output process 0 step)
(decf times step))
(ignore-errors
@ -347,13 +408,17 @@ If FULLP, return the entire record returned."
(>= (buffer-size) 2))
(goto-char (point-min))
(delete-region (point) (+ (point) 2)))
(when (>= (buffer-size) 2)
(when (and (>= (buffer-size) 2)
;; We had a time-out.
(> times 0))
(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)))))))))))
(if (eq type 'TXT)
(dns-get-txt-answer (dns-get 'answers result))
(dns-get 'data answer))))))))))))
(provide 'dns)

152
lisp/gnus/ecomplete.el Normal file
View File

@ -0,0 +1,152 @@
;;; ecomplete.el --- electric completion of addresses and the like
;; Copyright (C) 2006 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(eval-when-compile
(require 'cl))
(defgroup ecomplete nil
"Electric completion of email addresses and the like."
:group 'mail)
(defcustom ecomplete-database-file "~/.ecompleterc"
"*The name of the file to store the ecomplete data."
:group 'ecomplete
:type 'file)
(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit
"Coding system used for writing the ecomplete database file."
:type '(symbol :tag "Coding system")
:group 'ecomplete)
;;; Internal variables.
(defvar ecomplete-database nil)
;;;###autoload
(defun ecomplete-setup ()
(when (file-exists-p ecomplete-database-file)
(with-temp-buffer
(let ((coding-system-for-read ecomplete-database-file-coding-system))
(insert-file-contents ecomplete-database-file)
(setq ecomplete-database (read (current-buffer)))))))
(defun ecomplete-add-item (type key text)
(let ((elems (assq type ecomplete-database))
(now (string-to-number
(format "%.0f" (time-to-seconds (current-time)))))
entry)
(unless elems
(push (setq elems (list type)) ecomplete-database))
(if (setq entry (assoc key (cdr elems)))
(setcdr entry (list (1+ (cadr entry)) now text))
(nconc elems (list (list key 1 now text))))))
(defun ecomplete-get-item (type key)
(assoc key (cdr (assq type ecomplete-database))))
(defun ecomplete-save ()
(with-temp-buffer
(let ((coding-system-for-write ecomplete-database-file-coding-system))
(insert "(")
(loop for (type . elems) in ecomplete-database
do
(insert (format "(%s\n" type))
(dolist (entry elems)
(prin1 entry (current-buffer))
(insert "\n"))
(insert ")\n"))
(insert ")")
(write-region (point-min) (point-max)
ecomplete-database-file nil 'silent))))
(defun ecomplete-get-matches (type match)
(let* ((elems (cdr (assq type ecomplete-database)))
(match (regexp-quote match))
(candidates
(sort
(loop for (key count time text) in elems
when (string-match match text)
collect (list count time text))
(lambda (l1 l2)
(> (car l1) (car l2))))))
(when (> (length candidates) 10)
(setcdr (nthcdr 10 candidates) nil))
(unless (zerop (length candidates))
(with-temp-buffer
(dolist (candidate candidates)
(insert (caddr candidate) "\n"))
(goto-char (point-min))
(put-text-property (point) (1+ (point)) 'ecomplete t)
(while (re-search-forward match nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'isearch))
(buffer-string)))))
(defun ecomplete-display-matches (type word &optional choose)
(let* ((matches (ecomplete-get-matches type word))
(line 0)
(max-lines (when matches (- (length (split-string matches "\n")) 2)))
(message-log-max nil)
command highlight)
(if (not matches)
(progn
(message "No ecomplete matches")
nil)
(if (not choose)
(progn
(message matches)
nil)
(setq highlight (ecomplete-highlight-match-line matches line))
(while (not (memq (setq command (read-event highlight)) '(? return)))
(cond
((eq command ?\M-n)
(setq line (min (1+ line) max-lines)))
((eq command ?\M-p)
(setq line (max (1- line) 0))))
(setq highlight (ecomplete-highlight-match-line matches line)))
(when (eq command 'return)
(nth line (split-string matches "\n")))))))
(defun ecomplete-highlight-match-line (matches line)
(with-temp-buffer
(insert matches)
(goto-char (point-min))
(forward-line line)
(save-restriction
(narrow-to-region (point) (point-at-eol))
(while (not (eobp))
;; Put the 'region face on any charactes on this line that
;; aren't already highlighted.
(unless (get-text-property (point) 'face)
(put-text-property (point) (1+ (point)) 'face 'highlight))
(forward-char 1)))
(buffer-string)))
(provide 'ecomplete)
;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72
;;; ecomplete.el ends here

296
lisp/gnus/encrypt.el Normal file
View File

@ -0,0 +1,296 @@
;;; encrypt.el --- file encryption routines
;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
;; Author: Teodor Zlatanov <tzz@lifelogs.com>
;; Created: 2003/01/24
;; Keywords: files
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; This module addresses data encryption. Page breaks are used for
;;; grouping declarations and documentation relating to each
;;; particular aspect.
;;; Use in Gnus like this:
;;; (setq
;;; nnimap-authinfo-file "~/.authinfo.enc"
;;; nntp-authinfo-file "~/.authinfo.enc"
;;; smtpmail-auth-credentials "~/.authinfo.enc"
;;; ;; using the AES256 cipher, feel free to use your own favorite
;;; encrypt-file-alist (quote (("~/.authinfo.enc" (gpg "AES256"))))
;;; password-cache-expiry 600)
;;; Then write ~/.authinfo.enc:
;;; 1) open the old authinfo
;;; C-x C-f ~/.authinfo
;;; 2) write the new authinfo.enc
;;; M-x encrypt-file-contents ~/.authinfo.enc
;;; 3) verify the new authinfo is correct (this will show the contents in the minibuffer)
;;; M-: (encrypt-get-file-contents "~/.authinfo.enc")
;;; Code:
;; autoload password
(eval-and-compile
(autoload 'password-read "password"))
(defgroup encrypt '((password-cache custom-variable)
(password-cache-expiry custom-variable))
"File encryption configuration."
:group 'applications)
(defcustom encrypt-file-alist nil
"List of file names or regexes matched with encryptions.
Format example:
'((\"beta\"
(gpg \"AES\"))
(\"/home/tzz/alpha\"
(encrypt-xor \"Semi-Secret\")))"
:type '(repeat
(list :tag "Encryption entry"
(radio :tag "What to encrypt"
(file :tag "Filename")
(regexp :tag "Regular expression match"))
(radio :tag "How to encrypt it"
(list
:tag "GPG Encryption"
(const :tag "GPG Program" gpg)
(radio :tag "Choose a cipher"
(const :tag "3DES Encryption" "3DES")
(const :tag "CAST5 Encryption" "CAST5")
(const :tag "Blowfish Encryption" "BLOWFISH")
(const :tag "AES Encryption" "AES")
(const :tag "AES192 Encryption" "AES192")
(const :tag "AES256 Encryption" "AES256")
(const :tag "Twofish Encryption" "TWOFISH")
(string :tag "Cipher Name")))
(list
:tag "Built-in simple XOR"
(const :tag "XOR Encryption" encrypt-xor)
(string :tag "XOR Cipher Value (seed value)")))))
:group 'encrypt)
;; TODO: now, load gencrypt.el and if successful, modify the
;; custom-type of encrypt-file-alist to add the gencrypt.el options
;; (plist-get (symbol-plist 'encrypt-file-alist) 'custom-type)
;; then use plist-put
(defcustom encrypt-gpg-path (executable-find "gpg")
"Path to the GPG program."
:type '(radio
(file :tag "Location of the GPG executable")
(const :tag "GPG is not installed" nil))
:group 'encrypt)
(defvar encrypt-temp-prefix "encrypt"
"Prefix for temporary filenames")
;;;###autoload
(defun encrypt-find-model (filename)
"Given a filename, find a encrypt-file-alist entry"
(dolist (entry encrypt-file-alist)
(let ((match (nth 0 entry))
(model (nth 1 entry)))
(when (or (eq match filename)
(string-match match filename))
(return model)))))
;;;###autoload
(defun encrypt-insert-file-contents (file &optional model)
"Decrypt FILE into the current buffer."
(interactive "fFile to insert: ")
(let* ((model (or model (encrypt-find-model file)))
(method (nth 0 model))
(cipher (nth 1 model))
(password-key (format "encrypt-password-%s-%s %s"
(symbol-name method) cipher file))
(passphrase
(password-read-and-add
(format "%s password for cipher %s (file %s)? "
file (symbol-name method) cipher)
password-key))
(buffer-file-coding-system 'binary)
(coding-system-for-read 'binary)
outdata)
;; note we only insert-file-contents if the method is known to be valid
(cond
((eq method 'gpg)
(insert-file-contents file)
(setq outdata (encrypt-gpg-decode-buffer passphrase cipher)))
((eq method 'encrypt-xor)
(insert-file-contents file)
(setq outdata (encrypt-xor-decode-buffer passphrase cipher))))
(if outdata
(progn
(message "%s was decrypted with %s (cipher %s)"
file (symbol-name method) cipher)
(delete-region (point-min) (point-max))
(goto-char (point-min))
(insert outdata))
;; the decryption failed, alas
(password-cache-remove password-key)
(gnus-error 5 "%s was NOT decrypted with %s (cipher %s)"
file (symbol-name method) cipher))))
(defun encrypt-get-file-contents (file &optional model)
"Decrypt FILE and return the contents."
(interactive "fFile to decrypt: ")
(with-temp-buffer
(encrypt-insert-file-contents file model)
(buffer-string)))
(defun encrypt-put-file-contents (file data &optional model)
"Encrypt the DATA to FILE, then continue normally."
(with-temp-buffer
(insert data)
(encrypt-write-file-contents file model)))
(defun encrypt-write-file-contents (file &optional model)
"Encrypt the current buffer to FILE, then continue normally."
(interactive "sFile to write: ")
(setq model (or model (encrypt-find-model file)))
(if model
(let* ((method (nth 0 model))
(cipher (nth 1 model))
(password-key (format "encrypt-password-%s-%s %s"
(symbol-name method) cipher file))
(passphrase
(password-read
(format "%s password for cipher %s? "
(symbol-name method) cipher)
password-key))
outdata)
(cond
((eq method 'gpg)
(setq outdata (encrypt-gpg-encode-buffer passphrase cipher)))
((eq method 'encrypt-xor)
(setq outdata (encrypt-xor-encode-buffer passphrase cipher))))
(if outdata
(progn
(message "%s was encrypted with %s (cipher %s)"
file (symbol-name method) cipher)
(delete-region (point-min) (point-max))
(goto-char (point-min))
(insert outdata)
;; do not confirm overwrites
(write-file file nil))
;; the decryption failed, alas
(password-cache-remove password-key)
(gnus-error 5 "%s was NOT encrypted with %s (cipher %s)"
file (symbol-name method) cipher)))
(gnus-error 1 "%s has no associated encryption model! See encrypt-file-alist." file)))
(defun encrypt-xor-encode-buffer (passphrase cipher)
(encrypt-xor-process-buffer passphrase cipher t))
(defun encrypt-xor-decode-buffer (passphrase cipher)
(encrypt-xor-process-buffer passphrase cipher nil))
(defun encrypt-xor-process-buffer (passphrase
cipher
&optional encode)
"Given PASSPHRASE, xor-encode or decode the contents of the current buffer."
(let* ((bs (buffer-substring-no-properties (point-min) (point-max)))
;; passphrase-sum is a simple additive checksum of the
;; passphrase and the cipher
(passphrase-sum
(when (stringp passphrase)
(apply '+ (append cipher passphrase nil))))
new-list)
(with-temp-buffer
(if encode
(progn
(dolist (x (append bs nil))
(setq new-list (cons (logxor x passphrase-sum) new-list)))
(dolist (x new-list)
(insert (format "%d " x))))
(progn
(setq new-list (reverse (split-string bs)))
(dolist (x new-list)
(setq x (string-to-number x))
(insert (format "%c" (logxor x passphrase-sum))))))
(buffer-substring-no-properties (point-min) (point-max)))))
(defun encrypt-gpg-encode-buffer (passphrase cipher)
(encrypt-gpg-process-buffer passphrase cipher t))
(defun encrypt-gpg-decode-buffer (passphrase cipher)
(encrypt-gpg-process-buffer passphrase cipher nil))
(defun encrypt-gpg-process-buffer (passphrase
cipher
&optional encode)
"With PASSPHRASE, use GPG to encode or decode the current buffer."
(let* ((program encrypt-gpg-path)
(input (buffer-substring-no-properties (point-min) (point-max)))
(temp-maker (if (fboundp 'make-temp-file)
'make-temp-file
'make-temp-name))
(temp-file (funcall temp-maker encrypt-temp-prefix))
(default-enable-multibyte-characters nil)
(args `("--cipher-algo" ,cipher
"--status-fd" "2"
"--logger-fd" "2"
"--passphrase-fd" "0"
"--no-tty"))
exit-status exit-data)
(when encode
(setq args
(append args
'("--symmetric"
"--armor"))))
(if program
(with-temp-buffer
(when passphrase
(insert passphrase "\n"))
(insert input)
(setq exit-status
(apply #'call-process-region (point-min) (point-max) program
t `(t ,temp-file) nil args))
(if (equal exit-status 0)
(setq exit-data
(buffer-substring-no-properties (point-min) (point-max)))
(with-temp-buffer
(when (file-exists-p temp-file)
(insert-file-contents temp-file))
(gnus-error 5 (format "%s exited abnormally: '%s' [%s]"
program exit-status (buffer-string)))))
(delete-file temp-file))
(gnus-error 5 "GPG is not installed."))
exit-data))
(provide 'encrypt)
;;; encrypt.el ends here
;; arch-tag: d907e4f1-71b5-42b1-a180-fc7b84ff0648

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

@ -75,17 +75,6 @@ RFC 2646 suggests 66 characters for readability."
(sexp)
(integer)))
(eval-and-compile
(defalias 'fill-flowed-point-at-bol
(if (fboundp 'point-at-bol)
'point-at-bol
'line-beginning-position))
(defalias 'fill-flowed-point-at-eol
(if (fboundp 'point-at-eol)
'point-at-eol
'line-end-position)))
;;;###autoload
(defun fill-flowed-encode (&optional buffer)
(with-current-buffer (or buffer (current-buffer))
@ -109,7 +98,7 @@ RFC 2646 suggests 66 characters for readability."
t)))
;;;###autoload
(defun fill-flowed (&optional buffer)
(defun fill-flowed (&optional buffer delete-space)
(save-excursion
(set-buffer (or (current-buffer) buffer))
(goto-char (point-min))
@ -119,6 +108,8 @@ RFC 2646 suggests 66 characters for readability."
(forward-line 1))
(goto-char (point-min))
(while (re-search-forward " $" nil t)
(when delete-space
(delete-char -1))
(when (save-excursion
(beginning-of-line)
(looking-at "^\\(>*\\)\\( ?\\)"))
@ -153,8 +144,8 @@ RFC 2646 suggests 66 characters for readability."
(fill-column (eval fill-flowed-display-column))
filladapt-mode
adaptive-fill-mode)
(fill-region (fill-flowed-point-at-bol)
(min (1+ (fill-flowed-point-at-eol))
(fill-region (point-at-bol)
(min (1+ (point-at-eol))
(point-max))
'left 'nosqueeze))
(error

2
lisp/gnus/format-spec.el
View File

@ -49,7 +49,7 @@ the text that it generates."
(spec (string-to-char (match-string 2)))
(val (cdr (assq spec specification))))
(unless val
(error "Invalid format character: %s" spec))
(error "Invalid format character: `%%%c'" spec))
;; Pad result to desired length.
(let ((text (format (concat "%" num "s") val)))
;; Insert first, to preserve text properties.

13
lisp/gnus/gmm-utils.el
View File

@ -49,6 +49,19 @@ jabbering all the time."
:type 'integer
:group 'gmm)
;;;###autoload
(defun gmm-regexp-concat (regexp)
"Potentially concat a list of regexps into a single one.
The concatenation is done with logical ORs."
(cond ((null regexp)
nil)
((stringp regexp)
regexp)
((listp regexp)
(mapconcat (lambda (elt) (concat "\\(" elt "\\)"))
regexp
"\\|"))))
;;;###autoload
(defun gmm-message (level &rest args)
"If LEVEL is lower than `gmm-verbose' print ARGS using `message'.

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -33,10 +33,6 @@
(require 'gnus-sum)
(require 'nntp)
(eval-when-compile
(when (featurep 'xemacs)
(require 'timer-funcs)))
(defgroup gnus-asynchronous nil
"Support for asynchronous operations."
:group 'gnus)
@ -274,28 +270,29 @@ It should return non-nil if the article is to be prefetched."
(nntp-server-buffer (current-buffer))
(nntp-have-messaged nil)
(tries 0))
(condition-case nil
;; FIXME: we could stop waiting after some
;; timeout, but this is the wrong place to do it.
;; rather than checking time-spent-waiting, we
;; should check time-since-last-output, which
;; needs to be done in nntp.el.
(while (eq article gnus-async-current-prefetch-article)
(incf tries)
(when (nntp-accept-process-output proc)
(setq tries 0))
(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 (> tries 3)
(setq gnus-async-current-prefetch-article nil))
(signal 'quit nil)))
(when nntp-have-messaged
(gnus-message 5 "")))))
(when proc
(condition-case nil
;; FIXME: we could stop waiting after some
;; timeout, but this is the wrong place to do it.
;; rather than checking time-spent-waiting, we
;; should check time-since-last-output, which
;; needs to be done in nntp.el.
(while (eq article gnus-async-current-prefetch-article)
(incf tries)
(when (nntp-accept-process-output proc)
(setq tries 0))
(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 (> tries 3)
(setq gnus-async-current-prefetch-article nil))
(signal 'quit nil)))
(when nntp-have-messaged
(gnus-message 5 ""))))))
(defun gnus-async-delete-prefetched-entry (entry)
"Delete ENTRY from buffer and alist."
@ -311,13 +308,11 @@ It should return non-nil if the article is to be prefetched."
"Remove all articles belonging to GROUP from the prefetch buffer."
(when (and (gnus-group-asynchronous-p group)
(memq 'exit gnus-prefetched-article-deletion-strategy))
(let ((alist gnus-async-article-alist))
(save-excursion
(gnus-async-set-buffer)
(while alist
(when (equal group (nth 3 (car alist)))
(gnus-async-delete-prefetched-entry (car alist)))
(pop alist))))))
(save-excursion
(gnus-async-set-buffer)
(dolist (entry gnus-async-article-alist)
(when (equal group (nth 3 entry))
(gnus-async-delete-prefetched-entry entry))))))
(defun gnus-async-prefetched-article-entry (group article)
"Return the entry for ARTICLE in GROUP if it has been prefetched."

826
lisp/gnus/gnus-bookmark.el Normal file
View File

@ -0,0 +1,826 @@
;;; gnus-bookmark.el --- Bookmarks in Gnus
;; Copyright (C) 2006 Free Software Foundation, Inc.
;; Author: Bastien Guerry <bzg AT altern DOT 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file implements real bookmarks for Gnus, closely following the way
;; `bookmark.el' handles bookmarks. Most of the code comes from
;; `bookmark.el'.
;;
;; Set a Gnus bookmark:
;; M-x `gnus-bookmark-set' from the summary buffer.
;;
;; Jump to a Gnus bookmark:
;; M-x `gnus-bookmark-jump'.
;;
;; Display a list of bookmarks
;; M-x `gnus-bookmark-bmenu-list'.
;;
;;; Todo:
;; - add tags to bookmarks
;; - don't write file each time a bookmark is created
;; - better annotation interactive buffer
;; - edit annotation in gnus-bookmark-bmenu
;; - sort gnus-bookmark-buffer by author/subject/date/group/message-id
;; - auto-bmk-name customizable format
;; - renaming bookmarks in gnus-bookmark-bmenu-list
;; - better (formatted string) display in bmenu-list
;; - Integrate the `gnus-summary-*-bookmark' functionality
;; - Initialize defcustoms from corresponding `bookmark.el' variables?
;;; Code:
(require 'gnus-sum)
;; FIXME: should avoid using C-c (no?)
;; (define-key gnus-summary-mode-map "\C-crm" 'gnus-bookmark-set)
;; (define-key global-map "\C-crb" 'gnus-bookmark-jump)
;; (define-key global-map "\C-crj" 'gnus-bookmark-jump)
;; (define-key global-map "\C-crl" 'gnus-bookmark-bmenu-list)
(defgroup gnus-bookmark nil
"Setting, annotation and jumping to Gnus bookmarks."
:group 'gnus)
(defcustom gnus-bookmark-default-file
(cond
;; Backward compatibility with previous versions:
((file-exists-p "~/.gnus.bmk") "~/.gnus.bmk")
(t (nnheader-concat gnus-directory "bookmarks.el")))
"The default Gnus bookmarks file."
:type 'string
:group 'gnus-bookmark)
(defcustom gnus-bookmark-file-coding-system
(if (mm-coding-system-p 'iso-2022-7bit)
'iso-2022-7bit)
"Coding system used for writing Gnus bookmark files."
:type '(symbol :tag "Coding system")
:group 'gnus-bookmark)
(defcustom gnus-bookmark-sort-flag t
"Non-nil means Gnus bookmarks are sorted by bookmark names.
Otherwise they will be displayed in LIFO order (that is,
most recently set ones come first, oldest ones come last)."
:type 'boolean
:group 'gnus-bookmark)
(defcustom gnus-bookmark-bmenu-toggle-infos t
"Non-nil means show details when listing Gnus bookmarks.
List of details is defined in `gnus-bookmark-bookmark-inline-details'.
This may result in truncated bookmark names. To disable this, put the
following in your `.emacs' file:
\(setq gnus-bookmark-bmenu-toggle-infos nil\)"
:type 'boolean
:group 'gnus-bookmark)
(defcustom gnus-bookmark-bmenu-file-column 30
"Column at which to display details in a buffer listing Gnus bookmarks.
You can toggle whether details are shown with \\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-toggle-infos]."
:type 'integer
:group 'gnus-bookmark)
(defcustom gnus-bookmark-use-annotations nil
"If non-nil, ask for an annotation when setting a bookmark."
:type 'boolean
:group 'gnus-bookmark)
(defcustom gnus-bookmark-bookmark-inline-details '(author)
"Details to be shown with `gnus-bookmark-bmenu-toggle-infos'.
The default value is \(subject\)."
:type '(list :tag "Gnus bookmark details"
(set :inline t
(const :tag "Author" author)
(const :tag "Subject" subject)
(const :tag "Date" date)
(const :tag "Group" group)
(const :tag "Message-id" message-id)))
:group 'gnus-bookmark)
(defcustom gnus-bookmark-bookmark-details
'(author subject date group annotation)
"Details to be shown with `gnus-bookmark-bmenu-show-details'.
The default value is \(author subject date group annotation\)."
:type '(list :tag "Gnus bookmark details"
(set :inline t
(const :tag "Author" author)
(const :tag "Subject" subject)
(const :tag "Date" date)
(const :tag "Group" group)
(const :tag "Message-id" message-id)
(const :tag "Annotation" annotation)))
:group 'gnus-bookmark)
(defface gnus-bookmark-menu-heading
'((t (:inherit font-lock-type-face)))
"Face used to highlight the heading in Gnus bookmark menu buffers."
:version "23.0" ;; No Gnus
:group 'gnus-bookmark)
(defconst gnus-bookmark-end-of-version-stamp-marker
"-*- End Of Bookmark File Format Version Stamp -*-\n"
"This string marks the end of the version stamp in a Gnus bookmark file.")
(defconst gnus-bookmark-file-format-version 0
"The current version of the format used by bookmark files.
You should never need to change this.")
(defvar gnus-bookmark-after-jump-hook nil
"Hook run after `gnus-bookmark-jump' jumps to a Gnus bookmark.")
(defvar gnus-bookmark-alist ()
"Association list of Gnus bookmarks and their records.
The format of the alist is
\(BMK1 BMK2 ...\)
where each BMK is of the form
\(NAME
\(group . GROUP\)
\(message-id . MESSAGE-ID\)
\(author . AUTHOR\)
\(date . DATE\)
\(subject . SUBJECT\)
\(annotation . ANNOTATION\)\)
So the cdr of each bookmark is an alist too.")
(defmacro gnus-bookmark-mouse-available-p ()
"Return non-nil if a mouse is available."
(if (featurep 'xemacs)
'(and (eq (device-class) 'color) (device-on-window-system-p))
'(and (display-color-p) (display-mouse-p))))
(defun gnus-bookmark-remove-properties (string)
"Remove all text properties from STRING."
(set-text-properties 0 (length string) nil string)
string)
;;;###autoload
(defun gnus-bookmark-set ()
"Set a bookmark for this article."
(interactive)
(gnus-bookmark-maybe-load-default-file)
(if (or (not (eq major-mode 'gnus-summary-mode))
(not gnus-article-current))
(error "Please select an article in the Gnus summary buffer")
(let* ((group (car gnus-article-current))
(article (cdr gnus-article-current))
(header (gnus-summary-article-header article))
(author (mail-header-from header))
(message-id (mail-header-id header))
(date (mail-header-date header))
(subject (gnus-summary-subject-string))
(bmk-name (gnus-bookmark-set-bookmark-name group author subject))
;; Maybe ask for annotation
(annotation
(if gnus-bookmark-use-annotations
(read-from-minibuffer
(format "Annotation for %s: " bmk-name)) "")))
;; Set the bookmark list
(setq gnus-bookmark-alist
(cons
(list (gnus-bookmark-remove-properties bmk-name)
(gnus-bookmark-make-cell
group message-id author date subject annotation))
gnus-bookmark-alist))))
(gnus-bookmark-bmenu-surreptitiously-rebuild-list)
(gnus-bookmark-write-file))
(defun gnus-bookmark-make-cell
(group message-id author date subject annotation)
"Return the record part of a new bookmark, given GROUP MESSAGE-ID AUTHOR DATE SUBJECT and ANNOTATION."
(let ((the-record
`((group . ,(gnus-bookmark-remove-properties group))
(message-id . ,(gnus-bookmark-remove-properties message-id))
(author . ,(gnus-bookmark-remove-properties author))
(date . ,(gnus-bookmark-remove-properties date))
(subject . ,(gnus-bookmark-remove-properties subject))
(annotation . ,(gnus-bookmark-remove-properties annotation)))))
the-record))
(defun gnus-bookmark-set-bookmark-name (group author subject)
"Set bookmark name from GROUP AUTHOR and SUBJECT."
(let* ((subject (split-string subject))
(default-name-0 ;; Should be merged with -1?
(concat (car (nreverse (delete "" (split-string group "[\\.:]"))))
"-" (car (split-string author))
"-" (car subject) "-" (cadr subject)))
(default-name-1
;; Strip "[]" chars from the bookmark name:
(gnus-replace-in-string default-name-0 "[]_[]" ""))
(name (read-from-minibuffer
(format "Set bookmark (%s): " default-name-1)
nil nil nil nil
default-name-1)))
(if (string-equal name "")
default-name-1
name)))
(defun gnus-bookmark-write-file ()
"Write currently defined Gnus bookmarks into `gnus-bookmark-default-file'."
(interactive)
(save-excursion
(save-window-excursion
;; Avoir warnings?
;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file)
(set-buffer (get-buffer-create " *Gnus bookmarks*"))
(erase-buffer)
(gnus-bookmark-insert-file-format-version-stamp)
(pp gnus-bookmark-alist (current-buffer))
(condition-case nil
(let ((coding-system-for-write gnus-bookmark-file-coding-system))
(write-region (point-min) (point-max)
gnus-bookmark-default-file))
(file-error (message "Can't write %s"
gnus-bookmark-default-file)))
(kill-buffer (current-buffer))
(message
"Saving Gnus bookmarks to file %s...done"
gnus-bookmark-default-file))))
(defun gnus-bookmark-insert-file-format-version-stamp ()
"Insert text indicating current version of Gnus bookmark file format."
(insert
(format ";;;; Gnus Bookmark Format Version %d %s;;;;\n"
gnus-bookmark-file-format-version
(if gnus-bookmark-file-coding-system
(concat "-*- coding: "
(symbol-name gnus-bookmark-file-coding-system)
"; -*- ")
"")))
(insert ";;; This format is meant to be slightly human-readable;\n"
";;; nevertheless, you probably don't want to edit it.\n"
";;; "
gnus-bookmark-end-of-version-stamp-marker))
;;;###autoload
(defun gnus-bookmark-jump (&optional bmk-name)
"Jump to a Gnus bookmark (BMK-NAME)."
(interactive)
(gnus-bookmark-maybe-load-default-file)
(let* ((bookmark (or bmk-name
(completing-read "Jump to bookmarked article: "
gnus-bookmark-alist)))
(bmk-cell (cadr (assoc bookmark gnus-bookmark-alist)))
(group (cdr (assoc 'group bmk-cell)))
(message-id (cdr (assoc 'message-id bmk-cell))))
(when group
(unless (get-buffer gnus-group-buffer)
(gnus-no-server))
(gnus-activate-group group)
(gnus-group-quick-select-group 0 group))
(if message-id
(or (gnus-summary-goto-article message-id nil 'force)
(if (fboundp 'gnus-summary-insert-cached-articles)
(progn
(gnus-summary-insert-cached-articles)
(gnus-summary-goto-article message-id nil 'force))
(message "Message could not be found."))))))
(defvar gnus-bookmark-already-loaded nil)
(defun gnus-bookmark-alist-from-buffer ()
"Return a `gnus-bookmark-alist' from the current buffer.
The buffer must of course contain Gnus bookmark format information.
Does not care from where in the buffer it is called, and does not
affect point."
(save-excursion
(goto-char (point-min))
(if (search-forward
gnus-bookmark-end-of-version-stamp-marker nil t)
(read (current-buffer))
;; Else no hope of getting information here.
(error "Not Gnus bookmark format"))))
(defun gnus-bookmark-load (file)
"Load Gnus bookmarks from FILE (which must be in bookmark format)."
(interactive
(list (read-file-name
(format "Load Gnus bookmarks from: (%s) "
gnus-bookmark-default-file)
"~/" gnus-bookmark-default-file 'confirm)))
(setq file (expand-file-name file))
(if (file-readable-p file)
(save-excursion
(save-window-excursion
(set-buffer (let ((enable-local-variables nil))
(find-file-noselect file)))
(goto-char (point-min))
(let ((blist (gnus-bookmark-alist-from-buffer)))
(if (listp blist)
(progn (setq gnus-bookmark-already-loaded t)
(setq gnus-bookmark-alist blist))
(error "Not Gnus bookmark format")))))))
(defun gnus-bookmark-maybe-load-default-file ()
"Maybe load Gnus bookmarks in `gnus-bookmark-alist'."
(and (not gnus-bookmark-already-loaded)
(null gnus-bookmark-alist)
(file-readable-p (expand-file-name gnus-bookmark-default-file))
(gnus-bookmark-load gnus-bookmark-default-file)))
(defun gnus-bookmark-maybe-sort-alist ()
"Return the gnus-bookmark-alist for display.
If the gnus-bookmark-sort-flag is non-nil, then return a sorted
copy of the alist."
(when gnus-bookmark-sort-flag
(setq gnus-bookmark-alist
(sort (copy-alist gnus-bookmark-alist)
(function
(lambda (x y) (string-lessp (car x) (car y))))))))
;;;###autoload
(defun gnus-bookmark-bmenu-list ()
"Display a list of existing Gnus bookmarks.
The list is displayed in a buffer named `*Gnus Bookmark List*'.
The leftmost column displays a D if the bookmark is flagged for
deletion, or > if it is flagged for displaying."
(interactive)
(gnus-bookmark-maybe-load-default-file)
(if (interactive-p)
(switch-to-buffer (get-buffer-create "*Gnus Bookmark List*"))
(set-buffer (get-buffer-create "*Gnus Bookmark List*")))
(let ((inhibit-read-only t)
alist name start end)
(erase-buffer)
(insert "% Gnus Bookmark\n- --------\n")
(add-text-properties (point-min) (point)
'(font-lock-face gnus-bookmark-menu-heading))
;; sort before displaying
(gnus-bookmark-maybe-sort-alist)
;; Display gnus bookmarks
(setq alist gnus-bookmark-alist)
(while alist
(setq name (gnus-bookmark-name-from-full-record (pop alist)))
;; if a Gnus bookmark has an annotation, prepend a "*"
;; in the list of bookmarks.
(insert (if (member (gnus-bookmark-get-annotation name) (list nil ""))
" "
" *"))
(if (gnus-bookmark-mouse-available-p)
(add-text-properties
(prog1
(point)
(insert name))
(let ((end (point)))
(prog2
(re-search-backward "[^ \t]")
(1+ (point))
(goto-char end)
(insert "\n")))
`(mouse-face highlight follow-link t
help-echo ,(format "%s: go to this article"
(aref gnus-mouse-2 0))))
(insert name "\n")))
(goto-char (point-min))
(forward-line 2)
(gnus-bookmark-bmenu-mode)
(if gnus-bookmark-bmenu-toggle-infos
(gnus-bookmark-bmenu-toggle-infos t))))
(defun gnus-bookmark-bmenu-surreptitiously-rebuild-list ()
"Rebuild the Bookmark List if it exists.
Don't affect the buffer ring order."
(if (get-buffer "*Gnus Bookmark List*")
(save-excursion
(save-window-excursion
(gnus-bookmark-bmenu-list)))))
(defun gnus-bookmark-get-annotation (bookmark)
"Return the annotation of Gnus BOOKMARK, or nil if none."
(cdr (assq 'annotation (gnus-bookmark-get-bookmark-record bookmark))))
(defun gnus-bookmark-get-bookmark (bookmark)
"Return the full entry for Gnus BOOKMARK in `gnus-bookmark-alist'.
If BOOKMARK is not a string, return nil."
(when (stringp bookmark)
(assoc bookmark gnus-bookmark-alist)))
(defun gnus-bookmark-get-bookmark-record (bookmark)
"Return the guts of the entry for Gnus BOOKMARK in `gnus-bookmark-alist'.
That is, all information but the name."
(car (cdr (gnus-bookmark-get-bookmark bookmark))))
(defun gnus-bookmark-name-from-full-record (full-record)
"Return name of FULL-RECORD \(an alist element instead of a string\)."
(car full-record))
(defvar gnus-bookmark-bmenu-bookmark-column nil)
(defvar gnus-bookmark-bmenu-hidden-bookmarks ())
(defvar gnus-bookmark-bmenu-mode-map nil)
(if gnus-bookmark-bmenu-mode-map
nil
(setq gnus-bookmark-bmenu-mode-map (make-keymap))
(suppress-keymap gnus-bookmark-bmenu-mode-map t)
(define-key gnus-bookmark-bmenu-mode-map "q" (if (fboundp 'quit-window)
'quit-window
'bury-buffer))
(define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select)
(define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select)
(define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete)
(define-key gnus-bookmark-bmenu-mode-map "k" 'gnus-bookmark-bmenu-delete)
(define-key gnus-bookmark-bmenu-mode-map "\C-d" 'gnus-bookmark-bmenu-delete-backwards)
(define-key gnus-bookmark-bmenu-mode-map "x" 'gnus-bookmark-bmenu-execute-deletions)
(define-key gnus-bookmark-bmenu-mode-map " " 'next-line)
(define-key gnus-bookmark-bmenu-mode-map "n" 'next-line)
(define-key gnus-bookmark-bmenu-mode-map "p" 'previous-line)
(define-key gnus-bookmark-bmenu-mode-map "\177" 'gnus-bookmark-bmenu-backup-unmark)
(define-key gnus-bookmark-bmenu-mode-map "?" 'describe-mode)
(define-key gnus-bookmark-bmenu-mode-map "u" 'gnus-bookmark-bmenu-unmark)
(define-key gnus-bookmark-bmenu-mode-map "m" 'gnus-bookmark-bmenu-mark)
(define-key gnus-bookmark-bmenu-mode-map "l" 'gnus-bookmark-bmenu-load)
(define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save)
(define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos)
(define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details)
(define-key gnus-bookmark-bmenu-mode-map gnus-mouse-2
'gnus-bookmark-bmenu-select-by-mouse))
;; Bookmark Buffer Menu mode is suitable only for specially formatted
;; data.
(put 'gnus-bookmark-bmenu-mode 'mode-class 'special)
;; Been to lazy to use gnus-bookmark-save...
(defalias 'gnus-bookmark-bmenu-save 'gnus-bookmark-write-file)
(defun gnus-bookmark-bmenu-mode ()
"Major mode for editing a list of Gnus bookmarks.
Each line describes one of the bookmarks in Gnus.
Letters do not insert themselves; instead, they are commands.
Gnus bookmarks names preceded by a \"*\" have annotations.
\\<gnus-bookmark-bmenu-mode-map>
\\[gnus-bookmark-bmenu-mark] -- mark bookmark to be displayed.
\\[gnus-bookmark-bmenu-select] -- select bookmark of line point is on.
Also show bookmarks marked using m in other windows.
\\[gnus-bookmark-bmenu-toggle-infos] -- toggle displaying of details (they may obscure long bookmark names).
\\[gnus-bookmark-bmenu-locate] -- display (in minibuffer) location of this bookmark.
\\[gnus-bookmark-bmenu-rename] -- rename this bookmark \(prompts for new name\).
\\[gnus-bookmark-bmenu-delete] -- mark this bookmark to be deleted, and move down.
\\[gnus-bookmark-bmenu-delete-backwards] -- mark this bookmark to be deleted, and move up.
\\[gnus-bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[gnus-bookmark-bmenu-delete]'.
\\[gnus-bookmark-bmenu-load] -- load in a file of bookmarks (prompts for file.)
\\[gnus-bookmark-bmenu-save] -- load in a file of bookmarks (prompts for file.)
\\[gnus-bookmark-bmenu-unmark] -- remove all kinds of marks from current line.
With prefix argument, also move up one line.
\\[gnus-bookmark-bmenu-backup-unmark] -- back up a line and remove marks.
\\[gnus-bookmark-bmenu-show-details] -- show the annotation, if it exists, for the current bookmark
in another buffer.
\\[gnus-bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer.
\\[gnus-bookmark-bmenu-edit-annotation] -- edit the annotation for the current bookmark."
(kill-all-local-variables)
(use-local-map gnus-bookmark-bmenu-mode-map)
(setq truncate-lines t)
(setq buffer-read-only t)
(setq major-mode 'gnus-bookmark-bmenu-mode)
(setq mode-name "Bookmark Menu")
(gnus-run-mode-hooks 'gnus-bookmark-bmenu-mode-hook))
;; avoid compilation warnings
(defvar gnus-bookmark-bmenu-toggle-infos nil)
(defun gnus-bookmark-bmenu-toggle-infos (&optional show)
"Toggle whether details are shown in the Gnus bookmark list.
Optional argument SHOW means show them unconditionally."
(interactive)
(cond
(show
(setq gnus-bookmark-bmenu-toggle-infos nil)
(gnus-bookmark-bmenu-show-infos)
(setq gnus-bookmark-bmenu-toggle-infos t))
(gnus-bookmark-bmenu-toggle-infos
(gnus-bookmark-bmenu-hide-infos)
(setq gnus-bookmark-bmenu-toggle-infos nil))
(t
(gnus-bookmark-bmenu-show-infos)
(setq gnus-bookmark-bmenu-toggle-infos t))))
(defun gnus-bookmark-bmenu-show-infos (&optional force)
"Show infos in bmenu, maybe FORCE display of infos."
(if (and (not force) gnus-bookmark-bmenu-toggle-infos)
nil ;already shown, so do nothing
(save-excursion
(save-window-excursion
(goto-char (point-min))
(forward-line 2)
(setq gnus-bookmark-bmenu-hidden-bookmarks ())
(let ((inhibit-read-only t))
(while (< (point) (point-max))
(let ((bmrk (gnus-bookmark-bmenu-bookmark)))
(setq gnus-bookmark-bmenu-hidden-bookmarks
(cons bmrk gnus-bookmark-bmenu-hidden-bookmarks))
(let ((start (save-excursion (end-of-line) (point))))
(move-to-column gnus-bookmark-bmenu-file-column t)
;; Strip off `mouse-face' from the white spaces region.
(if (gnus-bookmark-mouse-available-p)
(remove-text-properties start (point)
'(mouse-face nil help-echo nil))))
(delete-region (point) (progn (end-of-line) (point)))
(insert " ")
;; Pass the NO-HISTORY arg:
(gnus-bookmark-insert-details bmrk)
(forward-line 1))))))))
(defun gnus-bookmark-insert-details (bmk-name)
"Insert the details of the article associated with BMK-NAME."
(let ((start (point)))
(prog1
(insert (gnus-bookmark-get-details
bmk-name
gnus-bookmark-bookmark-inline-details))
(if (gnus-bookmark-mouse-available-p)
(add-text-properties
start
(save-excursion (re-search-backward
"[^ \t]")
(1+ (point)))
`(mouse-face highlight
follow-link t
help-echo ,(format "%s: go to this article"
(aref gnus-mouse-2 0))))))))
(defun gnus-bookmark-kill-line (&optional newline-too)
"Kill from point to end of line.
If optional arg NEWLINE-TOO is non-nil, delete the newline too.
Does not affect the kill ring."
(let ((eol (save-excursion (end-of-line) (point))))
(delete-region (point) eol)
(if (and newline-too (looking-at "\n"))
(delete-char 1))))
(defun gnus-bookmark-get-details (bmk-name details-list)
"Get details for a Gnus BMK-NAME depending on DETAILS-LIST."
(let ((details (cadr (assoc bmk-name gnus-bookmark-alist))))
(mapconcat
(lambda (info)
(cdr (assoc info details)))
details-list " | ")))
(defun gnus-bookmark-bmenu-hide-infos (&optional force)
"Hide infos in bmenu, maybe FORCE."
(if (and (not force) gnus-bookmark-bmenu-toggle-infos)
;; nothing to hide if above is nil
(save-excursion
(save-window-excursion
(goto-char (point-min))
(forward-line 2)
(setq gnus-bookmark-bmenu-hidden-bookmarks
(nreverse gnus-bookmark-bmenu-hidden-bookmarks))
(save-excursion
(goto-char (point-min))
(search-forward "Gnus Bookmark")
(backward-word 2)
(setq gnus-bookmark-bmenu-bookmark-column (current-column)))
(save-excursion
(let ((inhibit-read-only t))
(while gnus-bookmark-bmenu-hidden-bookmarks
(move-to-column gnus-bookmark-bmenu-bookmark-column t)
(gnus-bookmark-kill-line)
(let ((start (point)))
(insert (car gnus-bookmark-bmenu-hidden-bookmarks))
(if (gnus-bookmark-mouse-available-p)
(add-text-properties
start
(save-excursion (re-search-backward
"[^ \t]")
(1+ (point)))
`(mouse-face highlight
follow-link t
help-echo
,(format "%s: go to this bookmark in other window"
(aref gnus-mouse-2 0))))))
(setq gnus-bookmark-bmenu-hidden-bookmarks
(cdr gnus-bookmark-bmenu-hidden-bookmarks))
(forward-line 1))))))))
(defun gnus-bookmark-bmenu-check-position ()
"Return non-nil if on a line with a bookmark.
The actual value returned is gnus-bookmark-alist. Else
reposition and try again, else return nil."
(cond ((< (count-lines (point-min) (point)) 2)
(goto-char (point-min))
(forward-line 2)
gnus-bookmark-alist)
((and (bolp) (eobp))
(beginning-of-line 0)
gnus-bookmark-alist)
(t
gnus-bookmark-alist)))
(defun gnus-bookmark-bmenu-bookmark ()
"Return a string which is bookmark of this line."
(if (gnus-bookmark-bmenu-check-position)
(save-excursion
(save-window-excursion
(goto-char (point-min))
(search-forward "Gnus Bookmark")
(backward-word 2)
(setq gnus-bookmark-bmenu-bookmark-column (current-column)))))
(if gnus-bookmark-bmenu-toggle-infos
(gnus-bookmark-bmenu-hide-infos))
(save-excursion
(save-window-excursion
(beginning-of-line)
(forward-char gnus-bookmark-bmenu-bookmark-column)
(prog1
(buffer-substring-no-properties (point)
(progn
(end-of-line)
(point)))
;; well, this is certainly crystal-clear:
(if gnus-bookmark-bmenu-toggle-infos
(gnus-bookmark-bmenu-toggle-infos t))))))
(defun gnus-bookmark-show-details (bookmark)
"Display the annotation for BOOKMARK in a buffer."
(let ((record (gnus-bookmark-get-bookmark-record bookmark))
(old-buf (current-buffer))
(details gnus-bookmark-bookmark-details)
detail)
(save-excursion
(pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t)
(erase-buffer)
(while details
(setq detail (pop details))
(unless (equal (cdr (assoc detail record)) "")
(insert (symbol-name detail) ": " (cdr (assoc detail record)) "\n")))
(goto-char (point-min))
(pop-to-buffer old-buf))))
(defun gnus-bookmark-bmenu-show-details ()
"Show the annotation for the current bookmark in another window."
(interactive)
(let ((bookmark (gnus-bookmark-bmenu-bookmark)))
(if (gnus-bookmark-bmenu-check-position)
(gnus-bookmark-show-details bookmark))))
(defun gnus-bookmark-bmenu-mark ()
"Mark bookmark on this line to be displayed by \\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-select]."
(interactive)
(beginning-of-line)
(if (gnus-bookmark-bmenu-check-position)
(let ((inhibit-read-only t))
(delete-char 1)
(insert ?>)
(forward-line 1)
(gnus-bookmark-bmenu-check-position))))
(defun gnus-bookmark-bmenu-unmark (&optional backup)
"Cancel all requested operations on bookmark on this line and move down.
Optional BACKUP means move up."
(interactive "P")
(beginning-of-line)
(if (gnus-bookmark-bmenu-check-position)
(progn
(let ((inhibit-read-only t))
(delete-char 1)
;; any flags to reset according to circumstances? How about a
;; flag indicating whether this bookmark is being visited?
;; well, we don't have this now, so maybe later.
(insert " "))
(forward-line (if backup -1 1))
(gnus-bookmark-bmenu-check-position))))
(defun gnus-bookmark-bmenu-backup-unmark ()
"Move up and cancel all requested operations on bookmark on line above."
(interactive)
(forward-line -1)
(if (gnus-bookmark-bmenu-check-position)
(progn
(gnus-bookmark-bmenu-unmark)
(forward-line -1)
(gnus-bookmark-bmenu-check-position))))
(defun gnus-bookmark-bmenu-delete ()
"Mark Gnus bookmark on this line to be deleted.
To carry out the deletions that you've marked, use
\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-execute-deletions]."
(interactive)
(beginning-of-line)
(if (gnus-bookmark-bmenu-check-position)
(let ((inhibit-read-only t))
(delete-char 1)
(insert ?D)
(forward-line 1)
(gnus-bookmark-bmenu-check-position))))
(defun gnus-bookmark-bmenu-delete-backwards ()
"Mark bookmark on this line to be deleted, then move up one line.
To carry out the deletions that you've marked, use
\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-execute-deletions]."
(interactive)
(gnus-bookmark-bmenu-delete)
(forward-line -2)
(if (gnus-bookmark-bmenu-check-position)
(forward-line 1))
(gnus-bookmark-bmenu-check-position))
(defun gnus-bookmark-bmenu-select ()
"Select this line's bookmark; also display bookmarks marked with `>'.
You can mark bookmarks with the
\\<gnus-bookmark-bmenu-mode-map>\\[gnus-bookmark-bmenu-mark]
command."
(interactive)
(if (gnus-bookmark-bmenu-check-position)
(let ((bmrk (gnus-bookmark-bmenu-bookmark))
(menu (current-buffer)))
(goto-char (point-min))
(delete-other-windows)
(gnus-bookmark-jump bmrk)
(bury-buffer menu))))
(defun gnus-bookmark-bmenu-select-by-mouse (event)
(interactive "e")
(mouse-set-point event)
(gnus-bookmark-bmenu-select))
(defun gnus-bookmark-bmenu-load ()
"Load the Gnus bookmark file and rebuild the bookmark menu-buffer."
(interactive)
(if (gnus-bookmark-bmenu-check-position)
(save-excursion
(save-window-excursion
;; This will call `gnus-bookmark-bmenu-list'
(call-interactively 'gnus-bookmark-load)))))
(defun gnus-bookmark-bmenu-execute-deletions ()
"Delete Gnus bookmarks marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] commands."
(interactive)
(message "Deleting Gnus bookmarks...")
(let ((hide-em gnus-bookmark-bmenu-toggle-infos)
(o-point (point))
(o-str (save-excursion
(beginning-of-line)
(if (looking-at "^D")
nil
(buffer-substring
(point)
(progn (end-of-line) (point))))))
(o-col (current-column)))
(if hide-em (gnus-bookmark-bmenu-hide-infos))
(setq gnus-bookmark-bmenu-toggle-infos nil)
(goto-char (point-min))
(forward-line 1)
(while (re-search-forward "^D" (point-max) t)
(gnus-bookmark-delete (gnus-bookmark-bmenu-bookmark) t)) ; pass BATCH arg
(gnus-bookmark-bmenu-list)
(setq gnus-bookmark-bmenu-toggle-infos hide-em)
(if gnus-bookmark-bmenu-toggle-infos
(gnus-bookmark-bmenu-toggle-infos t))
(if o-str
(progn
(goto-char (point-min))
(search-forward o-str)
(beginning-of-line)
(forward-char o-col))
(goto-char o-point))
(beginning-of-line)
(gnus-bookmark-write-file)
(message "Deleting bookmarks...done")))
(defun gnus-bookmark-delete (bookmark &optional batch)
"Delete BOOKMARK from the bookmark list.
Removes only the first instance of a bookmark with that name. If
there are one or more other bookmarks with the same name, they will
not be deleted. Defaults to the \"current\" bookmark \(that is, the
one most recently used in this file, if any\).
Optional second arg BATCH means don't update the bookmark list buffer,
probably because we were called from there."
(gnus-bookmark-maybe-load-default-file)
(let ((will-go (gnus-bookmark-get-bookmark bookmark)))
(setq gnus-bookmark-alist (delq will-go gnus-bookmark-alist)))
;; Don't rebuild the list
(if batch
nil
(gnus-bookmark-bmenu-surreptitiously-rebuild-list)))
(provide 'gnus-bookmark)
;; arch-tag: 779df694-366f-46e8-84b2-1d0340e6f525
;;; gnus-bookmark.el ends here

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

@ -30,11 +30,8 @@
(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-int)
(require 'gnus-range)
(require 'gnus-start)
(eval-when-compile
(if (not (fboundp 'gnus-agent-load-alist))
(unless (fboundp 'gnus-agent-load-alist)
(defun gnus-agent-load-alist (group)))
(require 'gnus-sum))
@ -92,6 +89,7 @@ it's not cached."
(defvar gnus-cache-buffer nil)
(defvar gnus-cache-active-hashtb nil)
(defvar gnus-cache-active-altered nil)
(defvar gnus-cache-total-fetched-hashtb nil)
(eval-and-compile
(autoload 'nnml-generate-nov-databases-1 "nnml")
@ -133,16 +131,20 @@ it's not cached."
(let ((coding-system-for-write
gnus-cache-overview-coding-system))
(gnus-write-buffer overview-file))
;; Empty overview file, remove it
(when (file-exists-p overview-file)
(delete-file overview-file))
;; If possible, remove group's cache subdirectory.
(condition-case nil
;; FIXME: we can detect the error type and warn the user
;; of any inconsistencies (articles w/o nov entries?).
;; for now, just be conservative...delete only if safe -- sj
(delete-directory (file-name-directory overview-file))
(error nil)))))
(let ((file-name-coding-system nnmail-pathname-coding-system))
;; Empty overview file, remove it
(when (file-exists-p overview-file)
(delete-file overview-file))
;; If possible, remove group's cache subdirectory.
(condition-case nil
;; FIXME: we can detect the error type and warn the user
;; of any inconsistencies (articles w/o nov entries?).
;; for now, just be conservative...delete only if safe -- sj
(delete-directory (file-name-directory overview-file))
(error))))
(gnus-cache-update-overview-total-fetched-for
(car gnus-cache-buffer) overview-file)))
;; Kill the buffer -- it's either unmodified or saved.
(gnus-kill-buffer buffer)
(setq gnus-cache-buffer nil))))
@ -152,7 +154,9 @@ it's not cached."
(when (and (or force (not (eq gnus-use-cache 'passive)))
(numberp article)
(> article 0)) ; This might be a dummy article.
(let ((number article) file headers)
(let ((number article)
file headers lines-chars
(file-name-coding-system nnmail-pathname-coding-system))
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
@ -180,10 +184,14 @@ it's not cached."
(gnus-request-article-this-buffer number group))
(when (> (buffer-size) 0)
(let ((coding-system-for-write gnus-cache-coding-system))
(gnus-write-buffer file))
(gnus-write-buffer file)
(gnus-cache-update-file-total-fetched-for group file))
(setq lines-chars (nnheader-get-lines-and-char))
(nnheader-remove-body)
(setq headers (nnheader-parse-naked-head))
(mail-header-set-number headers number)
(mail-header-set-lines headers (car lines-chars))
(mail-header-set-chars headers (cadr lines-chars))
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-max))
@ -236,12 +244,10 @@ it's not cached."
(defun gnus-cache-possibly-remove-articles-1 ()
"Possibly remove some of the removable articles."
(when (gnus-cache-fully-p gnus-newsgroup-name)
(let ((articles gnus-cache-removable-articles)
(cache-articles gnus-newsgroup-cached)
article)
(let ((cache-articles gnus-newsgroup-cached))
(gnus-cache-change-buffer gnus-newsgroup-name)
(while articles
(when (memq (setq article (pop articles)) cache-articles)
(dolist (article gnus-cache-removable-articles)
(when (memq article cache-articles)
;; The article was in the cache, so we see whether we are
;; supposed to remove it from the cache.
(gnus-cache-possibly-remove-article
@ -256,7 +262,8 @@ it's not cached."
(defun gnus-cache-request-article (article group)
"Retrieve ARTICLE in GROUP from the cache."
(let ((file (gnus-cache-file-name group article))
(buffer-read-only nil))
(buffer-read-only nil)
(file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p file)
(erase-buffer)
(gnus-kill-all-overlays)
@ -285,7 +292,8 @@ it's not cached."
(gnus-retrieve-headers articles group fetch-old))
(let ((uncached-articles (gnus-sorted-difference articles cached))
(cache-file (gnus-cache-file-name group ".overview"))
type)
type
(file-name-coding-system nnmail-pathname-coding-system))
;; We first retrieve all the headers that we don't have in
;; the cache.
(let ((gnus-use-cache nil))
@ -325,9 +333,8 @@ it's not cached."
If not given a prefix, use the process marked articles instead.
Returns the list of articles entered."
(interactive "P")
(let ((articles (gnus-summary-work-articles n))
article out)
(while (setq article (pop articles))
(let (out)
(dolist (article (gnus-summary-work-articles n))
(gnus-summary-remove-process-mark article)
(if (natnump article)
(when (gnus-cache-possibly-enter-article
@ -348,10 +355,8 @@ If not given a prefix, use the process marked articles instead.
Returns the list of articles removed."
(interactive "P")
(gnus-cache-change-buffer gnus-newsgroup-name)
(let ((articles (gnus-summary-work-articles n))
article out)
(while articles
(setq article (pop articles))
(let (out)
(dolist (article (gnus-summary-work-articles n))
(gnus-summary-remove-process-mark article)
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(when gnus-newsgroup-agentized
@ -407,7 +412,8 @@ Returns the list of articles removed."
" *gnus-cache-overview*"))))
;; Insert the contents of this group's cache overview.
(erase-buffer)
(let ((file (gnus-cache-file-name group ".overview")))
(let ((file (gnus-cache-file-name group ".overview"))
(file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p file)
(nnheader-insert-file-contents file)))
;; We have a fresh (empty/just loaded) buffer,
@ -421,8 +427,43 @@ Returns the list of articles removed."
(and unread (memq 'unread class))
(and (not unread) (not ticked) (not dormant) (memq 'read class))))
(defvar gnus-cache-decoded-group-names nil
"Alist of original group names and decoded group names.
Decoding is done according to `gnus-group-name-charset-method-alist'
or `gnus-group-name-charset-group-alist'.")
(defvar gnus-cache-unified-group-names nil
"Alist of unified decoded group names and original group names.
A group name is decoded according to
`gnus-group-name-charset-method-alist' or
`gnus-group-name-charset-group-alist' first, and is encoded and
decoded again according to `nnmail-pathname-coding-system',
`file-name-coding-system', or `default-file-name-coding-system'.
It is used when asking for a original group name from a cache
directory name, in which non-ASCII characters might have been unified
into the ones of a certain charset particularly if the `utf-8' coding
system for example was used.")
(defun gnus-cache-decoded-group-name (group)
"Return a decoded group name of GROUP."
(or (cdr (assoc group gnus-cache-decoded-group-names))
(let ((decoded (gnus-group-decoded-name group))
(coding (or nnmail-pathname-coding-system
(and (boundp 'file-name-coding-system)
file-name-coding-system)
(and (boundp 'default-file-name-coding-system)
default-file-name-coding-system))))
(push (cons group decoded) gnus-cache-decoded-group-names)
(push (cons (mm-decode-coding-string
(mm-encode-coding-string decoded coding)
coding)
group)
gnus-cache-unified-group-names)
decoded)))
(defun gnus-cache-file-name (group article)
(setq group (gnus-group-decoded-name group))
(setq group (gnus-cache-decoded-group-name group))
(expand-file-name
(if (stringp article) article (int-to-string article))
(file-name-as-directory
@ -455,7 +496,8 @@ Returns the list of articles removed."
"Possibly remove ARTICLE from the cache."
(let ((group gnus-newsgroup-name)
(number article)
file)
file
(file-name-coding-system nnmail-pathname-coding-system))
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
@ -468,13 +510,15 @@ Returns the list of articles removed."
(gnus-cache-member-of-class
gnus-cache-remove-articles ticked dormant unread)))
(save-excursion
(gnus-cache-update-file-total-fetched-for group file t)
(delete-file file)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-min))
(when (or (looking-at (concat (int-to-string number) "\t"))
(search-forward (concat "\n" (int-to-string number) "\t")
(point-max) t))
(gnus-delete-line)))
(gnus-delete-line)))
(unless (setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached))
(gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb)
@ -485,7 +529,8 @@ Returns the list of articles removed."
(defun gnus-cache-articles-in-group (group)
"Return a sorted list of cached articles in GROUP."
(let ((dir (file-name-directory (gnus-cache-file-name group 1)))
articles)
articles
(file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p dir)
(setq articles
(sort (mapcar (lambda (name) (string-to-number name))
@ -508,8 +553,8 @@ Returns the list of articles removed."
(save-excursion
(set-buffer cache-buf)
(erase-buffer)
(let ((coding-system-for-read
gnus-cache-overview-coding-system))
(let ((coding-system-for-read gnus-cache-overview-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
(insert-file-contents
(or file (gnus-cache-file-name group ".overview"))))
(goto-char (point-min))
@ -525,7 +570,7 @@ Returns the list of articles removed."
(set-buffer cache-buf)
(if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
nil t)
(setq beg (gnus-point-at-bol)
(setq beg (point-at-bol)
end (progn (end-of-line) (point)))
(setq beg nil))
(set-buffer nntp-server-buffer)
@ -537,24 +582,23 @@ Returns the list of articles removed."
(defun gnus-cache-braid-heads (group cached)
(let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")))
(save-excursion
(set-buffer cache-buf)
(with-current-buffer cache-buf
(erase-buffer))
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(while cached
(dolist (entry cached)
(while (and (not (eobp))
(looking-at "2.. +\\([0-9]+\\) ")
(< (progn (goto-char (match-beginning 1))
(read (current-buffer)))
(car cached)))
entry))
(search-forward "\n.\n" nil 'move))
(beginning-of-line)
(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))))
(let ((coding-system-for-read gnus-cache-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
(insert-file-contents (gnus-cache-file-name group entry)))
(goto-char (point-min))
(insert "220 ")
(princ (car cached) (current-buffer))
@ -564,8 +608,7 @@ Returns the list of articles removed."
(forward-char -1)
(insert ".")
(set-buffer nntp-server-buffer)
(insert-buffer-substring cache-buf)
(setq cached (cdr cached)))
(insert-buffer-substring cache-buf))
(kill-buffer cache-buf)))
;;;###autoload
@ -661,6 +704,7 @@ If LOW, update the lower bound instead."
(interactive)
(let* ((top (null directory))
(directory (expand-file-name (or directory gnus-cache-directory)))
(file-name-coding-system nnmail-pathname-coding-system)
(files (directory-files directory 'full))
(group
(if top
@ -686,16 +730,21 @@ If LOW, update the lower bound instead."
(push (pop files) alphs)))
;; If we have nums, then this is probably a valid group.
(when (setq nums (sort nums '<))
(gnus-sethash group (cons (car nums) (gnus-last-element nums))
;; Use non-decoded group name.
;; FIXME: this is kind of a workaround. The active file should
;; be updated at the time articles are cached. It will make
;; `gnus-cache-unified-group-names' needless.
(gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names))
group)
(cons (car nums) (gnus-last-element nums))
gnus-cache-active-hashtb))
;; Go through all the other files.
(while alphs
(when (and (file-directory-p (car alphs))
(dolist (file alphs)
(when (and (file-directory-p file)
(not (string-match "^\\."
(file-name-nondirectory (car alphs)))))
(file-name-nondirectory file))))
;; We descend directories.
(gnus-cache-generate-active (car alphs)))
(setq alphs (cdr alphs)))
(gnus-cache-generate-active file)))
;; Write the new active file.
(when top
(gnus-cache-write-active t)
@ -708,6 +757,9 @@ If LOW, update the lower bound instead."
(gnus-cache-close)
(let ((nnml-generate-active-function 'identity))
(nnml-generate-nov-databases-1 dir))
(setq gnus-cache-total-fetched-hashtb nil)
(gnus-cache-open))
(defun gnus-cache-move-cache (dir)
@ -736,9 +788,12 @@ files would corrupt Gnus when the cache was next enabled. It
depends on the caller to determine whether group renaming is
supported."
(let ((old-dir (gnus-cache-file-name old-group ""))
(new-dir (gnus-cache-file-name new-group "")))
(new-dir (gnus-cache-file-name new-group ""))
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-rename-file old-dir new-dir t))
(gnus-cache-rename-group-total-fetched-for old-group new-group)
(let ((no-save gnus-cache-active-hashtb))
(unless gnus-cache-active-hashtb
(gnus-cache-read-active))
@ -762,9 +817,12 @@ Always updates the cache, even when disabled, as the old cache
files would corrupt gnus when the cache was next enabled.
Depends upon the caller to determine whether group deletion is
supported."
(let ((dir (gnus-cache-file-name group "")))
(let ((dir (gnus-cache-file-name group ""))
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-delete-directory dir))
(gnus-cache-delete-group-total-fetched-for group)
(let ((no-save gnus-cache-active-hashtb))
(unless gnus-cache-active-hashtb
(gnus-cache-read-active))
@ -775,6 +833,85 @@ supported."
(setq gnus-cache-active-altered group-hash-value)
(gnus-cache-write-active group-hash-value)))))
(defvar gnus-cache-inhibit-update-total-fetched-for nil)
(defvar gnus-cache-need-update-total-fetched-for nil)
(defmacro gnus-cache-with-refreshed-group (group &rest body)
`(prog1 (let ((gnus-cache-inhibit-update-total-fetched-for t))
,@body)
(when (and gnus-cache-need-update-total-fetched-for
(not gnus-cache-inhibit-update-total-fetched-for))
(save-excursion
(set-buffer gnus-group-buffer)
(setq gnus-cache-need-update-total-fetched-for nil)
(gnus-group-update-group ,group t)))))
(defun gnus-cache-update-file-total-fetched-for (group file &optional subtract)
(when gnus-cache-total-fetched-hashtb
(gnus-cache-with-refreshed-group
group
(let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
(gnus-sethash group (make-vector 2 0)
gnus-cache-total-fetched-hashtb)))
size)
(if file
(setq size (or (nth 7 (file-attributes file)) 0))
(let* ((file-name-coding-system nnmail-pathname-coding-system)
(files (directory-files (gnus-cache-file-name group "")
t nil t))
file attrs)
(setq size 0.0)
(while (setq file (pop files))
(setq attrs (file-attributes file))
(unless (nth 0 attrs)
(incf size (float (nth 7 attrs)))))))
(setq gnus-cache-need-update-total-fetched-for t)
(incf (nth 1 entry) (if subtract (- size) size))))))
(defun gnus-cache-update-overview-total-fetched-for (group file)
(when gnus-cache-total-fetched-hashtb
(gnus-cache-with-refreshed-group
group
(let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
(gnus-sethash group (make-list 2 0)
gnus-cache-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system)
(size (or (nth 7 (file-attributes
(or file
(gnus-cache-file-name group ".overview"))))
0)))
(setq gnus-cache-need-update-total-fetched-for t)
(setf (nth 0 entry) size)))))
(defun gnus-cache-rename-group-total-fetched-for (old-group new-group)
"Record of disk space used by OLD-GROUP now associated with NEW-GROUP."
(when gnus-cache-total-fetched-hashtb
(let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb)))
(gnus-sethash new-group entry gnus-cache-total-fetched-hashtb)
(gnus-sethash old-group nil gnus-cache-total-fetched-hashtb))))
(defun gnus-cache-delete-group-total-fetched-for (group)
"Delete record of disk space used by GROUP being deleted."
(when gnus-cache-total-fetched-hashtb
(gnus-sethash group nil gnus-cache-total-fetched-hashtb)))
(defun gnus-cache-total-fetched-for (group &optional no-inhibit)
"Get total disk space used by the cache for the specified GROUP."
(unless (equal group "dummy.group")
(unless gnus-cache-total-fetched-hashtb
(setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024)))
(let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb)))
(if entry
(apply '+ entry)
(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
(+
(gnus-cache-update-overview-total-fetched-for group nil)
(gnus-cache-update-file-total-fetched-for group nil)))))))
(provide 'gnus-cache)
;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a

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

@ -27,6 +27,9 @@
;;; Code:
(eval-when-compile (require 'cl))
(eval-when-compile
(when (featurep 'xemacs)
(require 'easy-mmode))) ; for `define-minor-mode'
(require 'gnus)
(require 'gnus-range)
@ -268,7 +271,7 @@ It is merged with the face for the cited text belonging to the attribution."
(defface gnus-cite-10 '((((class color)
(background dark))
(:foreground "medium purple"))
(:foreground "plum1"))
(((class color)
(background light))
(:foreground "medium purple"))
@ -294,14 +297,28 @@ It is merged with the face for the cited text belonging to the attribution."
(defcustom gnus-cite-face-list
'(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6
gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11)
gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11)
"*List of faces used for highlighting citations.
When there are citations from multiple articles in the same message,
Gnus will try to give each citation from each article its own face.
This should make it easier to see who wrote what."
:group 'gnus-cite
:type '(repeat face))
:type '(repeat face)
:set (lambda (symbol value)
(prog1
(custom-set-default symbol value)
(if (boundp 'gnus-message-max-citation-depth)
(setq gnus-message-max-citation-depth (length value)))
(if (boundp 'gnus-message-citation-keywords)
(setq gnus-message-citation-keywords
`((gnus-message-search-citation-line
,@(let ((list nil)
(count 1))
(dolist (face value (nreverse list))
(push (list count (list 'quote face) 'prepend t)
list)
(setq count (1+ count)))))))))))
(defcustom gnus-cite-hide-percentage 50
"Only hide excess citation if above this percentage of the body."
@ -367,7 +384,7 @@ in a boring face, then the pages will be skipped."
;;; Commands:
(defun gnus-article-highlight-citation (&optional force)
(defun gnus-article-highlight-citation (&optional force same-buffer)
"Highlight cited text.
Each citation in the article will be highlighted with a different face.
The faces are taken from `gnus-cite-face-list'.
@ -381,7 +398,8 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
(save-excursion
(set-buffer gnus-article-buffer)
(unless same-buffer
(set-buffer gnus-article-buffer))
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
(alist gnus-cite-prefix-alist)
@ -416,7 +434,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
(gnus-point-at-eol)
(point-at-eol)
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
'gnus-cite-toggle prefix))
@ -770,7 +788,7 @@ See also the documentation for `gnus-article-highlight-citation'."
;; Each line.
(setq begin (point)
guess-limit (progn (skip-chars-forward "^> \t\r\n") (point))
end (gnus-point-at-bol 2)
end (point-at-bol 2)
start end)
(goto-char begin)
;; Ignore standard Supercite attribution prefix.
@ -793,7 +811,7 @@ See also the documentation for `gnus-article-highlight-citation'."
;; Each prefix.
(setq end (match-end 0)
prefix (buffer-substring begin end))
(gnus-set-text-properties 0 (length prefix) nil prefix)
(set-text-properties 0 (length prefix) nil prefix)
(setq entry (assoc prefix alist))
(if entry
(setcdr entry (cons line (cdr entry)))
@ -803,13 +821,24 @@ See also the documentation for `gnus-article-highlight-citation'."
(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)))
(setq start t begin nil entry nil)
(while start
;; Assume this search ends up at the beginning of a line.
(if (re-search-forward gnus-cite-unsightly-citation-regexp max t)
(progn
(when (number-or-marker-p start)
(setq begin (count-lines (point-min) start)
end (count-lines (point-min) (match-beginning 0))))
(setq start (match-end 0)))
(when (number-or-marker-p start)
(setq begin (count-lines (point-min) start)
end (count-lines (point-min) max)))
(setq start nil))
(when begin
(while (< begin end)
;; Need to do 1+ because we're in the bol.
(push (setq begin (1+ begin)) entry))))
(when entry
(push (cons "" entry) alist))
;; We got all the potential prefixes. Now create
;; `gnus-cite-prefix-alist' containing the oldest prefix for each
@ -875,11 +904,10 @@ See also the documentation for `gnus-article-highlight-citation'."
(let ((al (buffer-substring (save-excursion (beginning-of-line 0)
(1+ (point)))
end)))
(if (not (assoc al al-alist))
(progn
(push (list wrote in prefix tag)
gnus-cite-loose-attribution-alist)
(push (cons al t) al-alist))))))))
(when (not (assoc al al-alist))
(push (list wrote in prefix tag)
gnus-cite-loose-attribution-alist)
(push (cons al t) al-alist)))))))
(defun gnus-cite-connect-attributions ()
;; Connect attributions to citations
@ -1101,6 +1129,108 @@ See also the documentation for `gnus-article-highlight-citation'."
(setq found t)))
found)))
;; Highlighting of different citation levels in message-mode.
;; - message-cite-prefix will be overridden if this is enabled.
(defvar gnus-message-max-citation-depth
(length gnus-cite-face-list)
"Maximum supported level of citation.")
(defvar gnus-message-cite-prefix-regexp
(concat "^\\(?:" message-cite-prefix-regexp "\\)"))
(defun gnus-message-search-citation-line (limit)
"Search for a cited line and set match data accordingly.
Returns nil if there is no such line before LIMIT, t otherwise."
(when (re-search-forward gnus-message-cite-prefix-regexp limit t)
(let ((cdepth (min (length (apply 'concat
(split-string
(match-string-no-properties 0)
"[ \t [:alnum:]]+")))
gnus-message-max-citation-depth))
(mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil))
(start (point-at-bol))
(end (point-at-eol)))
(setcar mlist start)
(setcar (cdr mlist) end)
(setcar (nthcdr (* cdepth 2) mlist) start)
(setcar (nthcdr (1+ (* cdepth 2)) mlist) end)
(set-match-data mlist))
t))
(defvar gnus-message-citation-keywords
;; eval-when-compile ;; This breaks in XEmacs
`((gnus-message-search-citation-line
,@(let ((list nil)
(count 1))
;; (require 'gnus-cite)
(dolist (face gnus-cite-face-list (nreverse list))
(push (list count (list 'quote face) 'prepend t) list)
(setq count (1+ count)))))) ;;
"Keywords for highlighting different levels of message citations.")
(eval-when-compile
(defvar font-lock-defaults-computed)
(defvar font-lock-keywords)
(defvar font-lock-set-defaults))
(eval-and-compile
(unless (featurep 'xemacs)
(autoload 'font-lock-set-defaults "font-lock")))
(define-minor-mode gnus-message-citation-mode
"Toggle `gnus-message-citation-mode' in current buffer.
This buffer local minor mode provides additional font-lock support for
nested citations.
With prefix ARG, turn `gnus-message-citation-mode' on if and only if ARG
is positive.
Automatically turn `font-lock-mode' on when `gnus-message-citation-mode'
is turned on."
nil ;; init-value
"" ;; lighter
nil ;; keymap
(when (eq major-mode 'message-mode)
(let ((defaults (car (if (featurep 'xemacs)
(get 'message-mode 'font-lock-defaults)
font-lock-defaults)))
default keywords)
(while defaults
(setq default (if (consp defaults)
(pop defaults)
(prog1
defaults
(setq defaults nil))))
(if gnus-message-citation-mode
;; `gnus-message-citation-keywords' should be the last
;; elements of the keywords because the others are unlikely
;; to have the OVERRIDE flags -- XEmacs applies a keyword
;; having no OVERRIDE flag to matched text even if it has
;; already other faces, while Emacs doesn't.
(set (make-local-variable default)
(append (default-value default)
gnus-message-citation-keywords))
(kill-local-variable default))))
;; Force `font-lock-set-defaults' to update `font-lock-keywords'.
(if (featurep 'xemacs)
(progn
(require 'font-lock)
(setq font-lock-defaults-computed nil
font-lock-keywords nil))
(setq font-lock-set-defaults nil))
(font-lock-set-defaults)
(cond ((symbol-value 'font-lock-mode)
(font-lock-fontify-buffer))
(gnus-message-citation-mode
(font-lock-mode 1)))))
(defun turn-on-gnus-message-citation-mode ()
"Turn on `gnus-message-citation-mode'."
(gnus-message-citation-mode 1))
(defun turn-off-gnus-message-citation-mode ()
"Turn off `gnus-message-citation-mode'."
(gnus-message-citation-mode -1))
(gnus-ems-redefine)
(provide 'gnus-cite)

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

@ -980,7 +980,7 @@ articles in the thread.
(deflt (if (,field defaults)
(concat " [" (gnus-trim-whitespace
(gnus-pp-to-string (,field defaults)))
"]")))
"]")))
symb)
(if (eq (car type) 'radio)

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

@ -152,7 +152,7 @@ DELAY is a string, giving the length of the time. Possible values are:
(message-send-hook (copy-sequence message-send-hook))
articles
article deadline)
(when (gnus-gethash group gnus-newsrc-hashtb)
(when (gnus-group-entry group)
(gnus-activate-group group)
(add-hook 'message-send-hook
'(lambda ()

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

@ -35,10 +35,6 @@
(require 'nntp)
(require 'nnmail)
(require 'gnus-util)
(eval-and-compile
(if (featurep 'xemacs)
(require 'itimer)
(require 'timer)))
(autoload 'parse-time-string "parse-time" nil nil)
@ -109,7 +105,7 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(when gnus-demon-handlers
;; Set up the timer.
(setq gnus-demon-timer
(nnheader-run-at-time
(run-at-time
gnus-demon-timestep gnus-demon-timestep 'gnus-demon))
;; Reset control variables.
(setq gnus-demon-handler-state

54
lisp/gnus/gnus-diary.el
View File

@ -251,32 +251,32 @@ Optional prefix (or REVERSE argument) means sort in reverse order."
;; - 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)))))
))
;; Posting style:
(let ((posting-style (gnus-group-get-parameter group 'posting-style t))
(headers nndiary-headers)
header)
(while headers
(setq header (format "X-Diary-%s" (caar headers))
headers (cdr headers))
(unless (assoc header posting-style)
(setq posting-style (append posting-style (list (list header "*"))))))
(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 back end function.
@ -347,7 +347,7 @@ If ARG (or prefix) is non-nil, force prompting for all fields."
(when (re-search-forward (concat "^" header ":") nil t)
(unless (eq (char-after) ? )
(insert " "))
(setq value (buffer-substring (point) (gnus-point-at-eol)))
(setq value (buffer-substring (point) (point-at-eol)))
(and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value)
(setq value (match-string 1 value)))
(condition-case ()

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

@ -72,7 +72,7 @@
(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)
(add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map)
(gnus-run-hooks 'gnus-dired-mode-hook))))
;;;###autoload

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

@ -75,7 +75,7 @@
;; Set up the menu.
(when (gnus-visual-p 'draft-menu 'menu)
(gnus-draft-make-menu-bar))
(gnus-add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map)
(add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map)
(gnus-run-hooks 'gnus-draft-mode-hook))))
;;; Commands
@ -105,7 +105,9 @@
(save-restriction
(message-narrow-to-headers)
(message-remove-header "date")))
(save-buffer)
(let ((message-draft-headers
(delq 'Date (copy-sequence message-draft-headers))))
(save-buffer))
(let ((gnus-verbose-backends nil))
(gnus-request-expire-articles (list article) group t))
(push
@ -160,7 +162,7 @@
(concat "^" (regexp-quote gnus-agent-target-move-group-header)
":") nil t)
(skip-syntax-forward "-")
(setq move-to (buffer-substring (point) (gnus-point-at-eol)))
(setq move-to (buffer-substring (point) (point-at-eol)))
(message-remove-header gnus-agent-target-move-group-header))
(goto-char (point-min))
(when (re-search-forward
@ -238,6 +240,12 @@
(throw 'continue t)
(error "Stop!"))))))))
(defcustom gnus-draft-setup-hook nil
"Hook run after setting up a draft buffer."
:group 'gnus-message
:version "23.0" ;; No Gnus
:type 'hook)
;;; Utility functions
;;;!!!If this is byte-compiled, it fails miserably.
@ -285,7 +293,8 @@
(gnus-add-mark ,(car ga) 'replied ,article)
(gnus-request-set-mark ,(car ga) (list (list (list ,article)
'add '(reply)))))
'send)))))))
'send))))
(run-hooks 'gnus-draft-setup-hook))))
(defun gnus-draft-article-sendable-p (article)
"Say whether ARTICLE is sendable."

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

@ -85,10 +85,8 @@ seen in the same session."
(setq gnus-dup-list nil))
(setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
;; Enter all Message-IDs into the hash table.
(let ((list gnus-dup-list)
(obarray gnus-dup-hashtb))
(while list
(intern (pop list)))))
(let ((obarray gnus-dup-hashtb))
(mapc 'intern gnus-dup-list)))
(defun gnus-dup-read ()
"Read the duplicate suppression list."
@ -113,11 +111,10 @@ seen in the same session."
(unless gnus-dup-list
(gnus-dup-open))
(setq gnus-dup-list-dirty t) ; mark list for saving
(let ((data gnus-newsgroup-data)
datum msgid)
(let (msgid)
;; Enter the Message-IDs of all read articles into the list
;; and hash table.
(while (setq datum (pop data))
(dolist (datum gnus-newsgroup-data)
(when (and (not (gnus-data-pseudo-p datum))
(> (gnus-data-number datum) 0)
(not (memq (gnus-data-number datum) gnus-newsgroup-unreads))
@ -130,6 +127,7 @@ seen in the same session."
;; Chop off excess Message-IDs from the list.
(let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
(when end
(mapc (lambda (id) (unintern id gnus-dup-hashtb)) (cdr end))
(setcdr end nil))))
(defun gnus-dup-suppress-articles ()
@ -137,11 +135,10 @@ seen in the same session."
(unless gnus-dup-list
(gnus-dup-open))
(gnus-message 6 "Suppressing duplicates...")
(let ((headers gnus-newsgroup-headers)
(auto (and gnus-newsgroup-auto-expire
(let ((auto (and gnus-newsgroup-auto-expire
(memq gnus-duplicate-mark gnus-auto-expirable-marks)))
number header)
(while (setq header (pop headers))
number)
(dolist (header gnus-newsgroup-headers)
(when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
(gnus-summary-article-unread-p (mail-header-number header)))
(setq gnus-newsgroup-unreads
@ -155,7 +152,8 @@ seen in the same session."
(defun gnus-dup-unsuppress-article (article)
"Stop suppression of ARTICLE."
(let ((id (mail-header-id (gnus-data-header (gnus-data-find article)))))
(let* ((header (gnus-data-header (gnus-data-find article)))
(id (when header (mail-header-id header))))
(when id
(setq gnus-dup-list-dirty t)
(setq gnus-dup-list (delete id gnus-dup-list))

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

@ -86,13 +86,14 @@ It is a slightly enhanced emacs-lisp-mode.
(make-local-variable 'gnus-prev-winconf)
(gnus-run-mode-hooks 'gnus-edit-form-mode-hook))
(defun gnus-edit-form (form documentation exit-func)
(defun gnus-edit-form (form documentation exit-func &optional layout)
"Edit FORM in a new buffer.
Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning
of the buffer."
of the buffer.
The optional LAYOUT overrides the `edit-form' window layout."
(let ((winconf (current-window-configuration)))
(set-buffer (gnus-get-buffer-create gnus-edit-form-buffer))
(gnus-configure-windows 'edit-form)
(gnus-configure-windows (or layout 'edit-form))
(gnus-edit-form-mode)
(setq gnus-prev-winconf winconf)
(setq gnus-edit-form-done-function exit-func)

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

@ -38,21 +38,17 @@
(defvar gnus-down-mouse-2 [down-mouse-2])
(defvar gnus-widget-button-keymap nil)
(defvar gnus-mode-line-modified
(if (or (featurep 'xemacs)
(< emacs-major-version 20))
(if (featurep 'xemacs)
'("--**-" . "-----")
'("**" "--")))
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
(autoload 'appt-select-lowest-window "appt")
(autoload 'gnus-get-buffer-create "gnus")
(autoload 'nnheader-find-etc-directory "nnheader"))
(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."
@ -72,12 +68,6 @@
(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)
@ -149,6 +139,18 @@
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject-or-nil "\n")))))
;; Clone of `appt-select-lowest-window' in appt.el.
(defun gnus-select-lowest-window ()
"Select the lowest window on the frame."
(let ((lowest-window (selected-window))
(bottom-edge (nth 3 (window-edges))))
(walk-windows (lambda (w)
(let ((next-bottom-edge (nth 3 (window-edges w))))
(when (< bottom-edge next-bottom-edge)
(setq bottom-edge next-bottom-edge
lowest-window w)))))
(select-window lowest-window)))
(defun gnus-region-active-p ()
"Say whether the region is active."
(and (boundp 'transient-mark-mode)
@ -160,16 +162,6 @@
"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)
(set (make-local-variable mode) t)
(unless (assq mode minor-mode-alist)
(push `(,mode ,name) minor-mode-alist))
(unless (assq mode minor-mode-map-alist)
(push (cons mode map)
minor-mode-map-alist))))
(defun gnus-x-splash ()
"Show a splash screen using a pixmap in the current buffer."
(interactive)
@ -289,13 +281,26 @@
glyph))
(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)
"Remove the image matching IMAGE and CATEGORY found first."
(let ((start (point-min))
val end)
(while (and (not end)
(or (setq val (get-text-property start 'display))
(and (setq start
(next-single-property-change start 'display))
(setq val (get-text-property start 'display)))))
(setq end (or (next-single-property-change start 'display)
(point-max)))
(if (and (equal val image)
(equal (get-text-property start '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))))))
(progn
(put-text-property start end 'display nil)
(when (get-text-property start 'gnus-image-text-deletable)
(delete-region start end)))
(unless (= end (point-max))
(setq start end
end nil))))))
(provide 'gnus-ems)

54
lisp/gnus/gnus-fun.el
View File

@ -46,21 +46,37 @@
: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"
(defcustom gnus-convert-image-to-x-face-command
"convert -scale 48x48! %s xbm:- | xbm2xface.pl"
"Command for converting an image to an X-Face.
The command must take a image filename (use \"%s\") as input.
The output must be the Face header data on stdout in PNG format.
By default it takes a GIF filename and output the X-Face header data
on stdout."
:version "22.1"
:group 'gnus-fun
:type 'string)
:type '(choice (const :tag "giftopnm, netpbm (GIF input only)"
"giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface")
(const :tag "convert"
"convert -scale 48x48! %s xbm:- | xbm2xface.pl")
(string)))
(defcustom gnus-convert-image-to-face-command "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng"
(defcustom gnus-convert-image-to-face-command
"convert -scale 48x48! %s -colors %d png:-"
"Command for converting an image to a Face.
By default it takes a JPEG filename and output the Face header data
on stdout."
The command must take an image filename (first format argument
\"%s\") and the number of colors (second format argument: \"%d\")
as input. The output must be the Face header data on stdout in
PNG format."
:version "22.1"
:group 'gnus-fun
:type 'string)
:type '(choice (const :tag "djpeg, netpbm (JPG input only)"
"djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng")
(const :tag "convert"
"convert -scale 48x48! %s -colors %d png:-")
(string)))
(defun gnus-shell-command-to-string (command)
"Like `shell-command-to-string' except not mingling ERROR."
@ -102,8 +118,11 @@ Output to the current buffer, replace text, and don't mingle error."
;;;###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): ")
"Insert an X-Face header based on an image file.
Depending on `gnus-convert-image-to-x-face-command' it may accept
different input formats."
(interactive "fImage file name: ")
(when (file-exists-p file)
(gnus-shell-command-to-string
(format gnus-convert-image-to-x-face-command
@ -111,8 +130,11 @@ Output to the current buffer, replace text, and don't mingle error."
;;;###autoload
(defun gnus-face-from-file (file)
"Return a Face header based on an image file."
(interactive "fImage file name (by default JPEG): ")
"Return a Face header based on an image file.
Depending on `gnus-convert-image-to-face-command' it may accept
different input formats."
(interactive "fImage file name: ")
(when (file-exists-p file)
(let ((done nil)
(attempt "")
@ -127,7 +149,7 @@ Output to the current buffer, replace text, and don't mingle error."
quant))))
(if (> (length attempt) 726)
(progn
(setq quant (- quant 2))
(setq quant (- quant (if (< quant 10) 1 2)))
(gnus-message 9 "Length %d; trying quant %d"
(length attempt) quant))
(setq done t)))
@ -197,11 +219,11 @@ colors of the displayed X-Faces."
'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))
(apply 'gnus-create-image (concat "X-Face: " data) 'xface t
(cdr (assq 'xface gnus-face-properties-alist)))
(apply 'gnus-create-image pbm 'pbm t
(cdr (assq 'pbm gnus-face-properties-alist))))
nil 'xface))
(gnus-add-wash-type 'xface))))))
(defun gnus-grab-cam-x-face ()

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

@ -1,860 +0,0 @@
;;; gnus-gl.el --- an interface to GroupLens for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Brad Miller <bmiller@cs.umn.edu>
;; Keywords: news, score
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GroupLens software and documentation is copyright (c) 1995 by Paul
;; Resnick (Massachusetts Institute of Technology); Brad Miller, John
;; Riedl, Jon Herlocker, and Joseph Konstan (University of Minnesota),
;; and David Maltz (Carnegie-Mellon University).
;;
;; Permission to use, copy, modify, and distribute this documentation
;; for non-commercial and commercial purposes without fee is hereby
;; granted provided that this copyright notice and permission notice
;; appears in all copies and that the names of the individuals and
;; institutions holding this copyright are not used in advertising or
;; publicity pertaining to this software without specific, written
;; prior permission. The copyright holders make no representations
;; about the suitability of this software and documentation for any
;; purpose. It is provided ``as is'' without express or implied
;; warranty.
;;
;; The copyright holders request that they be notified of
;; modifications of this code. Please send electronic mail to
;; grouplens@cs.umn.edu for more information or to announce derived
;; works.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Author: Brad Miller
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; User Documentation:
;; To use GroupLens you must load this file.
;; You must also register a pseudonym with the Better Bit Bureau.
;; http://www.cs.umn.edu/Research/GroupLens
;;
;; ---------------- For your .emacs or .gnus file ----------------
;;
;; As of version 2.5, grouplens now works as a minor mode of
;; gnus-summary-mode. To get make that work you just need a couple of
;; hooks.
;; (setq gnus-use-grouplens t)
;; (setq grouplens-pseudonym "")
;; (setq grouplens-bbb-host "grouplens.cs.umn.edu")
;;
;; (setq gnus-summary-default-score 0)
;;
;; USING GROUPLENS
;; How do I Rate an article??
;; Before you type n to go to the next article, hit a number from 1-5
;; Type r in the summary buffer and you will be prompted.
;; Note that when you're in grouplens-minor-mode 'r' masks the
;; usual reply binding for 'r'
;;
;; What if, Gasp, I find a bug???
;; Please type M-x gnus-gl-submit-bug-report. This will set up a
;; mail buffer with the state of variables and buffers that will help
;; me debug the problem. A short description up front would help too!
;;
;; How do I display the prediction for an article:
;; If you set the gnus-summary-line-format as shown above, the score
;; (prediction) will be shown automatically.
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Programmer Notes
;; 10/9/95
;; gnus-scores-articles contains the articles
;; When scoring is done, the call tree looks something like:
;; gnus-possibly-score-headers
;; ==> gnus-score-headers
;; ==> gnus-score-load-file
;; ==> get-all-mids (from the eval form)
;;
;; it would be nice to have one that gets called after all the other
;; headers have been scored.
;; we may want a variable gnus-grouplens-scale-factor
;; and gnus-grouplens-offset this would probably be either -3 or 0
;; to make the scores centered around zero or not.
;; Notes 10/12/95
;; According to Lars, Norse god of gnus, the simple way to insert a
;; call to an external function is to have a function added to the
;; variable gnus-score-find-files-function This new function
;; gnus-grouplens-score-alist will return a core alist that
;; has (("message-id" ("<message-id-xxxx>" score) ("<message-id-xxxy>" score))
;; This seems like it would be pretty inefficient, though workable.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 3. Add some more ways to rate messages
;; 4. Better error handling for token timeouts.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bugs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:
(eval-when-compile (require 'cl))
(require 'gnus-score)
(require 'gnus)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; User variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar gnus-summary-grouplens-line-format
"%U\%R\%z%l%I\%(%[%4L: %-23,23n%]%) %s\n"
"*The line format spec in summary GroupLens mode buffers.")
(defvar grouplens-pseudonym ""
"User's pseudonym.
This pseudonym is obtained during the registration process")
(defvar grouplens-bbb-host "grouplens.cs.umn.edu"
"Host where the bbbd is running.")
(defvar grouplens-bbb-port 9000
"Port where the bbbd is listening.")
(defvar grouplens-newsgroups
'("comp.groupware" "comp.human-factors" "comp.lang.c++"
"comp.lang.java" "comp.os.linux.admin" "comp.os.linux.advocacy"
"comp.os.linux.announce" "comp.os.linux.answers"
"comp.os.linux.development" "comp.os.linux.development.apps"
"comp.os.linux.development.system" "comp.os.linux.hardware"
"comp.os.linux.help" "comp.os.linux.m68k" "comp.os.linux.misc"
"comp.os.linux.networking" "comp.os.linux.setup" "comp.os.linux.x"
"mn.general" "rec.arts.movies" "rec.arts.movies.current-films"
"rec.food.recipes" "rec.humor")
"*Groups that are part of the GroupLens experiment.")
(defvar grouplens-prediction-display 'prediction-spot
"valid values are:
prediction-spot -- an * corresponding to the prediction between 1 and 5,
confidence-interval -- a numeric confidence interval
prediction-bar -- |##### | the longer the bar, the better the article,
confidence-bar -- | ----- } the prediction is in the middle of the bar,
confidence-spot -- ) * | the spot gets bigger with more confidence,
prediction-num -- plain-old numeric value,
confidence-plus-minus -- prediction +/i confidence")
(defvar grouplens-score-offset 0
"Offset the prediction by this value.
Setting this variable to -2 would have the following effect on
GroupLens scores:
1 --> -2
2 --> -1
3 --> 0
4 --> 1
5 --> 2
The reason is that a user might want to do this is to combine
GroupLens predictions with scores calculated by other score methods.")
(defvar grouplens-score-scale-factor 1
"This variable allows the user to magnify the effect of GroupLens scores.
The scale factor is applied after the offset.")
(defvar gnus-grouplens-override-scoring 'override
"Tell GroupLens to override the normal Gnus scoring mechanism.
GroupLens scores can be combined with gnus scores in one of three ways.
'override -- just use grouplens predictions for grouplens groups
'combine -- combine grouplens scores with gnus scores
'separate -- treat grouplens scores completely separate from gnus")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Program global variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar grouplens-bbb-token nil
"Current session token number.")
(defvar grouplens-bbb-process nil
"Process Id of current bbbd network stream process.")
(defvar grouplens-bbb-buffer nil
"Buffer associated with the BBBD process.")
(defvar grouplens-rating-alist nil
"Current set of message-id rating pairs.")
(defvar grouplens-current-hashtable nil
"A hashtable to hold predictions from the BBB.")
(defvar grouplens-current-group nil)
;;(defvar bbb-alist nil)
(defvar bbb-timeout-secs 10
"Number of seconds to wait for some response from the BBB.
If this times out we give up and assume that something has died..." )
(defvar grouplens-previous-article nil
"Message-ID of the last article read.")
(defvar bbb-read-point)
(defvar bbb-response-point)
(defun bbb-renew-hash-table ()
(setq grouplens-current-hashtable (make-vector 100 0)))
(bbb-renew-hash-table)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Utility Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-connect-to-bbbd (host port)
(unless grouplens-bbb-buffer
(setq grouplens-bbb-buffer
(gnus-get-buffer-create (format " *BBBD trace: %s*" host)))
(save-excursion
(set-buffer grouplens-bbb-buffer)
(make-local-variable 'bbb-read-point)
(make-local-variable 'bbb-response-point)
(setq bbb-read-point (point-min))))
;; if an old process is still running for some reason, kill it
(when grouplens-bbb-process
(ignore-errors
(when (eq 'open (process-status grouplens-bbb-process))
(set-process-buffer grouplens-bbb-process nil)
(delete-process grouplens-bbb-process))))
;; clear the trace buffer of old output
(save-excursion
(set-buffer grouplens-bbb-buffer)
(erase-buffer))
;; open the connection to the server
(catch 'done
(condition-case error
(setq grouplens-bbb-process
(open-network-stream "BBBD" grouplens-bbb-buffer host port))
(error (gnus-message 3 "Error: Failed to connect to BBB")
nil))
(and (null grouplens-bbb-process)
(throw 'done nil))
(save-excursion
(set-buffer grouplens-bbb-buffer)
(setq bbb-read-point (point-min))
(or (bbb-read-response grouplens-bbb-process)
(throw 'done nil))))
;; return the process
grouplens-bbb-process)
(defun bbb-send-command (process command)
(goto-char (point-max))
(insert command)
(insert "\r\n")
(setq bbb-read-point (point))
(setq bbb-response-point (point))
(set-marker (process-mark process) (point)) ; process output also comes here
(process-send-string process command)
(process-send-string process "\r\n")
(process-send-eof process))
(defun bbb-read-response (process)
"This function eats the initial response of OK or ERROR from the BBB."
(let ((case-fold-search nil)
match-end)
(goto-char bbb-read-point)
(while (and (not (search-forward "\r\n" nil t))
(accept-process-output process bbb-timeout-secs))
(goto-char bbb-read-point))
(setq match-end (point))
(goto-char bbb-read-point)
(setq bbb-read-point match-end)
(looking-at "OK")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Login Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-login ()
"return the token number if login is successful, otherwise return nil."
(interactive)
(setq grouplens-bbb-token nil)
(if (not (equal grouplens-pseudonym ""))
(let ((bbb-process
(bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
(if bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(bbb-send-command bbb-process
(concat "login " grouplens-pseudonym))
(if (bbb-read-response bbb-process)
(setq grouplens-bbb-token (bbb-extract-token-number))
(gnus-message 3 "Error: GroupLens login failed")))))
(gnus-message 3 "Error: you must set a pseudonym"))
grouplens-bbb-token)
(defun bbb-extract-token-number ()
(let ((token-pos (search-forward "token=" nil t)))
(when (looking-at "[0-9]+")
(buffer-substring token-pos (match-end 0)))))
(gnus-add-shutdown 'bbb-logout 'gnus)
(defun bbb-logout ()
"logout of bbb session."
(when grouplens-bbb-token
(let ((bbb-process
(bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
(when bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(bbb-send-command bbb-process (concat "logout " grouplens-bbb-token))
(bbb-read-response bbb-process))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Get Predictions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-build-mid-scores-alist (groupname)
"this function can be called as part of the function to return the list of score files to use.
See the gnus variable `gnus-score-find-score-files-function'.
*Note:* If you want to use grouplens scores along with calculated scores,
you should see the offset and scale variables. At this point, I don't
recommend using both scores and grouplens predictions together."
(setq grouplens-current-group groupname)
(when (member groupname grouplens-newsgroups)
(setq grouplens-previous-article nil)
;; scores-alist should be a list of lists:
;; ((("message-id" ("<mid1>" score1 nil s) ("<mid2> score2 nil s))))
;;`((("message-id" . ,predict-list))) ; Yes, this is the return value
(list
(list
(list (append (list "message-id")
(bbb-get-predictions (bbb-get-all-mids) groupname)))))))
(defun bbb-get-predictions (midlist groupname)
"Ask the bbb for predictions, and build up the score alist."
(gnus-message 5 "Fetching Predictions...")
(if grouplens-bbb-token
(let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host
grouplens-bbb-port)))
(when bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(bbb-send-command bbb-process
(bbb-build-predict-command midlist groupname
grouplens-bbb-token))
(if (bbb-read-response bbb-process)
(bbb-get-prediction-response bbb-process)
(gnus-message 1 "Invalid Token, login and try again")
(ding)))))
(gnus-message 3 "Error: You are not logged in to a BBB")
(ding)))
(defun bbb-get-all-mids ()
(mapcar (function (lambda (x) (mail-header-id x))) gnus-newsgroup-headers))
(defun bbb-build-predict-command (mlist grpname token)
(concat "getpredictions " token " " grpname "\r\n"
(mapconcat 'identity mlist "\r\n") "\r\n.\r\n"))
(defun bbb-get-prediction-response (process)
(let ((case-fold-search nil))
(goto-char bbb-read-point)
(while (and (not (search-forward ".\r\n" nil t))
(accept-process-output process bbb-timeout-secs))
(goto-char bbb-read-point))
(goto-char (+ bbb-response-point 4));; we ought to be right before OK
(bbb-build-response-alist)))
;; build-response-alist assumes that the cursor has been positioned at
;; the first line of the list of mid/rating pairs.
(defun bbb-build-response-alist ()
(let (resp mid pred)
(while
(cond
((looking-at "\\(<.*>\\) :nopred=")
;;(push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp)
(forward-line 1)
t)
((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)")
(setq mid (bbb-get-mid)
pred (bbb-get-pred))
(push `(,mid ,pred nil s) resp)
(gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh))
grouplens-current-hashtable)
(forward-line 1)
t)
((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)")
(setq mid (bbb-get-mid)
pred (bbb-get-pred))
(push `(,mid ,pred nil s) resp)
(gnus-sethash mid (list pred 0 0) grouplens-current-hashtable)
(forward-line 1)
t)
(t nil)))
resp))
;; these "get" functions assume that there is an active match lying
;; around. Where the first parenthesized expression is the
;; message-id, and the second is the prediction, the third and fourth
;; are the confidence interval
;;
;; Since gnus assumes that scores are integer values?? we round the
;; prediction.
(defun bbb-get-mid ()
(buffer-substring (match-beginning 1) (match-end 1)))
(defun bbb-get-pred ()
(let ((tpred (string-to-number (buffer-substring (match-beginning 2)
(match-end 2)))))
(if (> tpred 0)
(round (* grouplens-score-scale-factor
(+ grouplens-score-offset tpred)))
1)))
(defun bbb-get-confl ()
(string-to-number (buffer-substring (match-beginning 4) (match-end 4))))
(defun bbb-get-confh ()
(string-to-number (buffer-substring (match-beginning 4) (match-end 4))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Prediction Display
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst grplens-rating-range 4.0)
(defconst grplens-maxrating 5)
(defconst grplens-minrating 1)
(defconst grplens-predstringsize 12)
(defvar gnus-tmp-score)
(defun bbb-grouplens-score (header)
(if (eq gnus-grouplens-override-scoring 'separate)
(bbb-grouplens-other-score header)
(let* ((rate-string (make-string 12 ?\ ))
(mid (mail-header-id header))
(hashent (gnus-gethash mid grouplens-current-hashtable))
(iscore gnus-tmp-score)
(low (car (cdr hashent)))
(high (car (cdr (cdr hashent)))))
(aset rate-string 0 ?|)
(aset rate-string 11 ?|)
(unless (member grouplens-current-group grouplens-newsgroups)
(unless (equal grouplens-prediction-display 'prediction-num)
(cond ((< iscore 0)
(setq iscore 1))
((> iscore 5)
(setq iscore 5))))
(setq low 0)
(setq high 0))
(if (and (bbb-valid-score iscore)
(not (null mid)))
(cond
;; prediction-spot
((equal grouplens-prediction-display 'prediction-spot)
(setq rate-string (bbb-fmt-prediction-spot rate-string iscore)))
;; confidence-interval
((equal grouplens-prediction-display 'confidence-interval)
(setq rate-string (bbb-fmt-confidence-interval iscore low high)))
;; prediction-bar
((equal grouplens-prediction-display 'prediction-bar)
(setq rate-string (bbb-fmt-prediction-bar rate-string iscore)))
;; confidence-bar
((equal grouplens-prediction-display 'confidence-bar)
(setq rate-string (format "| %4.2f |" iscore)))
;; confidence-spot
((equal grouplens-prediction-display 'confidence-spot)
(setq rate-string (format "| %4.2f |" iscore)))
;; prediction-num
((equal grouplens-prediction-display 'prediction-num)
(setq rate-string (bbb-fmt-prediction-num iscore)))
;; confidence-plus-minus
((equal grouplens-prediction-display 'confidence-plus-minus)
(setq rate-string (bbb-fmt-confidence-plus-minus iscore low high))
)
(t (gnus-message 3 "Invalid prediction display type")))
(aset rate-string 5 ?N) (aset rate-string 6 ?A))
rate-string)))
;; Gnus user format function that doesn't depend on
;; bbb-build-mid-scores-alist being used as the score function, but is
;; instead called from gnus-select-group-hook. -- LAB
(defun bbb-grouplens-other-score (header)
(if (not (member grouplens-current-group grouplens-newsgroups))
;; Return an empty string
""
(let* ((rate-string (make-string 12 ?\ ))
(mid (mail-header-id header))
(hashent (gnus-gethash mid grouplens-current-hashtable))
(pred (or (nth 0 hashent) 0))
(low (nth 1 hashent))
(high (nth 2 hashent)))
;; Init rate-string
(aset rate-string 0 ?|)
(aset rate-string 11 ?|)
(unless (equal grouplens-prediction-display 'prediction-num)
(cond ((< pred 0)
(setq pred 1))
((> pred 5)
(setq pred 5))))
;; If no entry in BBB hash mark rate string as NA and return
(cond
((null hashent)
(aset rate-string 5 ?N)
(aset rate-string 6 ?A)
rate-string)
((equal grouplens-prediction-display 'prediction-spot)
(bbb-fmt-prediction-spot rate-string pred))
((equal grouplens-prediction-display 'confidence-interval)
(bbb-fmt-confidence-interval pred low high))
((equal grouplens-prediction-display 'prediction-bar)
(bbb-fmt-prediction-bar rate-string pred))
((equal grouplens-prediction-display 'confidence-bar)
(format "| %4.2f |" pred))
((equal grouplens-prediction-display 'confidence-spot)
(format "| %4.2f |" pred))
((equal grouplens-prediction-display 'prediction-num)
(bbb-fmt-prediction-num pred))
((equal grouplens-prediction-display 'confidence-plus-minus)
(bbb-fmt-confidence-plus-minus pred low high))
(t
(gnus-message 3 "Invalid prediction display type")
(aset rate-string 0 ?|)
(aset rate-string 11 ?|)
rate-string)))))
(defun bbb-valid-score (score)
(or (equal grouplens-prediction-display 'prediction-num)
(and (>= score grplens-minrating)
(<= score grplens-maxrating))))
(defun bbb-requires-confidence (format-type)
(or (equal format-type 'confidence-plus-minus)
(equal format-type 'confidence-spot)
(equal format-type 'confidence-interval)))
(defun bbb-have-confidence (clow chigh)
(not (or (null clow)
(null chigh))))
(defun bbb-fmt-prediction-spot (rate-string score)
(aset rate-string
(round (* (/ (- score grplens-minrating) grplens-rating-range)
(+ (- grplens-predstringsize 4) 1.49)))
?*)
rate-string)
(defun bbb-fmt-confidence-interval (score low high)
(if (bbb-have-confidence low high)
(format "|%4.2f-%4.2f |" low high)
(bbb-fmt-prediction-num score)))
(defun bbb-fmt-confidence-plus-minus (score low high)
(if (bbb-have-confidence low high)
(format "|%3.1f+/-%4.2f|" score (/ (- high low) 2.0))
(bbb-fmt-prediction-num score)))
(defun bbb-fmt-prediction-bar (rate-string score)
(let* ((i 1)
(step (/ grplens-rating-range (- grplens-predstringsize 4)))
(half-step (/ step 2))
(loc (- grplens-minrating half-step)))
(while (< i (- grplens-predstringsize 2))
(if (> score loc)
(aset rate-string i ?#)
(aset rate-string i ?\ ))
(setq i (+ i 1))
(setq loc (+ loc step)))
)
rate-string)
(defun bbb-fmt-prediction-num (score)
(format "| %4.2f |" score))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Put Ratings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-put-ratings ()
(if (and grouplens-bbb-token
grouplens-rating-alist
(member gnus-newsgroup-name grouplens-newsgroups))
(let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host
grouplens-bbb-port))
(rate-command (bbb-build-rate-command grouplens-rating-alist)))
(if bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(gnus-message 5 "Sending Ratings...")
(bbb-send-command bbb-process rate-command)
(if (bbb-read-response bbb-process)
(setq grouplens-rating-alist nil)
(gnus-message 1
"Token timed out: call bbb-login and quit again")
(ding))
(gnus-message 5 "Sending Ratings...Done"))
(gnus-message 3 "No BBB connection")))
(setq grouplens-rating-alist nil)))
(defun bbb-build-rate-command (rate-alist)
(concat "putratings " grouplens-bbb-token " " grouplens-current-group " \r\n"
(mapconcat (lambda (this) ; form (mid . (score . time))
(concat (car this)
" :rating=" (cadr this) ".00"
" :time=" (cddr this)))
rate-alist "\r\n")
"\r\n.\r\n"))
;; Interactive rating functions.
(defun bbb-summary-rate-article (rating &optional midin)
(interactive "nRating: ")
(when (member gnus-newsgroup-name grouplens-newsgroups)
(let ((mid (or midin (bbb-get-current-id))))
(if (and rating
(>= rating grplens-minrating)
(<= rating grplens-maxrating)
mid)
(let ((oldrating (assoc mid grouplens-rating-alist)))
(if oldrating
(setcdr oldrating (cons rating 0))
(push `(,mid . (,rating . 0)) grouplens-rating-alist))
(gnus-summary-mark-article nil (int-to-string rating)))
(gnus-message 3 "Invalid rating")))))
(defun grouplens-next-unread-article (rating)
"Select unread article after current one."
(interactive "P")
(when rating
(bbb-summary-rate-article rating))
(gnus-summary-next-unread-article))
(defun grouplens-best-unread-article (rating)
"Select unread article after current one."
(interactive "P")
(when rating
(bbb-summary-rate-article rating))
(gnus-summary-best-unread-article))
(defun grouplens-summary-catchup-and-exit (rating)
"Mark all articles not marked as unread in this newsgroup as read, then exit.
If prefix argument ALL is non-nil, all articles are marked as read."
(interactive "P")
(when rating
(bbb-summary-rate-article rating))
(if (numberp rating)
(gnus-summary-catchup-and-exit)
(gnus-summary-catchup-and-exit rating)))
(defun grouplens-score-thread (score)
"Raise the score of the articles in the current thread with SCORE."
(interactive "nRating: ")
(let (e)
(save-excursion
(let ((articles (gnus-summary-articles-in-thread))
article)
(while (setq article (pop articles))
(gnus-summary-goto-subject article)
(bbb-summary-rate-article score
(mail-header-id
(gnus-summary-article-header article)))))
(setq e (point)))
(let ((gnus-summary-check-current t))
(or (zerop (gnus-summary-next-subject 1 t))
(goto-char e))))
(gnus-summary-recenter)
(gnus-summary-position-point)
(gnus-set-mode-line 'summary))
(defun bbb-exit-group ()
(bbb-put-ratings)
(bbb-renew-hash-table))
(defun bbb-get-current-id ()
(if gnus-current-headers
(mail-header-id gnus-current-headers)
(gnus-message 3 "You must select an article before you rate it")))
(defun bbb-grouplens-group-p (group)
"Say whether GROUP is a GroupLens group."
(if (member group grouplens-newsgroups) " (GroupLens Enhanced)" ""))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TIME SPENT READING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar grouplens-current-starting-time nil)
(defun grouplens-start-timer ()
(setq grouplens-current-starting-time (current-time)))
(defun grouplens-elapsed-time ()
(let ((et (bbb-time-float (current-time))))
(- et (bbb-time-float grouplens-current-starting-time))))
(defun bbb-time-float (timeval)
(+ (* (car timeval) 65536)
(cadr timeval)))
(defun grouplens-do-time ()
(when (member gnus-newsgroup-name grouplens-newsgroups)
(when grouplens-previous-article
(let ((elapsed-time (grouplens-elapsed-time))
(oldrating (assoc grouplens-previous-article
grouplens-rating-alist)))
(if (not oldrating)
(push `(,grouplens-previous-article . (0 . ,elapsed-time))
grouplens-rating-alist)
(setcdr oldrating (cons (cadr oldrating) elapsed-time)))))
(grouplens-start-timer)
(setq grouplens-previous-article (bbb-get-current-id))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BUG REPORTING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst gnus-gl-version "gnus-gl.el 2.50")
(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu")
(defun gnus-gl-submit-bug-report ()
"Submit via mail a bug report on gnus-gl."
(interactive)
(require 'reporter)
(reporter-submit-bug-report gnus-gl-maintainer-address
(concat "gnus-gl.el " gnus-gl-version)
(list 'grouplens-pseudonym
'grouplens-bbb-host
'grouplens-bbb-port
'grouplens-newsgroups
'grouplens-bbb-token
'grouplens-bbb-process
'grouplens-current-group
'grouplens-previous-article)
nil
'gnus-gl-get-trace))
(defun gnus-gl-get-trace ()
"Insert the contents of the BBBD trace buffer."
(when grouplens-bbb-buffer
(insert-buffer-substring grouplens-bbb-buffer)))
;;
;; GroupLens minor mode
;;
(defvar gnus-grouplens-mode nil
"Minor mode for providing a GroupLens interface in Gnus summary buffers.")
(defvar gnus-grouplens-mode-map nil)
(unless gnus-grouplens-mode-map
(setq gnus-grouplens-mode-map (make-keymap))
(gnus-define-keys
gnus-grouplens-mode-map
"n" grouplens-next-unread-article
"r" bbb-summary-rate-article
"k" grouplens-score-thread
"c" grouplens-summary-catchup-and-exit
"," grouplens-best-unread-article))
(defun gnus-grouplens-make-menu-bar ()
(unless (boundp 'gnus-grouplens-menu)
(easy-menu-define
gnus-grouplens-menu gnus-grouplens-mode-map ""
'("GroupLens"
["Login" bbb-login t]
["Rate" bbb-summary-rate-article t]
["Next article" grouplens-next-unread-article t]
["Best article" grouplens-best-unread-article t]
["Raise thread" grouplens-score-thread t]
["Report bugs" gnus-gl-submit-bug-report t]))))
(defun gnus-grouplens-mode (&optional arg)
"Minor mode for providing a GroupLens interface in Gnus summary buffers."
(interactive "P")
(when (and (eq major-mode 'gnus-summary-mode)
(member gnus-newsgroup-name grouplens-newsgroups))
(make-local-variable 'gnus-grouplens-mode)
(setq gnus-grouplens-mode
(if (null arg) (not gnus-grouplens-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-grouplens-mode
(gnus-make-local-hook 'gnus-select-article-hook)
(add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local)
(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)
(cond
((eq gnus-grouplens-override-scoring 'combine)
;; either add bbb-buld-mid-scores-alist to a list
;; or make a list
(if (listp gnus-score-find-score-files-function)
(setq gnus-score-find-score-files-function
(append 'bbb-build-mid-scores-alist
gnus-score-find-score-files-function))
(setq gnus-score-find-score-files-function
(list gnus-score-find-score-files-function
'bbb-build-mid-scores-alist))))
;; leave the gnus-score-find-score-files variable alone
((eq gnus-grouplens-override-scoring 'separate)
(add-hook 'gnus-select-group-hook
(lambda ()
(bbb-get-predictions (bbb-get-all-mids)
gnus-newsgroup-name))))
;; default is to override
(t
(setq gnus-score-find-score-files-function
'bbb-build-mid-scores-alist)))
;; Change how summary lines look
(make-local-variable 'gnus-summary-line-format)
(make-local-variable 'gnus-summary-line-format-spec)
(setq gnus-summary-line-format gnus-summary-grouplens-line-format)
(setq gnus-summary-line-format-spec nil)
(gnus-update-format-specifications nil 'summary)
(gnus-update-summary-mark-positions)
;; Set up the menu.
(when (and menu-bar-mode
(gnus-visual-p 'grouplens-menu 'menu))
(gnus-grouplens-make-menu-bar))
(gnus-add-minor-mode
'gnus-grouplens-mode " GroupLens" gnus-grouplens-mode-map)
(gnus-run-hooks 'gnus-grouplens-mode-hook))))
(provide 'gnus-gl)
;;; arch-tag: 6f1bab2c-c2a3-4764-9ef6-0714cd5902a4
;;; gnus-gl.el ends here

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

@ -47,7 +47,11 @@
(require 'mm-url)
(let ((features (cons 'gnus-group features)))
(require 'gnus-sum))
(defvar gnus-cache-active-hashtb))
(unless (boundp 'gnus-cache-active-hashtb)
(defvar gnus-cache-active-hashtb nil)))
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
(defcustom gnus-group-archive-directory
"/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
@ -61,7 +65,7 @@
:group 'gnus-group-foreign
:type 'directory)
(defcustom gnus-no-groups-message "No gnus is bad news"
(defcustom gnus-no-groups-message "No Gnus is good news"
"*Message displayed by Gnus when no groups are available."
:group 'gnus-start
:type 'string)
@ -151,7 +155,7 @@ list."
(function-item gnus-group-sort-by-rank)
(function :tag "other" nil))))
(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%l %O\n"
(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n"
"*Format of group lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
@ -179,11 +183,11 @@ with some simple extensions.
%O Moderated group (string, \"(m)\" or \"\")
%P Topic indentation (string)
%m Whether there is new(ish) mail in the group (char, \"%\")
%l Whether there are GroupLens predictions for this group (string)
%n Select from where (string)
%z A string that look like `<%s:%n>' if a foreign select method is used
%d The date the group was last entered.
%E Icon as defined by `gnus-group-icon-list'.
%F The disk space used by the articles fetched by both the cache and agent.
%u User defined specifier. The next character in the format string should
be a letter. Gnus will call the function gnus-user-format-function-X,
where X is the letter following %u. The function will be passed a
@ -198,10 +202,10 @@ output may end up looking strange when listing both alive and killed
groups.
If you use %o or %O, reading the active file will be slower and quite
a bit of extra memory will be used. %D will also worsen performance.
Also note that if you change the format specification to include any
of these specs, you must probably re-start Gnus to see them go into
effect.
a bit of extra memory will be used. %D and %F will also worsen
performance. Also note that if you change the format specification to
include any of these specs, you must probably re-start Gnus to see
them go into effect.
General format specifiers can also be used.
See Info node `(gnus)Formatting Variables'."
@ -440,13 +444,20 @@ For example:
(defcustom gnus-group-jump-to-group-prompt nil
"Default prompt for `gnus-group-jump-to-group'.
If non-nil, the value should be a string, e.g. \"nnml:\",
in which case `gnus-group-jump-to-group' offers \"Group: nnml:\"
in the minibuffer prompt."
If non-nil, the value should be a string or an alist. If it is a string,
e.g. \"nnml:\", in which case `gnus-group-jump-to-group' offers \"Group:
nnml:\" in the minibuffer prompt.
If it is an alist, it must consist of \(NUMBER . PROMPT\) pairs, for example:
\((1 . \"\") (2 . \"nnfolder+archive:\")). The element with number 0 is
used when no prefix argument is given to `gnus-group-jump-to-group'."
:version "22.1"
:group 'gnus-group-various
:type '(choice (string :tag "Prompt string")
(const :tag "Empty" nil)))
(const :tag "Empty" nil)
(repeat (cons (integer :tag "Argument")
(string :tag "Prompt string")))))
(defvar gnus-group-listing-limit 1000
"*A limit of the number of groups when listing.
@ -512,11 +523,12 @@ simple manner.")
(?P gnus-group-indentation ?s)
(?E gnus-tmp-group-icon ?s)
(?B gnus-tmp-summary-live ?c)
(?l gnus-tmp-grouplens ?s)
(?z gnus-tmp-news-method-string ?s)
(?m (gnus-group-new-mail gnus-tmp-group) ?c)
(?d (gnus-group-timestamp-string gnus-tmp-group) ?s)
(?u gnus-tmp-user-defined ?s)))
(?u gnus-tmp-user-defined ?s)
(?F (gnus-total-fetched-for gnus-tmp-group) ?s)
))
(defvar gnus-group-mode-line-format-alist
`((?S gnus-tmp-news-server ?s)
@ -648,6 +660,7 @@ simple manner.")
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
"c" gnus-group-customize
"z" gnus-group-compact-group
"x" gnus-group-nnimap-expunge
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
@ -730,7 +743,8 @@ simple manner.")
"?" gnus-group-list-plus)
(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map)
"f" gnus-score-flush-cache)
"f" gnus-score-flush-cache
"e" gnus-score-edit-all-score)
(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
"c" gnus-group-fetch-charter
@ -825,6 +839,8 @@ simple manner.")
(gnus-group-group-name)]
["Select quick" gnus-group-quick-select-group (gnus-group-group-name)]
["Customize" gnus-group-customize (gnus-group-group-name)]
["Compact" gnus-group-compact-group
:active (gnus-group-group-name)]
("Edit"
["Parameters" gnus-group-edit-group-parameters
:included (not (gnus-topic-mode-p))
@ -1010,7 +1026,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and
(const :tag "Retro look" gnus-group-tool-bar-retro)
(repeat :tag "User defined list" gmm-tool-bar-item)
(symbol))
:version "22.1" ;; Gnus 5.10.9
:version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@ -1053,7 +1069,7 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and
See `gmm-tool-bar-from-list' for the format of the list."
:type '(repeat gmm-tool-bar-item)
:version "22.1" ;; Gnus 5.10.9
:version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@ -1072,7 +1088,7 @@ See `gmm-tool-bar-from-list' for the format of the list."
See `gmm-tool-bar-from-list' for the format of the list."
:type '(repeat gmm-tool-bar-item)
:version "22.1" ;; Gnus 5.10.9
:version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@ -1083,7 +1099,7 @@ These items are not displayed in the Gnus group mode tool bar.
See `gmm-tool-bar-from-list' for the format of the list."
:type 'gmm-tool-bar-zap-list
:version "22.1" ;; Gnus 5.10.9
:version "23.0" ;; No Gnus
:initialize 'custom-initialize-default
:set 'gnus-group-tool-bar-update
:group 'gnus-group)
@ -1143,7 +1159,8 @@ The following commands are available:
(use-local-map gnus-group-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
(setq buffer-read-only t)
(setq buffer-read-only t
show-trailing-whitespace nil)
(gnus-set-default-directory)
(gnus-update-format-specifications nil 'group 'group-mode)
(gnus-update-group-mark-positions)
@ -1202,7 +1219,10 @@ The following commands are available:
(defun gnus-group-name-charset (method group)
(if (null method)
(setq method (gnus-find-method-for-group group)))
(let ((item (assoc method gnus-group-name-charset-method-alist))
(let ((item (or (assoc method gnus-group-name-charset-method-alist)
(and (consp method)
(assoc (list (car method) (cadr method))
gnus-group-name-charset-method-alist))))
(alist gnus-group-name-charset-group-alist)
result)
(if item
@ -1244,7 +1264,7 @@ Also see the `gnus-group-use-permanent-levels' variable."
(gnus-group-setup-buffer)
(gnus-update-format-specifications nil 'group 'group-mode)
(let ((case-fold-search nil)
(props (text-properties-at (gnus-point-at-bol)))
(props (text-properties-at (point-at-bol)))
(empty (= (point-min) (point-max)))
(group (gnus-group-group-name))
number)
@ -1276,7 +1296,7 @@ Also see the `gnus-group-use-permanent-levels' variable."
(point-min) (point-max)
'gnus-group (gnus-intern-safe
group gnus-active-hashtb))))
(let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb))))
(let ((newsrc (cdddr (gnus-group-entry group))))
(while (and newsrc
(not (gnus-goto-char
(text-property-any
@ -1331,7 +1351,7 @@ if it is a string, only list groups matching REGEXP."
group (gnus-info-group info)
params (gnus-info-params info)
newsrc (cdr newsrc)
unread (car (gnus-gethash group gnus-newsrc-hashtb)))
unread (gnus-group-unread group))
(when not-in-list
(setq not-in-list (delete group not-in-list)))
(when (gnus-group-prepare-logic
@ -1431,7 +1451,7 @@ if it is a string, only list groups matching REGEXP."
"Update the current line in the group buffer."
(let* ((buffer-read-only nil)
(group (gnus-group-group-name))
(entry (and group (gnus-gethash group gnus-newsrc-hashtb)))
(entry (and group (gnus-group-entry group)))
gnus-group-indentation)
(when group
(and entry
@ -1448,7 +1468,7 @@ if it is a string, only list groups matching REGEXP."
(defun gnus-group-insert-group-line-info (group)
"Insert GROUP on the current line."
(let ((entry (gnus-gethash group gnus-newsrc-hashtb))
(let ((entry (gnus-group-entry group))
(gnus-group-indentation (gnus-group-group-indentation))
active info)
(if entry
@ -1575,10 +1595,6 @@ if it is a string, only list groups matching REGEXP."
(gnus-tmp-process-marked
(if (member gnus-tmp-group gnus-group-marked)
gnus-process-mark ? ))
(gnus-tmp-grouplens
(or (and gnus-use-grouplens
(bbb-grouplens-group-p gnus-tmp-group))
""))
(buffer-read-only nil)
beg end
header gnus-tmp-header) ; passed as parameter to user-funcs.
@ -1615,7 +1631,7 @@ if it is a string, only list groups matching REGEXP."
"Highlight the current line according to `gnus-group-highlight'."
(let* ((list gnus-group-highlight)
(p (point))
(end (gnus-point-at-eol))
(end (point-at-eol))
;; now find out where the line starts and leave point there.
(beg (progn (beginning-of-line) (point)))
(group (gnus-group-group-name))
@ -1666,7 +1682,7 @@ already."
(loc (point-min))
found buffer-read-only)
;; Enter the current status into the dribble buffer.
(let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
(let ((entry (gnus-group-entry group)))
(when (and entry
(not (gnus-ephemeral-group-p group)))
(gnus-dribble-enter
@ -1691,7 +1707,7 @@ already."
;; go, and insert it there (or at the end of the buffer).
(if gnus-goto-missing-group-function
(funcall gnus-goto-missing-group-function group)
(let ((entry (cddr (gnus-gethash group gnus-newsrc-hashtb))))
(let ((entry (cddr (gnus-group-entry group))))
(while (and entry (car entry)
(not
(gnus-goto-char
@ -1751,24 +1767,24 @@ already."
(defun gnus-group-group-name ()
"Get the name of the newsgroup on the current line."
(let ((group (get-text-property (gnus-point-at-bol) 'gnus-group)))
(let ((group (get-text-property (point-at-bol) 'gnus-group)))
(when group
(symbol-name group))))
(defun gnus-group-group-level ()
"Get the level of the newsgroup on the current line."
(get-text-property (gnus-point-at-bol) 'gnus-level))
(get-text-property (point-at-bol) 'gnus-level))
(defun gnus-group-group-indentation ()
"Get the indentation of the newsgroup on the current line."
(or (get-text-property (gnus-point-at-bol) 'gnus-indentation)
(or (get-text-property (point-at-bol) 'gnus-indentation)
(and gnus-group-indentation-function
(funcall gnus-group-indentation-function))
""))
(defun gnus-group-group-unread ()
"Get the number of unread articles of the newsgroup on the current line."
(get-text-property (gnus-point-at-bol) 'gnus-unread))
(get-text-property (point-at-bol) 'gnus-unread))
(defun gnus-group-new-mail (group)
(if (nnmail-new-mail-p (gnus-group-real-name group))
@ -1826,6 +1842,18 @@ If FIRST-TOO, the current line is also eligible as a target."
(goto-char (or pos beg))
(and pos t))))
(defun gnus-total-fetched-for (group)
(let* ((size-in-cache (or (gnus-cache-total-fetched-for group) 0))
(size-in-agent (or (gnus-agent-total-fetched-for group) 0))
(size (+ size-in-cache size-in-agent))
(suffix '("B" "K" "M" "G"))
(scale 1024.0)
(cutoff scale))
(while (> size cutoff)
(setq size (/ size scale)
suffix (cdr suffix)))
(format "%5.1f%s" size (car suffix))))
;;; Gnus group mode commands
;; Group marking.
@ -1847,15 +1875,14 @@ If FIRST-TOO, the current line is also eligible as a target."
;; Go to the mark position.
(beginning-of-line)
(forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2))
(subst-char-in-region
(point) (1+ (point)) (char-after)
(if unmark
(progn
(setq gnus-group-marked (delete group gnus-group-marked))
? )
(delete-char 1)
(if unmark
(progn
(setq gnus-group-marked (delete group gnus-group-marked))
(insert-char ? 1 t))
(setq gnus-group-marked
(cons group (delete group gnus-group-marked)))
gnus-process-mark)))
(insert-char gnus-process-mark 1 t)))
(unless no-advance
(gnus-group-next-group 1))
(decf n))
@ -1871,10 +1898,8 @@ If FIRST-TOO, the current line is also eligible as a target."
(defun gnus-group-unmark-all-groups ()
"Unmark all groups."
(interactive)
(let ((groups gnus-group-marked))
(save-excursion
(while groups
(gnus-group-remove-mark (pop groups)))))
(save-excursion
(mapc 'gnus-group-remove-mark gnus-group-marked))
(gnus-group-position-point))
(defun gnus-group-mark-region (unmark beg end)
@ -2020,8 +2045,7 @@ group."
(unless group
(error "No group on current line"))
(setq marked (gnus-info-marks
(nth 2 (setq entry (gnus-gethash
group gnus-newsrc-hashtb)))))
(nth 2 (setq entry (gnus-group-entry group)))))
;; This group might be a dead group. In that case we have to get
;; the number of unread articles from `gnus-active-hashtb'.
(setq number
@ -2051,11 +2075,11 @@ articles in the group."
(forward-line -1))
(gnus-group-read-group all t))
(defun gnus-group-quick-select-group (&optional all)
"Select the current group \"quickly\".
This means that no highlighting or scoring will be performed.
If ALL (the prefix argument) is 0, don't even generate the summary
buffer.
(defun gnus-group-quick-select-group (&optional all group)
"Select the GROUP \"quickly\".
This means that no highlighting or scoring will be performed. If
ALL (the prefix argument) is 0, don't even generate the summary
buffer. If GROUP is nil, use current group.
This might be useful if you want to toggle threading
before entering the group."
@ -2066,7 +2090,7 @@ before entering the group."
gnus-home-score-file
gnus-apply-kill-hook
gnus-summary-expunge-below)
(gnus-group-read-group all t)))
(gnus-group-read-group all t group)))
(defun gnus-group-visible-select-group (&optional all)
"Select the current group without hiding any articles."
@ -2090,14 +2114,86 @@ be permanent."
(gnus-group-read-ephemeral-group
(gnus-group-prefixed-name group method) method)))
(defun gnus-group-name-at-point ()
"Return a group name from around point if it exists, or nil."
(if (eq major-mode 'gnus-group-mode)
(let ((group (gnus-group-group-name)))
(when group
(gnus-group-decoded-name group)))
(let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\
\\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\
\[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)*\
\\|[^][\C-@-*,./:-@\\^`{-\C-?]+\\(?:\\.[^][\C-@-*,./:-@\\^`{-\C-?]+\\)+\\)")
(start (point))
(case-fold-search nil))
(prog1
(if (or (and (not (or (eobp)
(looking-at "[][\C-@-*,/;-@\\^`{-\C-?]")))
(prog1 t
(skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
(point-at-bol))))
(and (looking-at "[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*$")
(prog1 t
(skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
(skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
(point-at-bol))))
(string-match "\\`[][\C-@-\t\v-*,/;-@\\^`{-\C-?]*\\'"
(buffer-substring (point-at-bol) (point))))
(when (looking-at regexp)
(match-string 1))
(let (group distance)
(when (looking-at regexp)
(setq group (match-string 1)
distance (- (match-beginning 1) (match-beginning 0))))
(skip-chars-backward "][\C-@-\t\v-*,/;-@\\^`{-\C-?")
(skip-chars-backward "^][\C-@-\t\v-*,/;-@\\^`{-\C-?"
(point-at-bol))
(if (looking-at regexp)
(if (and group (<= distance (- start (match-end 0))))
group
(match-string 1))
group)))
(goto-char start)))))
(defun gnus-group-completing-read (prompt &optional collection predicate
require-match initial-input hist def
&rest args)
"Read a group name with completion. Non-ASCII group names are allowed.
The arguments are the same as `completing-read' except that COLLECTION
and HIST default to `gnus-active-hashtb' and `gnus-group-history'
respectively if they are omitted."
(let (group)
(mapatoms (lambda (symbol)
(setq group (symbol-name symbol))
(set (intern (if (string-match "[^\000-\177]" group)
(gnus-group-decoded-name group)
group)
collection)
group))
(prog1
(or collection
(setq collection (or gnus-active-hashtb [0])))
(setq collection (gnus-make-hashtable (length collection)))))
(setq group (apply 'completing-read prompt collection predicate
require-match initial-input
(or hist 'gnus-group-history)
def args))
(or (prog1
(symbol-value (intern-soft group collection))
(setq collection nil))
(mm-encode-coding-string group (gnus-group-name-charset nil group)))))
;;;###autoload
(defun gnus-fetch-group (group &optional articles)
"Start Gnus if necessary and enter GROUP.
If ARTICLES, display those articles.
Returns whether the fetching was successful or not."
(interactive (list (completing-read "Group name: " gnus-active-hashtb)))
(unless (get-buffer gnus-group-buffer)
(interactive (list (gnus-group-completing-read "Group name: "
nil nil nil
(gnus-group-name-at-point))))
(unless (gnus-alive-p)
(gnus-no-server))
(gnus-group-read-group articles nil group))
(gnus-group-read-group (if articles nil t) nil group articles))
;;;###autoload
(defun gnus-fetch-group-other-frame (group)
@ -2155,10 +2251,7 @@ Return the name of the group if selection was successful."
(interactive
(list
;; (gnus-read-group "Group name: ")
(completing-read
"Group: " gnus-active-hashtb
nil nil nil
'gnus-group-history)
(gnus-group-completing-read "Group: ")
(gnus-read-method "From method: ")))
;; Transform the select method into a unique server.
(when (stringp method)
@ -2204,15 +2297,20 @@ Return the name of the group if selection was successful."
(message "Quit reading the ephemeral group")
nil)))))
(defun gnus-group-jump-to-group (group)
"Jump to newsgroup GROUP."
(defun gnus-group-jump-to-group (group &optional prompt)
"Jump to newsgroup GROUP.
If PROMPT (the prefix) is a number, use the prompt specified in
`gnus-group-jump-to-group-prompt'."
(interactive
(list (mm-string-make-unibyte
(completing-read
"Group: " gnus-active-hashtb nil
(gnus-read-active-file-p)
gnus-group-jump-to-group-prompt
'gnus-group-history))))
(list (gnus-group-completing-read
"Group: " nil nil (gnus-read-active-file-p)
(if current-prefix-arg
(cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
(or (and (stringp gnus-group-jump-to-group-prompt)
gnus-group-jump-to-group-prompt)
(let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
(and (stringp p) p)))))))
(when (equal group "")
(error "Empty group name"))
@ -2360,6 +2458,25 @@ If EXCLUDE-GROUP, do not go to that group."
(gnus-group-position-point)
(and best-point (gnus-group-group-name))))
;; Is there something like an after-point-motion-hook?
;; (inhibit-point-motion-hooks?). Is there a tool-bar-update function?
;; (defun gnus-group-menu-bar-update ()
;; (let* ((buf (list (with-current-buffer gnus-group-buffer
;; (current-buffer))))
;; (name (buffer-name (car buf))))
;; (setcdr buf
;; (if (> (length name) 27)
;; (concat (substring name 0 12)
;; "..."
;; (substring name -12))
;; name))
;; (menu-bar-update-buffers-1 buf)))
;; (defun gnus-group-position-point ()
;; (gnus-goto-colon)
;; (gnus-group-menu-bar-update))
(defun gnus-group-first-unread-group ()
"Go to the first group with unread articles."
(interactive)
@ -2381,10 +2498,19 @@ If EXCLUDE-GROUP, do not go to that group."
(interactive)
(gnus-enter-server-buffer))
(defun gnus-group-make-group (name &optional method address args)
(defun gnus-group-make-group-simple (&optional group)
"Add a new newsgroup.
The user will be prompted for GROUP."
(interactive (list (gnus-group-completing-read "Group: ")))
(gnus-group-make-group (gnus-group-real-name group)
(gnus-group-server group)
nil nil t))
(defun gnus-group-make-group (name &optional method address args encoded)
"Add a new newsgroup.
The user will be prompted for a NAME, for a select METHOD, and an
ADDRESS."
ADDRESS. NAME should be a human-readable string (i.e., not be encoded
even if it contains non-ASCII characters) unless ENCODED is non-nil."
(interactive
(list
(gnus-read-group "Group name: ")
@ -2392,6 +2518,10 @@ ADDRESS."
(when (stringp method)
(setq method (or (gnus-server-to-method method) method)))
(unless encoded
(setq name (mm-encode-coding-string
name
(gnus-group-name-charset method name))))
(let* ((meth (gnus-method-simplify
(when (and method
(not (gnus-server-equal method gnus-select-method)))
@ -2399,15 +2529,14 @@ ADDRESS."
method))))
(nname (if method (gnus-group-prefixed-name name meth) name))
backend info)
(when (gnus-gethash nname gnus-newsrc-hashtb)
(when (gnus-group-entry nname)
(error "Group %s already exists" (gnus-group-decoded-name nname)))
;; Subscribe to the new group.
(gnus-group-change-level
(setq info (list t nname gnus-level-default-subscribed nil nil meth))
gnus-level-default-subscribed gnus-level-killed
(and (gnus-group-group-name)
(gnus-gethash (gnus-group-group-name)
gnus-newsrc-hashtb))
(gnus-group-entry (gnus-group-group-name)))
t)
;; Make it active.
(gnus-set-active nname (cons 1 0))
@ -2474,7 +2603,7 @@ be removed from the server, even when it's empty."
(gnus-message 6 "Deleting group %s...done" group-decoded)
(gnus-group-goto-group group)
(gnus-group-kill-group 1 t)
(gnus-sethash group nil gnus-active-hashtb)
(gnus-set-active group nil)
t)))
(gnus-group-position-point)))
@ -2641,7 +2770,7 @@ group already exists:
(interactive)
(let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
(file (nnheader-find-etc-directory "gnus-tut.txt" t)))
(if (gnus-gethash name gnus-newsrc-hashtb)
(if (gnus-group-entry name)
(cond ((eq noerror nil)
(error "Documentation group already exists"))
((eq noerror t)
@ -2684,19 +2813,17 @@ If called with a prefix argument, ask for the file type."
nil))))
(setq type found)))
(setq file (expand-file-name file))
(let ((name (gnus-generate-new-group-name
(gnus-group-prefixed-name
(file-name-nondirectory file) '(nndoc ""))))
(encodable (mm-coding-system-p 'utf-8)))
(let* ((name (gnus-generate-new-group-name
(gnus-group-prefixed-name
(file-name-nondirectory file) '(nndoc ""))))
(method (list 'nndoc file
(list 'nndoc-address file)
(list 'nndoc-article-type (or type 'guess))))
(coding (gnus-group-name-charset method name)))
(setcar (cdr method) (mm-encode-coding-string file coding))
(gnus-group-make-group
(if encodable
(mm-encode-coding-string (gnus-group-real-name name) 'utf-8)
(gnus-group-real-name name))
(list 'nndoc (if encodable
(mm-encode-coding-string file 'utf-8)
file)
(list 'nndoc-address file)
(list 'nndoc-article-type (or type 'guess))))))
(mm-encode-coding-string (gnus-group-real-name name) coding)
method nil nil t)))
(defvar nnweb-type-definition)
(defvar gnus-group-web-type-history nil)
@ -2750,25 +2877,23 @@ If there is, use Gnus to create an nnrss group"
(setq url (read-from-minibuffer "URL to Search for RSS: ")))
(let ((feedinfo (nnrss-discover-feed url)))
(if feedinfo
(let ((title (gnus-newsgroup-savable-name
(read-from-minibuffer "Title: "
(gnus-newsgroup-savable-name
(or (cdr (assoc 'title
feedinfo))
"")))))
(desc (read-from-minibuffer "Description: "
(cdr (assoc 'description
feedinfo))))
(href (cdr (assoc 'href feedinfo)))
(encodable (mm-coding-system-p 'utf-8)))
(when encodable
(let* ((title (gnus-newsgroup-savable-name
(read-from-minibuffer "Title: "
(gnus-newsgroup-savable-name
(or (cdr (assoc 'title
feedinfo))
"")))))
(desc (read-from-minibuffer "Description: "
(cdr (assoc 'description
feedinfo))))
(href (cdr (assoc 'href feedinfo)))
(coding (gnus-group-name-charset '(nnrss "") title)))
(when coding
;; Unify non-ASCII text.
(setq title (mm-decode-coding-string
(mm-encode-coding-string title 'utf-8) 'utf-8)))
(gnus-group-make-group (if encodable
(mm-encode-coding-string title 'utf-8)
title)
'(nnrss ""))
(mm-encode-coding-string title coding)
coding)))
(gnus-group-make-group title '(nnrss ""))
(push (list title href desc) nnrss-group-alist)
(nnrss-save-server-data nil))
(error "No feeds found for %s" url))))
@ -2815,7 +2940,7 @@ Given a prefix, create a full group."
(interactive "P")
(let ((group (gnus-group-prefixed-name
(if all "ding.archives" "ding.recent") '(nndir ""))))
(when (gnus-gethash group gnus-newsrc-hashtb)
(when (gnus-group-entry group)
(error "Archive group already exists"))
(gnus-group-make-group
(gnus-group-real-name group)
@ -2839,7 +2964,7 @@ mail messages or news articles in files that have numeric names."
(let ((ext "")
(i 0)
group)
(while (or (not group) (gnus-gethash group gnus-newsrc-hashtb))
(while (or (not group) (gnus-group-entry group))
(setq group
(gnus-group-prefixed-name
(expand-file-name ext dir)
@ -2858,7 +2983,7 @@ score file entries for articles to include in the group."
(list
(read-string "nnkiboze group name: ")
(read-string "Source groups (regexp): ")
(let ((headers (mapcar (lambda (group) (list group))
(let ((headers (mapcar 'list
'("subject" "from" "number" "date" "message-id"
"references" "chars" "lines" "xref"
"followup" "all" "body" "head")))
@ -2909,7 +3034,7 @@ score file entries for articles to include in the group."
(let* ((method (list 'nnvirtual "^$"))
(pgroup (gnus-group-prefixed-name group method)))
;; Check whether it exists already.
(when (gnus-gethash pgroup gnus-newsrc-hashtb)
(when (gnus-group-entry pgroup)
(error "Group %s already exists" pgroup))
;; Subscribe the new group after the group on the current line.
(gnus-subscribe-group pgroup (gnus-group-group-name) method)
@ -3081,7 +3206,7 @@ If REVERSE, sort in reverse order."
(let (entries infos)
;; First find all the group entries for these groups.
(while groups
(push (nthcdr 2 (gnus-gethash (pop groups) gnus-newsrc-hashtb))
(push (nthcdr 2 (gnus-group-entry (pop groups)))
entries))
;; Then sort the infos.
(setq infos
@ -3162,8 +3287,8 @@ sort in reverse order."
(defun gnus-group-sort-by-unread (info1 info2)
"Sort by number of unread articles."
(let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb)))
(n2 (car (gnus-gethash (gnus-info-group info2) gnus-newsrc-hashtb))))
(let ((n1 (gnus-group-unread (gnus-info-group info1)))
(n2 (gnus-group-unread (gnus-info-group info2))))
(< (or (and (numberp n1) n1) 0)
(or (and (numberp n2) n2) 0))))
@ -3283,13 +3408,15 @@ up is returned."
(when (eq 'nnvirtual (car method))
(nnvirtual-catchup-group
(gnus-group-real-name group) (nth 1 method) all)))
(if (>= (gnus-group-level group) gnus-level-zombie)
(gnus-message 2 "Dead groups can't be caught up")
(if (prog1
(gnus-group-goto-group group)
(gnus-group-catchup group all))
(gnus-group-update-group-line)
(setq ret (1+ ret)))))
(cond
((>= (gnus-group-level group) gnus-level-zombie)
(gnus-message 2 "Dead groups can't be caught up"))
((prog1
(gnus-group-goto-group group)
(gnus-group-catchup group all))
(gnus-group-update-group-line))
(t
(setq ret (1+ ret)))))
(gnus-group-next-unread-group 1)
ret)))
@ -3304,9 +3431,9 @@ Cross references (Xref: header) of articles are ignored."
If ALL is non-nil, all articles are marked as read.
The return value is the number of articles that were marked as read,
or nil if no action could be taken."
(let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
(let* ((entry (gnus-group-entry group))
(num (car entry))
(marks (nth 3 (nth 2 entry)))
(marks (gnus-info-marks (nth 2 entry)))
(unread (gnus-sequence-of-unread-articles group)))
;; Remove entries for this group.
(nnmail-purge-split-history (gnus-group-real-name group))
@ -3321,16 +3448,18 @@ or nil if no action could be taken."
(list (cdr (assq 'dormant marks))
'del '(dormant))))
(setq unread (gnus-range-add (gnus-range-add
unread (cdr (assq 'dormant marks)))
(cdr (assq 'tick marks))))
unread (cdr (assq 'dormant marks)))
(cdr (assq 'tick marks))))
(gnus-add-marked-articles group 'tick nil nil 'force)
(gnus-add-marked-articles group 'dormant nil nil 'force))
;; Do auto-expirable marks if that's required.
(when (gnus-group-auto-expirable-p group)
(gnus-range-map (lambda (article)
(gnus-add-marked-articles group 'expire (list article))
(gnus-request-set-mark group (list (list (list article) 'add '(expire)))))
unread))
(gnus-range-map
(lambda (article)
(gnus-add-marked-articles group 'expire (list article))
(gnus-request-set-mark group (list (list (list article)
'add '(expire)))))
unread))
(let ((gnus-newsgroup-name group))
(gnus-run-hooks 'gnus-group-catchup-group-hook))
num)))
@ -3412,17 +3541,15 @@ Uses the process/prefix convention."
s))))))
(unless (and (>= level 1) (<= level gnus-level-killed))
(error "Invalid level: %d" level))
(let ((groups (gnus-group-process-prefix n))
group)
(while (setq group (pop groups))
(gnus-group-remove-mark group)
(gnus-message 6 "Changed level of %s from %d to %d"
(gnus-group-decoded-name group)
(or (gnus-group-group-level) gnus-level-killed)
level)
(gnus-group-change-level
group level (or (gnus-group-group-level) gnus-level-killed))
(gnus-group-update-group-line)))
(dolist (group (gnus-group-process-prefix n))
(gnus-group-remove-mark group)
(gnus-message 6 "Changed level of %s from %d to %d"
(gnus-group-decoded-name group)
(or (gnus-group-group-level) gnus-level-killed)
level)
(gnus-group-change-level
group level (or (gnus-group-group-level) gnus-level-killed))
(gnus-group-update-group-line))
(gnus-group-position-point))
(defun gnus-group-unsubscribe (&optional n)
@ -3460,13 +3587,9 @@ If given numerical prefix, toggle the N next groups."
"Toggle subscription to GROUP.
Killed newsgroups are subscribed. If SILENT, don't try to update the
group line."
(interactive
(list (completing-read
"Group: " gnus-active-hashtb nil
(gnus-read-active-file-p)
nil
'gnus-group-history)))
(let ((newsrc (gnus-gethash group gnus-newsrc-hashtb)))
(interactive (list (gnus-group-completing-read
"Group: " nil nil (gnus-read-active-file-p))))
(let ((newsrc (gnus-group-entry group)))
(cond
((string-match "^[ \t]*$" group)
(error "Empty group name"))
@ -3490,7 +3613,7 @@ group line."
gnus-level-zombie)
gnus-level-killed)
(when (gnus-group-group-name)
(gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb)))
(gnus-group-entry (gnus-group-group-name))))
(unless silent
(gnus-group-update-group group)))
(t (error "No such newsgroup: %s" group)))
@ -3529,12 +3652,10 @@ The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
(count-lines
(progn
(goto-char begin)
(beginning-of-line)
(point))
(point-at-bol))
(progn
(goto-char end)
(beginning-of-line)
(point))))))
(point-at-bol))))))
(goto-char begin)
(beginning-of-line) ;Important when LINES < 1
(gnus-group-kill-group lines)))
@ -3558,7 +3679,7 @@ of groups killed."
(setq level (gnus-group-group-level))
(gnus-delete-line)
(when (and (not discard)
(setq entry (gnus-gethash group gnus-newsrc-hashtb)))
(setq entry (gnus-group-entry group)))
(gnus-undo-register
`(progn
(gnus-group-goto-group ,(gnus-group-group-name))
@ -3581,7 +3702,7 @@ of groups killed."
(funcall gnus-group-change-level-function
group gnus-level-killed 3))
(cond
((setq entry (gnus-gethash group gnus-newsrc-hashtb))
((setq entry (gnus-group-entry group))
(push (cons (car entry) (nth 2 entry))
gnus-list-of-killed-groups)
(setcdr (cdr entry) (cdddr entry)))
@ -3614,7 +3735,7 @@ yanked) a list of yanked groups is returned."
(setq prev (gnus-group-group-name))
(gnus-group-change-level
info (gnus-info-level (cdr info)) gnus-level-killed
(and prev (gnus-gethash prev gnus-newsrc-hashtb))
(and prev (gnus-group-entry prev))
t)
(gnus-group-insert-group-line-info group)
(gnus-undo-register
@ -3773,6 +3894,7 @@ re-scanning. If ARG is non-nil and not a number, this will force
(gnus-get-unread-articles arg))
(let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
(gnus-get-unread-articles arg)))
(gnus-check-reasonable-setup)
(gnus-run-hooks 'gnus-after-getting-new-news-hook)
(gnus-group-list-groups (and (numberp arg)
(max (car gnus-group-list-mode) arg)))))
@ -3797,15 +3919,17 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(gnus-group-remove-mark group)
;; Bypass any previous denials from the server.
(gnus-remove-denial (setq method (gnus-find-method-for-group group)))
(if (gnus-activate-group group (if dont-scan nil 'scan))
(progn
(gnus-get-unread-articles-in-group
(gnus-get-info group) (gnus-active group) t)
(if (gnus-activate-group group (if dont-scan nil 'scan) nil method)
(let ((info (gnus-get-info group))
(active (gnus-active group)))
(when info
(gnus-request-update-info info method))
(gnus-get-unread-articles-in-group info active)
(unless (gnus-virtual-group-p group)
(gnus-close-group group))
(when gnus-agent
(gnus-agent-save-group-info
method (gnus-group-real-name group) (gnus-active group)))
method (gnus-group-real-name group) active))
(gnus-group-update-group group))
(if (eq (gnus-server-status (gnus-find-method-for-group group))
'denied)
@ -3851,7 +3975,7 @@ to use."
If given a prefix argument, prompt for a group."
(interactive
(list (or (when current-prefix-arg
(completing-read "Group: " gnus-active-hashtb))
(gnus-group-completing-read "Group: "))
(gnus-group-group-name)
gnus-newsgroup-name)))
(unless group
@ -3879,7 +4003,7 @@ If given a prefix argument, prompt for a group."
If given a prefix argument, prompt for a group."
(interactive
(list (or (when current-prefix-arg
(completing-read "Group: " gnus-active-hashtb))
(gnus-group-completing-read "Group: "))
(gnus-group-group-name)
gnus-newsgroup-name)))
(unless group
@ -4105,14 +4229,12 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending."
(gnus-offer-save-summaries)
;; Kill Gnus buffers except for group mode buffer.
(let ((group-buf (get-buffer gnus-group-buffer)))
(mapcar (lambda (buf)
(unless (or (member buf (list group-buf gnus-dribble-buffer))
(progn
(save-excursion
(set-buffer buf)
(eq major-mode 'message-mode))))
(gnus-kill-buffer buf)))
(gnus-buffers))
(dolist (buf (gnus-buffers))
(unless (or (eq buf group-buf)
(eq buf gnus-dribble-buffer)
(with-current-buffer buf
(eq major-mode 'message-mode)))
(gnus-kill-buffer buf)))
(setq gnus-backlog-articles nil)
(gnus-kill-gnus-frames)
(when group-buf
@ -4196,17 +4318,15 @@ and the second element is the address."
;; Suggested by mapjph@bath.ac.uk.
(completing-read
"Address: "
(mapcar (lambda (server) (list server))
gnus-secondary-servers)))
(mapcar 'list gnus-secondary-servers)))
;; We got a server name.
how))))
(gnus-browse-foreign-server method))
(defun gnus-group-set-info (info &optional method-only-group part)
(when (or info part)
(let* ((entry (gnus-gethash
(or method-only-group (gnus-info-group info))
gnus-newsrc-hashtb))
(let* ((entry (gnus-group-entry
(or method-only-group (gnus-info-group info))))
(part-info info)
(info (if method-only-group (nth 2 entry) info))
method)
@ -4239,15 +4359,15 @@ and the second element is the address."
(if (stringp method) method
(prin1-to-string (car method)))
(and (consp method)
(nth 1 (gnus-info-method info))))
(nth 1 (gnus-info-method info)))
nil t)
;; It's a native group.
(gnus-group-make-group (gnus-info-group info))))
(gnus-group-make-group (gnus-info-group info) nil nil nil t)))
(gnus-message 6 "Note: New group created")
(setq entry
(gnus-gethash (gnus-group-prefixed-name
(gnus-group-real-name (gnus-info-group info))
(or (gnus-info-method info) gnus-select-method))
gnus-newsrc-hashtb))))
(gnus-group-entry (gnus-group-prefixed-name
(gnus-group-real-name (gnus-info-group info))
(or (gnus-info-method info) gnus-select-method))))))
;; Whether it was a new group or not, we now have the entry, so we
;; can do the update.
(if entry
@ -4460,6 +4580,40 @@ This command may read the active file."
(gnus-add-marked-articles
group 'expire (list article))))))
;;;
;;; Group compaction. -- dvl
;;;
(defun gnus-group-compact-group (group)
"Compact the current group.
Compaction means removing gaps between article numbers. Hence, this
operation is only meaningful for back ends using one file per article
\(e.g. nnml).
Note: currently only implemented in nnml."
(interactive (list (gnus-group-group-name)))
(unless group
(error "No group to compact"))
(unless (gnus-check-backend-function 'request-compact-group group)
(error "This back end does not support group compaction"))
(let ((group-decoded (gnus-group-decoded-name group)))
(gnus-message 6 "\
Compacting group %s... (this may take a long time)"
group-decoded)
(prog1
(if (not (gnus-request-compact-group group))
(gnus-error 3 "Couldn't compact group %s" group-decoded)
(gnus-message 6 "Compacting group %s...done" group-decoded)
t)
;; Invalidate the "original article" buffer which might be out of date.
;; #### NOTE: Yes, this might be a bit rude, but since compaction
;; #### will not happen very often, I think this is acceptable.
(let ((original (get-buffer gnus-original-article-buffer)))
(and original (gnus-kill-buffer original)))
;; Update the group line to reflect new information (art number etc).
(gnus-group-update-group-line))))
(provide 'gnus-group)
;;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6

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

@ -75,7 +75,7 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server."
;; Read server name with completion.
(setq gnus-nntp-server
(completing-read "NNTP server: "
(mapcar (lambda (server) (list server))
(mapcar 'list
(cons (list gnus-nntp-server)
gnus-secondary-servers))
nil nil gnus-nntp-server)))
@ -209,11 +209,12 @@ If it is down, start it up (again)."
"Open a connection to GNUS-COMMAND-METHOD."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
(let ((elem (assoc gnus-command-method gnus-opened-servers)))
(let ((elem (assoc gnus-command-method gnus-opened-servers))
(server (gnus-method-to-server-name gnus-command-method)))
;; If this method was previously denied, we just return nil.
(if (eq (nth 1 elem) 'denied)
(progn
(gnus-message 1 "Denied server")
(gnus-message 1 "Denied server %s" server)
nil)
;; Open the server.
(let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
@ -224,11 +225,11 @@ If it is down, start it up (again)."
(nthcdr 2 gnus-command-method))
(error
(gnus-message 1 (format
"Unable to open server due to: %s"
(error-message-string err)))
"Unable to open server %s due to: %s"
server (error-message-string err)))
nil)
(quit
(gnus-message 1 "Quit trying to open server")
(gnus-message 1 "Quit trying to open server %s" server)
nil)))
open-offline)
;; If this hasn't been opened before, we add it to the list.
@ -253,9 +254,9 @@ If it is down, start it up (again)."
((and
(not gnus-batch-mode)
(gnus-y-or-n-p
(format "Unable to open %s:%s, go offline? "
(car gnus-command-method)
(cadr gnus-command-method))))
(format
"Unable to open server %s, go offline? "
server)))
(setq open-offline t)
'offline)
(t
@ -335,6 +336,23 @@ name. The method this group uses will be queried."
(funcall (gnus-get-function gnus-command-method 'request-regenerate)
(nth 1 gnus-command-method)))
(defun gnus-request-compact-group (group)
(let* ((method (gnus-find-method-for-group group))
(gnus-command-method method)
(result
(funcall (gnus-get-function gnus-command-method
'request-compact-group)
(gnus-group-real-name group)
(nth 1 gnus-command-method) t)))
result))
(defun gnus-request-compact (gnus-command-method)
"Request groups compaction from GNUS-COMMAND-METHOD."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
(funcall (gnus-get-function gnus-command-method 'request-compact)
(nth 1 gnus-command-method)))
(defun gnus-request-group (group &optional dont-check gnus-command-method)
"Request GROUP. If DONT-CHECK, no information is required."
(let ((gnus-command-method
@ -342,7 +360,7 @@ name. The method this group uses will be queried."
(when (stringp gnus-command-method)
(setq gnus-command-method
(inline (gnus-server-to-method gnus-command-method))))
(funcall (inline (gnus-get-function gnus-command-method 'request-group))
(funcall (inline (gnus-get-function gnus-command-method 'request-group))
(gnus-group-real-name group) (nth 1 gnus-command-method)
dont-check)))
@ -521,12 +539,11 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(if group (gnus-find-method-for-group group) gnus-command-method))
(gnus-inhibit-demon t)
(mail-source-plugged gnus-plugged))
(if (or gnus-plugged (not (gnus-agent-method-p 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))))))
(when (or gnus-plugged (not (gnus-agent-method-p gnus-command-method)))
(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."
@ -566,12 +583,12 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
not-deleted))
(defun gnus-request-move-article (article group server accept-function
&optional last)
&optional last move-is-internal)
(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)))
(nth 1 gnus-command-method) accept-function last move-is-internal)))
(when (and result gnus-agent
(gnus-agent-method-p gnus-command-method))
(gnus-agent-unfetch-articles group (list article)))
@ -597,7 +614,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(let ((mail-parse-charset message-default-charset))
(mail-encode-encoded-word-buffer)))
(message-encode-message-body)))
(let ((gnus-command-method (or gnus-command-method
(let ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group)))
(result
(funcall

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

@ -497,7 +497,7 @@ Optional 1st argument COMMAND is default to
(gnus-summary-mark-as-read nil \"X\").
If optional 2nd argument ALL is non-nil, articles marked are also applied to.
If FIELD is an empty string (or nil), entire article body is searched for.
COMMAND must be a lisp expression or a string representing a key sequence."
COMMAND must be a Lisp expression or a string representing a key sequence."
;; We don't want to change current point nor window configuration.
(let ((old-buffer (current-buffer)))
(save-excursion
@ -625,7 +625,7 @@ COMMAND must be a lisp expression or a string representing a key sequence."
did-kill)))
(defun gnus-execute (field regexp form &optional backward unread)
"If FIELD of article header matches REGEXP, execute lisp FORM (or a string).
"If FIELD of article header matches REGEXP, execute Lisp FORM (or a string).
If FIELD is an empty string (or nil), entire article body is searched for.
If optional 1st argument BACKWARD is non-nil, do backward instead.
If optional 2nd argument UNREAD is non-nil, articles which are
@ -691,7 +691,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
(mail-sources nil)
(gnus-use-dribble-file nil)
(gnus-batch-mode t)
info group newsrc entry
info group newsrc unread
;; Disable verbose message.
gnus-novice-user gnus-large-newsgroup
gnus-options-subscribe gnus-auto-subscribed-groups
@ -703,11 +703,11 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
(setq newsrc (cdr gnus-newsrc-alist))
(while (setq info (pop newsrc))
(setq group (gnus-info-group info)
entry (gnus-gethash group gnus-newsrc-hashtb))
unread (gnus-group-unread group))
(when (and (<= (gnus-info-level info) gnus-level-subscribed)
(and (car entry)
(or (eq (car entry) t)
(not (zerop (car entry))))))
(and unread
(or (eq unread t)
(not (zerop unread)))))
(ignore-errors
(gnus-summary-read-group group nil t nil t))
(when (eq (current-buffer) (get-buffer gnus-summary-buffer))

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

@ -102,8 +102,8 @@ If FORCE is non-nil, replace the old ones."
;; Set up the menu.
(when (gnus-visual-p 'mailing-list-menu 'menu)
(gnus-mailing-list-make-menu-bar))
(gnus-add-minor-mode 'gnus-mailing-list-mode " Mailing-List"
gnus-mailing-list-mode-map)
(add-minor-mode 'gnus-mailing-list-mode " Mailing-List"
gnus-mailing-list-mode-map)
(gnus-run-hooks 'gnus-mailing-list-mode-hook))))
;;; Commands

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

@ -34,31 +34,31 @@
(require 'nnmail)
(defvar gnus-group-split-updated-hook nil
"Hook called just after nnmail-split-fancy is updated by
gnus-group-split-update.")
"Hook called just after `nnmail-split-fancy' is updated by
`gnus-group-split-update'.")
(defvar gnus-group-split-default-catch-all-group "mail.misc"
"Group name (or arbitrary fancy split) with default splitting rules.
Used by gnus-group-split and gnus-group-split-update as a fallback
Used by `gnus-group-split' and `gnus-group-split-update' as a fallback
split, in case none of the group-based splits matches.")
;;;###autoload
(defun gnus-group-split-setup (&optional auto-update catch-all)
"Set up the split for nnmail-split-fancy.
"Set up the split for `nnmail-split-fancy'.
Sets things up so that nnmail-split-fancy is used for mail
splitting, and defines the variable nnmail-split-fancy according with
group parameters.
If AUTO-UPDATE is non-nil (prefix argument accepted, if called
interactively), it makes sure nnmail-split-fancy is re-computed before
getting new mail, by adding gnus-group-split-update to
nnmail-pre-get-new-mail-hook.
getting new mail, by adding `gnus-group-split-update' to
`nnmail-pre-get-new-mail-hook'.
A non-nil CATCH-ALL replaces the current value of
gnus-group-split-default-catch-all-group. This variable is only used
`gnus-group-split-default-catch-all-group'. This variable is only used
by gnus-group-split-update, and only when its CATCH-ALL argument is
nil. This argument may contain any fancy split, that will be added as
the last split in a `|' split produced by gnus-group-split-fancy,
the last split in a `|' split produced by `gnus-group-split-fancy',
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
@ -78,8 +78,8 @@ match any of the group-specified splitting rules. See
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."
If CATCH-ALL is nil, `gnus-group-split-default-catch-all-group' is used
instead. This variable is set by `gnus-group-split-setup'."
(interactive)
(setq nnmail-split-fancy
(gnus-group-split-fancy
@ -89,10 +89,10 @@ 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.
"Use information from group parameters in order to split mail.
See `gnus-group-split-fancy' for more information.
gnus-group-split is a valid value for nnmail-split-methods."
`gnus-group-split' is a valid value for `nnmail-split-methods'."
(let (nnmail-split-fancy)
(gnus-group-split-update)
(nnmail-split-fancy)))

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

@ -53,10 +53,8 @@ Update the .newsrc.eld file to reflect the change of nntp server."
(save-excursion
;; Go through all groups and translate.
(let ((newsrc gnus-newsrc-alist)
(nntp-nov-gap nil)
info)
(while (setq info (pop newsrc))
(let ((nntp-nov-gap nil))
(dolist (info gnus-newsrc-alist)
(when (gnus-group-native-p (gnus-info-group info))
(gnus-move-group-to-server info from-server to-server))))))
@ -177,8 +175,7 @@ Update the .newsrc.eld file to reflect the change of nntp server."
(new-name (gnus-group-prefixed-name
(gnus-group-real-name group) to-server)))
(gnus-info-set-group info new-name)
(gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb)
gnus-newsrc-hashtb)
(gnus-sethash new-name (gnus-group-entry group) gnus-newsrc-hashtb)
(gnus-sethash group nil gnus-newsrc-hashtb))))
(provide 'gnus-move)

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

@ -255,7 +255,8 @@ See also the `mml-default-encrypt-method' variable."
:group 'gnus-message
:type 'boolean)
(defcustom gnus-confirm-mail-reply-to-news nil
(defcustom gnus-confirm-mail-reply-to-news (and gnus-novice-user
(not gnus-expert-user))
"If non-nil, Gnus requests confirmation when replying to news.
This is done because new users often reply by mistake when reading
news.
@ -288,6 +289,16 @@ If nil, the address field will always be empty after invoking
:group 'gnus-message
:type 'boolean)
(defcustom gnus-message-highlight-citation
t ;; gnus-treat-highlight-citation ;; gnus-cite dependency
"Enable highlighting of different citation levels in message-mode."
:version "23.0" ;; No Gnus
:group 'gnus-cite
:group 'gnus-message
:type 'boolean)
(autoload 'gnus-message-citation-mode "gnus-cite" nil t)
;;; Internal variables.
(defvar gnus-inhibit-posting-styles nil
@ -324,11 +335,7 @@ Thank you for your help in stamping out bugs.
")
(eval-and-compile
(autoload 'gnus-uu-post-news "gnus-uu" nil t)
(autoload 'news-setup "rnewspost")
(autoload 'news-reply-mode "rnewspost")
(autoload 'rmail-dont-reply-to "mail-utils")
(autoload 'rmail-output "rmailout"))
(autoload 'gnus-uu-post-news "gnus-uu" nil t))
;;;
@ -369,10 +376,10 @@ Thank you for your help in stamping out bugs.
;;; Internal functions.
(defun gnus-inews-make-draft ()
(defun gnus-inews-make-draft (articles)
`(lambda ()
(gnus-inews-make-draft-meta-information
,gnus-newsgroup-name ',gnus-article-reply)))
,(gnus-group-decoded-name gnus-newsgroup-name) ',articles)))
(defvar gnus-article-reply nil)
(defmacro gnus-setup-message (config &rest forms)
@ -421,7 +428,7 @@ Thank you for your help in stamping out bugs.
(not (string= ,group "")))
(push (cons
(intern gnus-draft-meta-information-header)
(gnus-inews-make-draft))
(gnus-inews-make-draft (or ,yanked ,article)))
message-required-headers))
(unwind-protect
(progn
@ -432,6 +439,9 @@ Thank you for your help in stamping out bugs.
(set (make-local-variable 'gnus-message-group-art)
(cons ,group ,article))
(set (make-local-variable 'gnus-newsgroup-name) ,group)
;; Enable highlighting of different citation levels
(when gnus-message-highlight-citation
(gnus-message-citation-mode 1))
(gnus-run-hooks 'gnus-message-setup-hook)
(if (eq major-mode 'message-mode)
(let ((mbl1 mml-buffer-list))
@ -449,12 +459,20 @@ Thank you for your help in stamping out bugs.
(run-hooks 'post-command-hook)
(set-buffer-modified-p nil))))
(defun gnus-inews-make-draft-meta-information (group article)
(concat "(\"" group "\" "
(if article (number-to-string
(if (listp article)
(car article)
article)) "\"\"")
(defun gnus-inews-make-draft-meta-information (group articles)
(when (numberp articles)
(setq articles (list articles)))
(concat "(\"" group "\""
(if articles
(concat " "
(mapconcat
(lambda (elem)
(number-to-string
(if (consp elem)
(car elem)
elem)))
articles " "))
"")
")"))
;;;###autoload
@ -519,7 +537,7 @@ Gcc: header for archiving purposes."
(gnus-make-local-hook 'message-header-hook)
(add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
(setq message-post-method
`(lambda (arg)
`(lambda (&optional arg)
(gnus-post-method arg ,gnus-newsgroup-name)))
(message-add-action
`(when (gnus-buffer-exists-p ,buffer)
@ -562,9 +580,9 @@ If ARG is 1, prompt for a group name to find the posting style."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Use posting style of group: "
gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-completing-read
"Use posting style of group: "
nil nil (gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
@ -593,9 +611,9 @@ network. The corresponding back end must have a 'request-post method."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Use group: "
gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-completing-read "Use group: "
nil nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
@ -615,8 +633,8 @@ a news."
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Newsgroup: " gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-completing-read "Newsgroup: " nil nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; make sure last viewed article doesn't affect posting styles:
@ -641,9 +659,9 @@ posting style."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Use group: "
gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-completing-read "Use group: "
nil nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; #### see comment in gnus-setup-message -- drv
@ -672,9 +690,9 @@ network. The corresponding back end must have a 'request-post method."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Use group: "
gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-completing-read "Use group: "
nil nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; #### see comment in gnus-setup-message -- drv
@ -682,9 +700,9 @@ network. The corresponding back end must have a 'request-post method."
(progn
(message-news (gnus-group-real-name gnus-newsgroup-name))
(set (make-local-variable 'gnus-discouraged-post-methods)
(delq
(remove
(car (gnus-find-method-for-group gnus-newsgroup-name))
(copy-sequence gnus-discouraged-post-methods))))))
gnus-discouraged-post-methods)))))
(save-excursion
(set-buffer buffer)
(setq gnus-newsgroup-name group)))))
@ -699,8 +717,8 @@ a news."
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Newsgroup: " gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-completing-read "Newsgroup: " nil nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; make sure last viewed article doesn't affect posting styles:
@ -784,12 +802,10 @@ Uses the process-prefix convention. If given the symbolic
prefix `a', cancel using the standard posting method; if not
post using the current select method."
(interactive (gnus-interactive "P\ny"))
(let ((articles (gnus-summary-work-articles n))
(message-post-method
(let ((message-post-method
`(lambda (arg)
(gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))
article)
(while (setq article (pop articles))
(gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))))
(dolist (article (gnus-summary-work-articles n))
(when (gnus-summary-select-article t nil nil article)
(when (gnus-eval-in-buffer-window gnus-original-article-buffer
(message-cancel-news))
@ -1254,14 +1270,12 @@ For the `inline' alternatives, also see the variable
(with-current-buffer gnus-original-article-buffer
(nnmail-fetch-field "to"))))
current-prefix-arg))
(let ((articles (gnus-summary-work-articles n))
article)
(while (setq article (pop articles))
(gnus-summary-select-article nil nil nil article)
(save-excursion
(set-buffer gnus-original-article-buffer)
(message-resend address))
(gnus-summary-mark-article-as-forwarded article))))
(dolist (article (gnus-summary-work-articles n))
(gnus-summary-select-article nil nil nil article)
(save-excursion
(set-buffer gnus-original-article-buffer)
(message-resend address))
(gnus-summary-mark-article-as-forwarded article)))
;; From: Matthieu Moy <Matthieu.Moy@imag.fr>
(defun gnus-summary-resend-message-edit ()
@ -1322,37 +1336,35 @@ The current group name will be inserted at \"%s\".")
(defun gnus-summary-mail-crosspost-complaint (n)
"Send a complaint about crossposting to the current article(s)."
(interactive "P")
(let ((articles (gnus-summary-work-articles n))
article)
(while (setq article (pop articles))
(set-buffer gnus-summary-buffer)
(gnus-summary-goto-subject article)
(let ((group (gnus-group-real-name gnus-newsgroup-name))
newsgroups followup-to)
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
(if (and (<= (length (message-tokenize-header
(setq newsgroups
(mail-fetch-field "newsgroups"))
", "))
1)
(or (not (setq followup-to (mail-fetch-field "followup-to")))
(not (member group (message-tokenize-header
followup-to ", ")))))
(if followup-to
(gnus-message 1 "Followup-to restricted")
(gnus-message 1 "Not a crossposted article"))
(set-buffer gnus-summary-buffer)
(gnus-summary-reply-with-original 1)
(set-buffer gnus-message-buffer)
(message-goto-body)
(insert (format gnus-crosspost-complaint newsgroups group))
(message-goto-subject)
(re-search-forward " *$")
(replace-match " (crosspost notification)" t t)
(gnus-deactivate-mark)
(when (gnus-y-or-n-p "Send this complaint? ")
(message-send-and-exit)))))))
(dolist (article (gnus-summary-work-articles n))
(set-buffer gnus-summary-buffer)
(gnus-summary-goto-subject article)
(let ((group (gnus-group-real-name gnus-newsgroup-name))
newsgroups followup-to)
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
(if (and (<= (length (message-tokenize-header
(setq newsgroups
(mail-fetch-field "newsgroups"))
", "))
1)
(or (not (setq followup-to (mail-fetch-field "followup-to")))
(not (member group (message-tokenize-header
followup-to ", ")))))
(if followup-to
(gnus-message 1 "Followup-to restricted")
(gnus-message 1 "Not a crossposted article"))
(set-buffer gnus-summary-buffer)
(gnus-summary-reply-with-original 1)
(set-buffer gnus-message-buffer)
(message-goto-body)
(insert (format gnus-crosspost-complaint newsgroups group))
(message-goto-subject)
(re-search-forward " *$")
(replace-match " (crosspost notification)" t t)
(gnus-deactivate-mark)
(when (gnus-y-or-n-p "Send this complaint? ")
(message-send-and-exit))))))
(defun gnus-mail-parse-comma-list ()
(let (accumulated
@ -1401,7 +1413,7 @@ The current group name will be inserted at \"%s\".")
(not (gnus-group-read-only-p group)))
(setq group (read-string "Put in group: " nil (gnus-writable-groups))))
(when (gnus-gethash group gnus-newsrc-hashtb)
(when (gnus-group-entry group)
(error "No such group: %s" group))
(save-excursion
(save-restriction
@ -1667,11 +1679,13 @@ this is a reply."
(concat "^" (regexp-quote mail-header-separator) "$")
nil t)
(replace-match "" t t ))
(unless (setq group-art
(gnus-request-accept-article group method t t))
(when (or (not (gnus-check-backend-function
'request-accept-article group))
(not (setq group-art
(gnus-request-accept-article
group method t t))))
(gnus-message 1 "Couldn't store article in group %s: %s"
group (gnus-status-message method))
(sit-for 2))
group (gnus-status-message method)))
(when (and group-art
;; FIXME: Should gcc-mark-as-read work when
;; Gnus is not running?
@ -1709,8 +1723,13 @@ this is a reply."
(defun gnus-inews-insert-archive-gcc (&optional group)
"Insert the Gcc to say where the article is to be archived."
(setq group (cond (group
(gnus-group-decoded-name group))
(gnus-newsgroup-name
(gnus-group-decoded-name gnus-newsgroup-name))
(t
"")))
(let* ((var gnus-message-archive-group)
(group (or group gnus-newsgroup-name ""))
(gcc-self-val
(and gnus-newsgroup-name
(not (equal gnus-newsgroup-name ""))
@ -1892,6 +1911,13 @@ this is a reply."
((eq element 'x-face-file)
(setq element 'x-face
filep t)))
;; Post-processing for the signature posting-style:
(and (eq element 'signature) filep
message-signature-directory
;; don't actually use the signature directory
;; if message-signature-file contains a path.
(not (file-name-directory v))
(setq v (nnheader-concat message-signature-directory v)))
;; Get the contents of file elems.
(when (and filep v)
(setq v (with-temp-buffer

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

@ -129,11 +129,12 @@ valid issuer, which is much faster if you are selective about the issuers."
(defun gnus-fill-real-hashtb ()
"Fill up a hash table with the real-name mappings from the user's active file."
(setq gnus-nocem-real-group-hashtb (gnus-make-hashtable
(length gnus-newsrc-alist)))
(if (hash-table-p gnus-nocem-real-group-hashtb)
(clrhash gnus-nocem-real-group-hashtb)
(setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal)))
(mapcar (lambda (group)
(setq group (gnus-group-real-name (car group)))
(gnus-sethash group t gnus-nocem-real-group-hashtb))
(puthash group t gnus-nocem-real-group-hashtb))
gnus-newsrc-alist))
;;;###autoload
@ -191,7 +192,7 @@ valid issuer, which is much faster if you are selective about the issuers."
(and gnus-nocem-check-from
(let ((case-fold-search t))
(catch 'ok
(mapcar
(mapc
(lambda (author)
(if (consp author)
(setq author (car author)))
@ -237,11 +238,11 @@ valid issuer, which is much faster if you are selective about the issuers."
(gnus-request-article-this-buffer (mail-header-number header) group)
(goto-char (point-min))
(when (re-search-forward
"-----BEGIN PGP\\( SIGNED\\)? MESSAGE-----"
"-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----"
nil t)
(delete-region (point-min) (match-beginning 0)))
(when (re-search-forward
"-----END PGP \\(MESSAGE\\|SIGNATURE\\)-----\n?"
"-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?"
nil t)
(delete-region (match-end 0) (point-max)))
(goto-char (point-min))
@ -304,34 +305,26 @@ 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-nocem-real-group-hashtb))
(read buf)))))
(setq group (gnus-group-real-name (symbol-name (read buf))))
(gethash group gnus-nocem-real-group-hashtb)))
;; An error.
)
((not (symbolp group))
;; Ignore invalid entries.
)
((not (boundp group))
;; Make sure all entries in the hashtb are bound.
(set group nil))
(t
(when (gnus-gethash (gnus-group-real-name (symbol-name group))
gnus-nocem-real-group-hashtb)
;; Valid group.
(beginning-of-line)
(while (eq (char-after) ?\t)
(forward-line -1))
(setq id (buffer-substring (point) (1- (search-forward "\t"))))
(unless (if gnus-nocem-hashtb
(gnus-gethash id gnus-nocem-hashtb)
(setq gnus-nocem-hashtb (gnus-make-hashtable))
nil)
;; only store if not already present
(gnus-sethash id t gnus-nocem-hashtb)
(push id ncm))
(forward-line 1)
(while (eq (char-after) ?\t)
(forward-line 1))))))
;; Valid group.
(beginning-of-line)
(while (eq (char-after) ?\t)
(forward-line -1))
(setq id (buffer-substring (point) (1- (search-forward "\t"))))
(unless (if (hash-table-p gnus-nocem-hashtb)
(gethash id gnus-nocem-hashtb)
(setq gnus-nocem-hashtb (make-hash-table :test 'equal))
nil)
;; only store if not already present
(puthash id t gnus-nocem-hashtb)
(push id ncm))
(forward-line 1)
(while (eq (char-after) ?\t)
(forward-line 1)))))
(when ncm
(setq gnus-nocem-touched-alist t)
(push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
@ -370,7 +363,9 @@ valid issuer, which is much faster if you are selective about the issuers."
(prev pprev)
(expiry (days-to-time gnus-nocem-expiry-wait))
entry)
(setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51)))
(if (hash-table-p gnus-nocem-hashtb)
(clrhash gnus-nocem-hashtb)
(setq gnus-nocem-hashtb (make-hash-table :test 'equal)))
(while (setq entry (car alist))
(if (not (time-less-p (time-since (car entry)) expiry))
;; This entry has expired, so we remove it.
@ -379,7 +374,7 @@ valid issuer, which is much faster if you are selective about the issuers."
;; This is ok, so we enter it into the hashtable.
(setq entry (cdr entry))
(while entry
(gnus-sethash (car entry) t gnus-nocem-hashtb)
(puthash (car entry) t gnus-nocem-hashtb)
(setq entry (cdr entry))))
(setq alist (cdr alist)))))
@ -397,7 +392,7 @@ valid issuer, which is much faster if you are selective about the issuers."
(defun gnus-nocem-unwanted-article-p (id)
"Say whether article ID in the current group is wanted."
(and gnus-nocem-hashtb
(gnus-gethash id gnus-nocem-hashtb)))
(gethash id gnus-nocem-hashtb)))
(provide 'gnus-nocem)

213
lisp/gnus/gnus-picon.el
View File

@ -74,6 +74,15 @@ Some people may want to add \"unknown\" to this list."
:type '(repeat string)
:group 'gnus-picon)
(defcustom gnus-picon-style 'inline
"How should picons be displayed.
If `inline', the textual representation is replaced. If `right', picons are
added right to the textual representation."
;; FIXME: `right' needs improvement for XEmacs.
:type '(choice (const inline)
(const right))
:group 'gnus-picon)
(defface gnus-picon-xbm '((t (:foreground "black" :background "white")))
"Face to show xbm picon in."
:group 'gnus-picon)
@ -139,14 +148,17 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
file
nil)))
(defun gnus-picon-insert-glyph (glyph category)
(defun gnus-picon-insert-glyph (glyph category &optional nostring)
"Insert GLYPH into the buffer.
GLYPH can be either a glyph or a string."
GLYPH can be either a glyph or a string. When NOSTRING, no textual
replacement is added."
;; Using NOSTRING prevents wrong BBDB entries with `gnus-picon-style' set to
;; 'right.
(if (stringp glyph)
(insert glyph)
(gnus-add-wash-type category)
(gnus-add-image category (car glyph))
(gnus-put-image (car glyph) (cdr glyph) category)))
(gnus-put-image (car glyph) (unless nostring (cdr glyph)) category)))
(defun gnus-picon-create-glyph (file)
(or (cdr (assoc file gnus-picon-glyph-alist))
@ -157,87 +169,107 @@ GLYPH can be either a glyph or a string."
(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))))
(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 len)
(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))
(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))))))))
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
(case gnus-picon-style
(right
(when (= (length addresses) 1)
(setq len (apply '+ (mapcar (lambda (x)
(condition-case nil
(car (image-size (car x)))
(error 0))) spec)))
(when (> len 0)
(goto-char (point-at-eol))
(insert (propertize
" " 'display
(cons 'space
(list :align-to (- (window-width) 1 len))))))
(goto-char (point-at-eol))
(setq point (point-at-eol))
(dolist (image spec)
(unless (stringp image)
(goto-char point)
(gnus-picon-insert-glyph image category 'nostring)))))
(inline
(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))))))))
(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:
@ -251,10 +283,9 @@ 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)))
))
(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 ()
@ -263,11 +294,10 @@ 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)))
))
(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 ()
@ -276,11 +306,10 @@ 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")))
))
(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)

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

@ -307,7 +307,7 @@ LIST1 and LIST2 have to be sorted over <."
(cdr top)))
(defun gnus-compress-sequence (numbers &optional always-list)
"Convert list of numbers to a list of ranges or a single range.
"Convert sorted list of numbers to a list of ranges or a single range.
If ALWAYS-LIST is non-nil, this function will always release a list of
ranges."
(let* ((first (car numbers))

334
lisp/gnus/gnus-registry.el
View File

@ -25,11 +25,11 @@
;;; 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
;; This is the gnus-registry.el package, which works with all
;; backends, not just nnmail (e.g. NNTP). 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
@ -71,14 +71,19 @@
:version "22.1"
:group 'gnus)
(defvar gnus-registry-hashtb nil
(defvar gnus-registry-hashtb (make-hash-table
:size 256
:test 'equal)
"*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."
(defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$")
"List of groups that gnus-registry-split-fancy-with-parent won't return.
The group names are matched, they don't have to be fully
qualified. This parameter tells the Registry 'never split a
message into a group that matches one of these, regardless of
references.'"
:group 'gnus-registry
:type '(repeat string))
:type '(repeat regexp))
(defcustom gnus-registry-install nil
"Whether the registry should be installed."
@ -87,7 +92,8 @@ The group names are matched, they don't have to be fully qualified."
(defcustom gnus-registry-clean-empty t
"Whether the empty registry entries should be deleted.
Registry entries are considered empty when they have no groups."
Registry entries are considered empty when they have no groups
and no extra data."
:group 'gnus-registry
:type 'boolean)
@ -121,7 +127,10 @@ way."
:group 'gnus-registry
:type 'boolean)
(defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
(defcustom gnus-registry-cache-file
(nnheader-concat
(or gnus-dribble-directory gnus-home-directory "~/")
".gnus.registry.eld")
"File where the Gnus registry will be stored."
:group 'gnus-registry
:type 'file)
@ -132,13 +141,6 @@ way."
:type '(radio (const :format "Unlimited " nil)
(integer :format "Maximum number: %v")))
;; 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))
@ -210,7 +212,7 @@ way."
;; Replace the existing startup file with the temp file.
(rename-file working-file startup-file t)
(set-file-modes startup-file setmodes)))
(gnus-set-file-modes startup-file setmodes)))
(condition-case nil
(delete-file working-file)
(file-error nil)))))
@ -221,7 +223,7 @@ way."
;; 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)
(gnus-message 7 "Adding whitespace to %s" filename)
(save-excursion
(goto-char (point-min))
(while (re-search-forward "^(\\|(\\\"" nil t)
@ -244,10 +246,12 @@ way."
;; 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
(gnus-hashtable-to-alist
gnus-registry-hashtb)))
;; now trim and clean text properties from the registry appropriately
(setq gnus-registry-alist
(gnus-registry-remove-alist-text-properties
(gnus-registry-trim
(gnus-hashtable-to-alist
gnus-registry-hashtb))))
;; really save
(gnus-registry-cache-save)
(setq gnus-registry-entry-caching caching)
@ -256,11 +260,36 @@ way."
(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)))
(when (stringp key)
(dolist (group (gnus-registry-fetch-groups key))
(when (gnus-parameter-registry-ignore group)
(gnus-message
10
"gnus-registry: deleted ignored group %s from key %s"
group key)
(gnus-registry-delete-group key group)))
(unless (gnus-registry-group-count key)
(gnus-registry-delete-id key))
(unless (or
(gnus-registry-fetch-group key)
;; TODO: look for specific extra data here!
;; in this example, we look for 'label
(gnus-registry-fetch-extra key 'label))
(incf count)
(gnus-registry-delete-id key))
(unless (stringp key)
(gnus-message
10
"gnus-registry key %s was not a string, removing"
key)
(gnus-registry-delete-id key))))
gnus-registry-hashtb)
count))
@ -269,8 +298,20 @@ way."
(setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
(setq gnus-registry-dirty nil))
(defun gnus-registry-remove-alist-text-properties (v)
"Remove text properties from all strings in alist."
(if (stringp v)
(gnus-string-remove-all-properties v)
(if (and (listp v) (listp (cdr v)))
(mapcar 'gnus-registry-remove-alist-text-properties v)
(if (and (listp v) (stringp (cdr v)))
(cons (gnus-registry-remove-alist-text-properties (car v))
(gnus-registry-remove-alist-text-properties (cdr v)))
v))))
(defun gnus-registry-trim (alist)
"Trim alist to size, using gnus-registry-max-entries."
"Trim alist to size, using gnus-registry-max-entries.
Also, drop all gnus-registry-ignored-groups matches."
(if (null gnus-registry-max-entries)
alist ; just return the alist
;; else, when given max-entries, trim the alist
@ -283,27 +324,28 @@ way."
(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
trim-length
(sort alist
(lambda (a b)
(time-less-p
(cdr (gethash (car a) timehash))
(cdr (gethash (car b) timehash))))))))))
(nthcdr
trim-length
(sort alist
(lambda (a b)
(time-less-p
(or (cdr (gethash (car a) timehash)) '(0 0 0))
(or (cdr (gethash (car b) timehash)) '(0 0 0))))))))))
(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))
(subject (gnus-string-remove-all-properties
(gnus-registry-simplify-subject
(mail-header-subject data-header))))
(sender (gnus-string-remove-all-properties (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"
(gnus-message 7 "Registry: article %s %s from %s to %s"
id
(if method "respooling" "going")
from
@ -321,7 +363,7 @@ way."
(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"
(gnus-message 7 "Registry: article %s spooled to %s"
id
group)
(gnus-registry-add-group id group subject sender)))
@ -334,36 +376,46 @@ 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)
This function tracks ALL backends, unlike
`nnmail-split-fancy-with-parent' which tracks only nnmail
messages.
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.
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, unless it matches one of the entries in
gnus-registry-unfollowed-groups or
nnmail-split-fancy-with-parent-ignore-groups.
See the Info node `(gnus)Fancy Mail Splitting' for more details."
(let ((refstr (or (message-fetch-field "references")
(message-fetch-field "in-reply-to")))
(let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string
(reply-to (message-fetch-field "in-reply-to")) ; grab reply-to
;; now, if reply-to is valid, append it to the References
(refstr (if reply-to
(concat refstr " " reply-to)
refstr))
(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))
res)
;; the references string must be valid and parse to valid references
(if (and refstr (gnus-extract-references refstr))
(dolist (reference (nreverse (gnus-extract-references refstr)))
(setq res (or (gnus-registry-fetch-group reference) 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)))
;; 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")))
(let ((sender (gnus-string-remove-all-properties(message-fetch-field "from")))
(subject (gnus-string-remove-all-properties
(gnus-registry-simplify-subject
(message-fetch-field "subject"))))
(single-match t))
(when (and single-match
(gnus-registry-track-sender-p)
@ -379,13 +431,14 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(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")))))
(when (and sender res)
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
(if gnus-registry-track-extra 7 9)
"%s (extra tracking) traced sender %s to group %s"
"gnus-registry-split-fancy-with-parent"
sender
res)))))
gnus-registry-hashtb))
(when (and single-match
(gnus-registry-track-subject-p)
@ -402,24 +455,26 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(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")))))
(when (and subject res)
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
(if gnus-registry-track-extra 7 9)
"%s (extra tracking) traced subject %s to group %s"
"gnus-registry-split-fancy-with-parent"
subject
res)))))
gnus-registry-hashtb))
(unless single-match
(gnus-message
5
3
"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 refstr res)
(gnus-message
5
"gnus-registry-split-fancy-with-parent traced %s to group %s"
refstr res))
(when (and res gnus-registry-use-long-group-names)
(let ((m1 (gnus-find-method-for-group res))
@ -436,12 +491,45 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(setq res short-res))
;; else...
(gnus-message
5
7
"gnus-registry-split-fancy-with-parent ignored foreign group %s"
res)
(setq res nil))))
res))
(defun gnus-registry-wash-for-keywords (&optional force)
(interactive)
(let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
word words)
(if (or (not (gnus-registry-fetch-extra id 'keywords))
force)
(save-excursion
(set-buffer gnus-article-buffer)
(article-goto-body)
(save-window-excursion
(save-restriction
(narrow-to-region (point) (point-max))
(with-syntax-table gnus-adaptive-word-syntax-table
(while (re-search-forward "\\b\\w+\\b" nil t)
(setq word (gnus-registry-remove-alist-text-properties
(downcase (buffer-substring
(match-beginning 0) (match-end 0)))))
(if (> (length word) 3)
(push word words))))))
(gnus-registry-store-extra-entry id 'keywords words)))))
(defun gnus-registry-find-keywords (keyword)
(interactive "skeyword: ")
(let (articles)
(maphash
(lambda (key value)
(when (gnus-registry-grep-in-list
keyword
(cdr (gnus-registry-fetch-extra key 'keywords)))
(push key articles)))
gnus-registry-hashtb)
articles))
(defun gnus-registry-register-message-ids ()
"Register the Message-ID of every article in the group"
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
@ -472,17 +560,19 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
"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)))))
(gnus-string-remove-all-properties
(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))))
(gnus-string-remove-all-properties
(mail-header-from (gnus-data-header
(assoc article (gnus-data-list nil)))))
nil))
(defun gnus-registry-grep-in-list (word list)
@ -491,9 +581,36 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(mapcar 'not
(mapcar
(lambda (x)
(string-match x word))
(string-match word x))
list)))))
;;; if this extends to more than 'flags, it should be improved to be more generic.
(defun gnus-registry-fetch-extra-flags (id)
"Get the flags of a message, based on the message ID.
Returns a list of symbol flags or nil."
(car-safe (cdr (gnus-registry-fetch-extra id 'flags))))
(defun gnus-registry-has-extra-flag (id flag)
"Checks if a message has `flag', based on the message ID."
(memq flag (gnus-registry-fetch-extra-flags id)))
(defun gnus-registry-store-extra-flags (id &rest flag-list)
"Set the flags of a message, based on the message ID.
The `flag-list' can be nil, in which case no flags are left."
(gnus-registry-store-extra-entry id 'flags (list flag-list)))
(defun gnus-registry-delete-extra-flags (id &rest flag-delete-list)
"Delete the message flags in `flag-delete-list', based on the message ID."
(let ((flags (gnus-registry-fetch-extra-flags id)))
(when flags
(dolist (flag flag-delete-list)
(setq flags (delq flag flags))))
(gnus-registry-store-extra-flags id (car flags))))
(defun gnus-registry-delete-all-extra-flags (id)
"Delete all the flags for a message ID."
(gnus-registry-store-extra-flags id nil))
(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."
@ -551,11 +668,20 @@ The message must have at least one group name."
gnus-registry-hashtb)
(setq gnus-registry-dirty t)))))
(defun gnus-registry-delete-extra-entry (id key)
"Delete a specific entry in the extras field of the registry entry for id."
(gnus-registry-store-extra-entry id key nil))
(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)))))
;; all the entries except the one for `key'
(the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
(alist (if value
(gnus-registry-remove-alist-text-properties
(cons (cons key value)
the-rest))
the-rest)))
(gnus-registry-store-extra id alist)))
(defun gnus-registry-fetch-group (id)
@ -570,6 +696,23 @@ Returns the first place where the trail finds a group name."
crumb
(gnus-group-short-name crumb))))))))
(defun gnus-registry-fetch-groups (id)
"Get the groups of a message, based on the message ID."
(let ((trail (gethash id gnus-registry-hashtb))
groups)
(dolist (crumb trail)
(when (stringp crumb)
;; push the group name into the list
(setq
groups
(cons
(if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
crumb
(gnus-group-short-name crumb))
groups))))
;; return the list of groups
groups))
(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)))
@ -579,12 +722,11 @@ Returns the first place where the trail finds a group name."
(defun gnus-registry-delete-group (id group)
"Delete a group for a message, based on the message ID."
(when group
(when id
(when (and group id)
(let ((trail (gethash id gnus-registry-hashtb))
(group (gnus-group-short-name group)))
(short-group (gnus-group-short-name group)))
(puthash id (if trail
(delete group trail)
(delete short-group (delete group trail))
nil)
gnus-registry-hashtb))
;; now, clear the entry if there are no more groups
@ -593,7 +735,7 @@ Returns the first place where the trail finds a group name."
(gnus-registry-delete-id id)))
;; is this ID still in the registry?
(when (gethash id gnus-registry-hashtb)
(gnus-registry-store-extra-entry id 'mtime (current-time))))))
(gnus-registry-store-extra-entry id 'mtime (current-time)))))
(defun gnus-registry-delete-id (id)
"Delete a message ID from the registry."

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

@ -128,7 +128,7 @@ It accepts the same format specs that `gnus-summary-line-format' does."
;; Set up the menu.
(when (gnus-visual-p 'pick-menu 'menu)
(gnus-pick-make-menu-bar))
(gnus-add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
(add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
(gnus-run-hooks 'gnus-pick-mode-hook))))
(defun gnus-pick-setup-message ()
@ -360,7 +360,7 @@ This must be bound to a button-down mouse event."
;; Set up the menu.
(when (gnus-visual-p 'binary-menu 'menu)
(gnus-binary-make-menu-bar))
(gnus-add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
(add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
(gnus-run-hooks 'gnus-binary-mode-hook))))
(defun gnus-binary-display-article (article &optional all-header)
@ -719,7 +719,7 @@ Two predefined functions are available:
(unless (zerop level)
(gnus-tree-indent level)
(insert (cadr gnus-tree-parent-child-edges))
(setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
(setq col (- (setq beg (point)) (point-at-bol) 1))
;; Draw "|" lines upwards.
(while (progn
(forward-line -1)
@ -743,7 +743,7 @@ Two predefined functions are available:
(defsubst gnus-tree-indent-vertical ()
(let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
(- (point) (gnus-point-at-bol)))))
(- (point) (point-at-bol)))))
(when (> len 0)
(insert (make-string len ? )))))
@ -1016,11 +1016,11 @@ The following commands are available:
(setq button (car buttons)
buttons (cdr buttons))
(if (stringp button)
(gnus-set-text-properties
(set-text-properties
(point)
(prog2 (insert button) (point) (insert " "))
(list 'face gnus-carpal-header-face))
(gnus-set-text-properties
(set-text-properties
(point)
(prog2 (insert (car button)) (point) (insert " "))
(list 'gnus-callback (cdr button)

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

@ -37,8 +37,6 @@
(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
@ -149,9 +147,15 @@ will be expired along with non-matching score entries."
:type 'boolean)
(defcustom gnus-decay-scores nil
"*If non-nil, decay non-permanent scores."
"*If non-nil, decay non-permanent scores.
If it is a regexp, only decay score files matching regexp."
:group 'gnus-score-decay
:type 'boolean)
:type `(choice (const :tag "never" nil)
(const :tag "always" t)
(const :tag "adaptive score files"
,(concat "\\." gnus-adaptive-file-suffix "\\'"))
(regexp)))
(defcustom gnus-decay-score-function 'gnus-decay-score
"*Function called to decay a score.
@ -318,6 +322,13 @@ If this variable is nil, exact matching will always be used."
:group 'gnus-score-files
:type 'regexp)
(defcustom gnus-adaptive-pretty-print nil
"If non-nil, adaptive score files fill are pretty printed."
:group 'gnus-score-files
:group 'gnus-score-adapt
:version "23.0" ;; No Gnus
:type 'boolean)
(defcustom gnus-score-default-header nil
"Default header when entering new scores.
@ -411,6 +422,18 @@ If nil, the user will be asked for a duration."
:group 'gnus-score-various
:type 'boolean)
(defcustom gnus-inhibit-slow-scoring nil
"Inhibit slow scoring, e.g. scoring on headers or body.
If a regexp, scoring on headers or body is inhibited if the group
matches the regexp. If it is t, scoring on headers or body is
inhibited for all groups."
:group 'gnus-score-various
:version "23.0" ;; No Gnus
:type '(choice (const :tag "All" nil)
(const :tag "None" t)
regexp))
;; Internal variables.
@ -753,7 +776,7 @@ file for the command instead of the current score file."
(setq i (1+ i))))
(goto-char (point-min))
;; display ourselves in a small window at the bottom
(gnus-appt-select-lowest-window)
(gnus-select-lowest-window)
(if (< (/ (window-height) 2) window-min-height)
(switch-to-buffer "*Score Help*")
(split-window)
@ -1099,6 +1122,16 @@ 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-all-score ()
"Edit the all.SCORE file."
(interactive)
(find-file (gnus-score-file-name "all"))
(gnus-score-mode)
(setq gnus-score-edit-exit-function 'gnus-score-edit-done)
(gnus-message
4 (substitute-command-keys
"\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
(defun gnus-score-edit-file (file)
"Edit a score file."
(interactive
@ -1128,9 +1161,9 @@ If FORMAT, also format the current score file."
(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))
(if (and (re-search-backward reg (point-at-bol) t)
(re-search-forward reg (point-at-eol) t))
(buffer-substring (point) (point-at-eol))
nil))))
(if (or (not file)
(string-match "\\<\\(non-file rule\\|A file\\)\\>" file)
@ -1209,7 +1242,9 @@ If FORMAT, also format the current score file."
(decay (car (gnus-score-get 'decay alist)))
(eval (car (gnus-score-get 'eval alist))))
;; Perform possible decays.
(when (and gnus-decay-scores
(when (and (if (stringp gnus-decay-scores)
(string-match gnus-decay-scores file)
gnus-decay-scores)
(or cached (file-exists-p file))
(or (not decay)
(gnus-decay-scores alist decay)))
@ -1219,8 +1254,7 @@ If FORMAT, also format the current score file."
;; files.
(when (and files (not global))
(setq lists (apply 'append lists
(mapcar (lambda (file)
(gnus-score-load-file file))
(mapcar 'gnus-score-load-file
(if adapt-file (cons adapt-file files)
files)))))
(when (and eval (not global))
@ -1412,12 +1446,13 @@ If FORMAT, also format the current score file."
(setq score (setcdr entry (gnus-delete-alist 'touched score)))
(erase-buffer)
(let (emacs-lisp-mode-hook)
(if (string-match
(concat (regexp-quote gnus-adaptive-file-suffix) "$")
file)
;; This is an adaptive score file, so we do not run
;; it through `pp'. These files can get huge, and
;; are not meant to be edited by human hands.
(if (and (not gnus-adaptive-pretty-print)
(string-match
(concat (regexp-quote gnus-adaptive-file-suffix) "$")
file))
;; This is an adaptive score file, so we do not run it through
;; `pp' unless requested. These files can get huge, and are
;; not meant to be edited by human hands.
(gnus-prin1 score)
;; This is a normal score file, so we print it very
;; prettily.
@ -1518,8 +1553,21 @@ If FORMAT, also format the current score file."
(length (gnus-score-get header score)))
scores)))
;; Call the scoring function for this type of "header".
(when (setq new (funcall (nth 2 entry) scores header
now expire trace))
(when (if (and gnus-inhibit-slow-scoring
(if (and (stringp gnus-inhibit-slow-scoring)
;; Always true here?
;; (stringp gnus-newsgroup-name)
(string-match gnus-inhibit-slow-scoring
gnus-newsgroup-name))
t
nil)
(> 0 (nth 1 (assoc header gnus-header-index))))
(progn
(gnus-message
7 "Scoring on headers or body skipped.")
nil)
(setq new (funcall (nth 2 entry) scores header
now expire trace)))
(push new news))))
(when (gnus-buffer-live-p gnus-summary-buffer)
(let ((scored gnus-newsgroup-scored))
@ -1860,7 +1908,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(goto-char (point-min))
(if (= dmt ?e)
(while (funcall search-func match nil t)
(and (= (gnus-point-at-bol)
(and (= (point-at-bol)
(match-beginning 0))
(= (progn (end-of-line) (point))
(match-end 0))
@ -2030,7 +2078,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(funcall search-func match nil t))
;; Is it really exact?
(and (eolp)
(= (gnus-point-at-bol) (match-beginning 0))
(= (point-at-bol) (match-beginning 0))
;; Yup.
(progn
(setq found (setq arts (get-text-property
@ -2120,7 +2168,7 @@ score in `gnus-newsgroup-scored' by SCORE."
(goto-char (point-min))
(while (and (not (eobp))
(search-forward match nil t))
(when (and (= (gnus-point-at-bol) (match-beginning 0))
(when (and (= (point-at-bol) (match-beginning 0))
(eolp))
(setq found (setq arts (get-text-property (point) 'articles)))
(if trace
@ -2194,23 +2242,19 @@ score in `gnus-newsgroup-scored' by SCORE."
(defun gnus-enter-score-words-into-hashtb (hashtb)
;; Find all the words in the buffer and enter them into
;; the hashtable.
(let ((syntab (syntax-table))
word val)
(let (word val)
(goto-char (point-min))
(unwind-protect
(progn
(set-syntax-table gnus-adaptive-word-syntax-table)
(while (re-search-forward "\\b\\w+\\b" nil t)
(setq val
(gnus-gethash
(setq word (downcase (buffer-substring
(match-beginning 0) (match-end 0))))
hashtb))
(gnus-sethash
word
(append (get-text-property (gnus-point-at-eol) 'articles) val)
hashtb)))
(set-syntax-table syntab))
(with-syntax-table gnus-adaptive-word-syntax-table
(while (re-search-forward "\\b\\w+\\b" nil t)
(setq val
(gnus-gethash
(setq word (downcase (buffer-substring
(match-beginning 0) (match-end 0))))
hashtb))
(gnus-sethash
word
(append (get-text-property (point-at-eol) 'articles) val)
hashtb)))
;; Make all the ignorable words ignored.
(let ((ignored (append gnus-ignored-adaptive-words
(if gnus-adaptive-word-no-group-words
@ -2313,39 +2357,35 @@ score in `gnus-newsgroup-scored' by SCORE."
(let* ((hashtb (gnus-make-hashtable 1000))
(date (date-to-day (current-time-string)))
(data gnus-newsgroup-data)
(syntab (syntax-table))
word d score val)
(unwind-protect
(progn
(set-syntax-table gnus-adaptive-word-syntax-table)
;; Go through all articles.
(while (setq d (pop data))
(when (and
(not (gnus-data-pseudo-p d))
(setq score
(cdr (assq
(gnus-data-mark d)
gnus-adaptive-word-score-alist))))
;; This article has a mark that should lead to
;; adaptive word rules, so we insert the subject
;; and find all words in that string.
(insert (mail-header-subject (gnus-data-header d)))
(downcase-region (point-min) (point-max))
(goto-char (point-min))
(while (re-search-forward "\\b\\w+\\b" nil t)
;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0))
hashtb))
(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))
(with-syntax-table gnus-adaptive-word-syntax-table
;; Go through all articles.
(while (setq d (pop data))
(when (and
(not (gnus-data-pseudo-p d))
(setq score
(cdr (assq
(gnus-data-mark d)
gnus-adaptive-word-score-alist))))
;; This article has a mark that should lead to
;; adaptive word rules, so we insert the subject
;; and find all words in that string.
(insert (mail-header-subject (gnus-data-header d)))
(downcase-region (point-min) (point-max))
(goto-char (point-min))
(while (re-search-forward "\\b\\w+\\b" nil t)
;; Put the word and score into the hashtb.
(setq val (gnus-gethash (setq word (match-string 0))
hashtb))
(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))))
;; Make all the ignorable words ignored.
(let ((ignored (append gnus-ignored-adaptive-words
(if gnus-adaptive-word-no-group-words
@ -2373,7 +2413,8 @@ score in `gnus-newsgroup-scored' by SCORE."
(when winconf
(set-window-configuration winconf))
(gnus-score-remove-from-cache bufnam)
(gnus-score-load-file bufnam)))
(gnus-score-load-file bufnam)
(run-hooks 'gnus-score-edit-done-hook)))
(defun gnus-score-find-trace ()
"Find all score rules that applies to the current article."
@ -2401,6 +2442,11 @@ score in `gnus-newsgroup-scored' by SCORE."
(interactive)
(bury-buffer nil)
(gnus-summary-expand-window)))
(local-set-key "k"
(lambda ()
(interactive)
(kill-buffer (current-buffer))
(gnus-summary-expand-window)))
(local-set-key "e" (lambda ()
"Run `gnus-score-edit-file-at-point'."
(interactive)
@ -2429,7 +2475,7 @@ score in `gnus-newsgroup-scored' by SCORE."
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.
`q' to quit, `k' to kill score trace buffer.
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.")
@ -2775,9 +2821,7 @@ Destroys the current buffer."
(lambda (file)
(cons (inline (gnus-score-file-rank file)) file))
files)))
(mapcar
(lambda (f) (cdr f))
(sort alist 'car-less-than-car)))))
(mapcar 'cdr (sort alist 'car-less-than-car)))))
(defun gnus-score-find-alist (group)
"Return list of score files for GROUP.

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

@ -140,8 +140,7 @@
(when gnus-use-sc
(add-hook 'mail-citation-hook 'sc-cite-original)
(setq message-cite-function 'sc-cite-original)
(autoload 'sc-cite-original "supercite"))
(setq message-cite-function 'sc-cite-original))
;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137))
;;; Generated autoloads from lisp/gnus.el

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

@ -306,7 +306,7 @@ Note -- this function hasn't been implemented yet."
If NOT-ALL, don't pack ticked articles."
(let ((gnus-expert-user t)
(gnus-large-newsgroup nil)
(entry (gnus-gethash group gnus-newsrc-hashtb)))
(entry (gnus-group-entry group)))
(when (or (null entry)
(eq (car entry) t)
(and (car entry)

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

@ -140,7 +140,7 @@ text properties. This is only needed on XEmacs, as FSF Emacs does this anyway."
(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)
(group "%M\%S\%p\%P\%5y: %(%g%)\n" ,gnus-group-line-format-spec)
(summary-dummy "* %(: :%) %S\n"
,gnus-summary-dummy-line-format-spec)
(summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n"
@ -198,12 +198,13 @@ Return a list of updated types."
(not (equal emacs-version
(cdr (assq 'version gnus-format-specs)))))
(setq gnus-format-specs nil))
;; Flush the group format spec cache if it doesn't support decoded
;; group names.
;; Flush the group format spec cache if there's the grouplens stuff
;; or it doesn't support decoded group names.
(when (memq 'group types)
(let ((spec (assq 'group gnus-format-specs)))
(unless (string-match " gnus-tmp-decoded-group[ )]"
(gnus-prin1-to-string (nth 2 spec)))
(let* ((spec (assq 'group gnus-format-specs))
(sspec (gnus-prin1-to-string (nth 2 spec))))
(when (or (string-match " gnus-tmp-grouplens[ )]" sspec)
(not (string-match " gnus-tmp-decoded-group[ )]" sspec)))
(setq gnus-format-specs (delq spec gnus-format-specs)))))
;; Go through all the formats and see whether they need updating.
@ -296,9 +297,7 @@ Return a list of updated types."
(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))
(apply #'+ (mapcar #'char-width string)))
(defun gnus-correct-substring (string start &optional end)
(let ((wstart 0)
@ -310,14 +309,14 @@ Return a list of updated types."
;; Find the start position.
(while (and (< seek length)
(< wseek start))
(incf wseek (gnus-char-width (aref string seek)))
(incf wseek (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 wseek (char-width (aref string seek)))
(incf seek))
(setq wend seek)
(substring string wstart (1- wend))))
@ -622,6 +621,9 @@ are supported for %s."
?s)))
;; Find the specification from `spec-alist'.
((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
;; We used to use "%l" for displaying the grouplens score.
((eq spec ?l)
(setq elem '("" ?s)))
(t
(setq elem '("*" ?s))))
(setq elem-type (cadr elem))
@ -672,7 +674,7 @@ are supported for %s."
(list (car flist)))
;; A single number.
((string= fstring "%d")
(setq dontinsert)
(setq dontinsert t)
(if insert
(list `(princ ,(car flist)))
(list `(int-to-string ,(car flist)))))

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

@ -52,7 +52,7 @@ with some simple extensions.
The following specs are understood:
%h backend
%h back end
%n name
%w address
%s status
@ -116,6 +116,7 @@ If nil, a faster, but more primitive, buffer is used instead."
["Copy" gnus-server-copy-server t]
["Edit" gnus-server-edit-server t]
["Regenerate" gnus-server-regenerate-server t]
["Compact" gnus-server-compact-server t]
["Exit" gnus-server-exit t]))
(easy-menu-define
@ -165,6 +166,8 @@ If nil, a faster, but more primitive, buffer is used instead."
"g" gnus-server-regenerate-server
"z" gnus-server-compact-server
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug))
@ -189,7 +192,7 @@ If nil, a faster, but more primitive, buffer is used instead."
(defface gnus-server-closed
'((((class color) (background light)) (:foreground "Steel Blue" :italic t))
(((class color) (background dark))
(:foreground "Light Steel Blue" :italic t))
(:foreground "LightBlue" :italic t))
(t (:italic t)))
"Face used for displaying CLOSED servers"
:group 'gnus-server-visual)
@ -299,7 +302,6 @@ The following commands are available:
(gnus-set-format 'server t)
(let ((alist gnus-server-alist)
(buffer-read-only nil)
(opened gnus-opened-servers)
done server op-ser)
(erase-buffer)
(setq gnus-inserted-opened-servers nil)
@ -314,27 +316,26 @@ The following commands are available:
(pop alist)))
;; Then we insert the list of servers that have been opened in
;; this session.
(while opened
(when (and (not (member (caar opened) done))
(dolist (open gnus-opened-servers)
(when (and (not (member (car open) done))
;; Just ignore ephemeral servers.
(not (member (caar opened) gnus-ephemeral-servers)))
(push (caar opened) done)
(not (member (car open) gnus-ephemeral-servers)))
(push (car open) done)
(gnus-server-insert-server-line
(setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
(caar opened))
(push (list op-ser (caar opened)) gnus-inserted-opened-servers))
(setq opened (cdr opened))))
(setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
(car open))
(push (list op-ser (car open)) gnus-inserted-opened-servers))))
(goto-char (point-min))
(gnus-server-position-point))
(defun gnus-server-server-name ()
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
(let ((server (get-text-property (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)))
"Return a server name that matches one of the names returned by
`gnus-method-to-server'."
(let ((server (get-text-property (point-at-bol) 'gnus-named-server)))
(and server (symbol-name server))))
(defalias 'gnus-server-position-point 'gnus-goto-colon)
@ -377,7 +378,14 @@ gnus-method-to-server."
(if cached
(setq gnus-server-method-cache
(delq cached gnus-server-method-cache)))
(if entry (setcdr entry info)
(if entry
(progn
;; Remove the server from `gnus-opened-servers' since
;; it has never been opened with the new `info' yet.
(gnus-opened-servers-remove (cdr entry))
;; Don't make a new Lisp object.
(setcar (cdr entry) (car info))
(setcdr (cdr entry) (cdr info)))
(setq gnus-server-alist
(nconc gnus-server-alist (list (cons server info))))))))
@ -478,9 +486,8 @@ gnus-method-to-server."
(defun gnus-server-open-all-servers ()
"Open all servers."
(interactive)
(let ((servers gnus-inserted-opened-servers))
(while servers
(gnus-server-open-server (car (pop servers))))))
(dolist (server gnus-inserted-opened-servers)
(gnus-server-open-server (car server))))
(defun gnus-server-close-server (server)
"Close SERVER."
@ -510,6 +517,8 @@ gnus-method-to-server."
"Close all servers."
(interactive)
(dolist (server gnus-inserted-opened-servers)
(gnus-server-close-server (car server)))
(dolist (server gnus-server-alist)
(gnus-server-close-server (car server))))
(defun gnus-server-deny-server (server)
@ -586,7 +595,8 @@ gnus-method-to-server."
`(lambda (form)
(gnus-server-set-info ,server form)
(gnus-server-list-servers)
(gnus-server-position-point)))))
(gnus-server-position-point))
'edit-server)))
(defun gnus-server-scan-server (server)
"Request a scan from the current server."
@ -717,11 +727,12 @@ gnus-method-to-server."
(while (not (eobp))
(ignore-errors
(push (cons
(buffer-substring
(point)
(progn
(skip-chars-forward "^ \t")
(point)))
(mm-string-as-unibyte
(buffer-substring
(point)
(progn
(skip-chars-forward "^ \t")
(point))))
(let ((last (read cur)))
(cons (read cur) last)))
groups))
@ -729,18 +740,19 @@ gnus-method-to-server."
(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)
(skip-chars-forward "^ \t\\\\")
(setq name (concat name (buffer-substring
p (point)))))
name))
(mm-string-as-unibyte
(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)
(skip-chars-forward "^ \t\\\\")
(setq name (concat name (buffer-substring
p (point)))))
name)))
(let ((last (read cur)))
(cons (read cur) last)))
groups))
@ -783,18 +795,26 @@ gnus-method-to-server."
(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)))
(let ((level
(if (string= prefix "")
(gnus-group-level (setq name (car group)))
(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))))
;; Don't decode if name is ASCII
(if (and (fboundp 'detect-coding-string)
(eq (detect-coding-string name t) 'undecided))
name
(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)
@ -885,7 +905,7 @@ If NUMBER, fetch this number of articles."
(save-excursion
(beginning-of-line)
(let ((name (get-text-property (point) 'gnus-group)))
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
(when (re-search-forward ": \\(.*\\)$" (point-at-eol) t)
(concat (gnus-method-to-server-name gnus-browse-current-method) ":"
(or name
(match-string-no-properties 1)))))))
@ -926,8 +946,7 @@ If NUMBER, fetch this number of articles."
gnus-browse-current-method))))
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))
(gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
(null (gnus-group-entry group)))
(delete-char 1)
(insert ? ))
@ -966,7 +985,7 @@ If NUMBER, fetch this number of articles."
(gnus-get-function (gnus-server-to-method server)
'request-regenerate)
(error
(error "This backend doesn't support regeneration")))
(error "This back end doesn't support regeneration")))
(gnus-message 5 "Requesting regeneration of %s..." server)
(unless (gnus-open-server server)
(error "Couldn't open server"))
@ -974,6 +993,40 @@ If NUMBER, fetch this number of articles."
(gnus-message 5 "Requesting regeneration of %s...done" server)
(gnus-message 5 "Couldn't regenerate %s" server))))
;;;
;;; Server compaction. -- dvl
;;;
;; #### FIXME: this function currently fails to update the Group buffer's
;; #### appearance.
(defun gnus-server-compact-server ()
"Issue a command to the server to compact all its groups.
Note: currently only implemented in nnml."
(interactive)
(let ((server (gnus-server-server-name)))
(unless server
(error "No server on the current line"))
(condition-case ()
(gnus-get-function (gnus-server-to-method server)
'request-compact)
(error
(error "This back end doesn't support compaction")))
(gnus-message 5 "\
Requesting compaction of %s... (this may take a long time)"
server)
(unless (gnus-open-server server)
(error "Couldn't open server"))
(if (not (gnus-request-compact server))
(gnus-message 5 "Couldn't compact %s" server)
(gnus-message 5 "Requesting compaction of %s...done" server)
;; Invalidate the original article buffer which might be out of date.
;; #### NOTE: Yes, this might be a bit rude, but since compaction
;; #### will not happen very often, I think this is acceptable.
(let ((original (get-buffer gnus-original-article-buffer)))
(and original (gnus-kill-buffer original))))))
(provide 'gnus-srvr)
;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25

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

@ -506,19 +506,23 @@ Can be used to turn version control on or off."
(defun gnus-subscribe-hierarchical-interactive (groups)
(let ((groups (sort groups 'string<))
prefixes prefix start ans group starts)
prefixes prefix start ans group starts real-group)
(while groups
(setq prefixes (list "^"))
(while (and groups prefixes)
(while (not (string-match (car prefixes) (car groups)))
(while (not (string-match (car prefixes)
(gnus-group-real-name (car groups))))
(setq prefixes (cdr prefixes)))
(setq prefix (car prefixes))
(setq start (1- (length prefix)))
(if (and (string-match "[^\\.]\\." (car groups) start)
(if (and (string-match "[^\\.]\\." (gnus-group-real-name (car groups))
start)
(cdr groups)
(setq prefix
(concat "^" (substring (car groups) 0 (match-end 0))))
(string-match prefix (cadr groups)))
(concat "^" (substring
(gnus-group-real-name (car groups))
0 (match-end 0))))
(string-match prefix (gnus-group-real-name (cadr groups))))
(progn
(push prefix prefixes)
(message "Descend hierarchy %s? ([y]nsq): "
@ -530,16 +534,18 @@ Can be used to turn version control on or off."
(substring prefix 1 (1- (length prefix)))))
(cond ((= ans ?n)
(while (and groups
(string-match prefix
(setq group (car groups))))
(setq group (car groups)
real-group (gnus-group-real-name group))
(string-match prefix real-group))
(push group gnus-killed-list)
(gnus-sethash group group gnus-killed-hashtb)
(setq groups (cdr groups)))
(setq starts (cdr starts)))
((= ans ?s)
(while (and groups
(string-match prefix
(setq group (car groups))))
(setq group (car groups)
real-group (gnus-group-real-name group))
(string-match prefix real-group))
(gnus-sethash group group gnus-killed-hashtb)
(gnus-subscribe-alphabetically (car groups))
(setq groups (cdr groups)))
@ -632,8 +638,7 @@ the first newsgroup."
;; We subscribe the group by changing its level to `subscribed'.
(gnus-group-change-level
newsgroup gnus-level-default-subscribed
gnus-level-killed (gnus-gethash (or next "dummy.group")
gnus-newsrc-hashtb))
gnus-level-killed (gnus-group-entry (or next "dummy.group")))
(gnus-message 5 "Subscribe newsgroup: %s" newsgroup)
(run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup)
t))
@ -755,6 +760,13 @@ prompt the user for the name of an NNTP server to use."
(nnheader-init-server-buffer)
(setq gnus-slave slave)
(gnus-read-init-file)
;; Add "native" to gnus-predefined-server-alist just to have a
;; name for the native select method.
(when gnus-select-method
(push (cons "native" gnus-select-method)
gnus-predefined-server-alist))
(if gnus-agent
(gnus-agentize))
@ -787,11 +799,6 @@ prompt the user for the name of an NNTP server to use."
(when (or gnus-slave gnus-use-dribble-file)
(gnus-dribble-read-file))
;; Allow using GroupLens predictions.
(when gnus-use-grouplens
(bbb-login)
(add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode))
;; Do the actual startup.
(if gnus-agent
(gnus-request-create-group "queue" '(nndraft "")))
@ -809,8 +816,7 @@ prompt the user for the name of an NNTP server to use."
(defun gnus-start-draft-setup ()
"Make sure the draft group exists."
(gnus-request-create-group "drafts" '(nndraft ""))
(unless (gnus-gethash "nndraft:drafts" gnus-newsrc-hashtb)
(gnus-message 3 "Subscribing drafts group")
(unless (gnus-group-entry "nndraft:drafts")
(let ((gnus-level-default-subscribed 1))
(gnus-subscribe-group "nndraft:drafts" nil '(nndraft ""))))
(unless (equal (gnus-group-get-parameter "nndraft:drafts" 'gnus-dummy t)
@ -891,7 +897,7 @@ prompt the user for the name of an NNTP server to use."
(when (and (file-exists-p gnus-current-startup-file)
(file-exists-p dribble-file)
(setq modes (file-modes gnus-current-startup-file)))
(set-file-modes dribble-file modes))
(gnus-set-file-modes dribble-file modes))
(goto-char (point-min))
(when (search-forward "Gnus was exited on purpose" nil t)
(setq purpose t))
@ -961,30 +967,34 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(gnus-read-newsrc-file rawfile))
;; Make sure the archive server is available to all and sundry.
(when gnus-message-archive-method
(unless (assoc "archive" gnus-server-alist)
(let ((method (or (and (stringp gnus-message-archive-method)
(gnus-server-to-method
gnus-message-archive-method))
gnus-message-archive-method)))
;; Check whether the archive method is writable.
(unless (or (stringp method)
(memq 'respool (assoc (format "%s" (car method))
gnus-valid-select-methods)))
(setq method "archive")) ;; The default.
(push (if (stringp method)
`("archive"
nnfolder
,method
(nnfolder-directory
,(nnheader-concat message-directory method))
(nnfolder-active-file
,(nnheader-concat message-directory
(concat method "/active")))
(nnfolder-get-new-mail nil)
(nnfolder-inhibit-expiry t))
(cons "archive" method))
gnus-server-alist))))
(let ((method (or (and (stringp gnus-message-archive-method)
(gnus-server-to-method
gnus-message-archive-method))
gnus-message-archive-method)))
;; Check whether the archive method is writable.
(unless (or (not method)
(stringp method)
(memq 'respool (assoc (format "%s" (car method))
gnus-valid-select-methods)))
(setq method "archive")) ;; The default.
(when (stringp method)
(setq method `(nnfolder
,method
(nnfolder-directory
,(nnheader-concat message-directory method))
(nnfolder-active-file
,(nnheader-concat message-directory
(concat method "/active")))
(nnfolder-get-new-mail nil)
(nnfolder-inhibit-expiry t))))
(if (assoc "archive" gnus-server-alist)
(when gnus-update-message-archive-method
(if method
(setcdr (assoc "archive" gnus-server-alist) method)
(setq gnus-server-alist (delq (assoc "archive" gnus-server-alist)
gnus-server-alist))))
(when method
(push (cons "archive" method) gnus-server-alist))))
;; If we don't read the complete active file, we fill in the
;; hashtb here.
@ -1334,16 +1344,16 @@ for new groups, and subscribe the new groups as zombies."
(when (and (stringp entry)
oldlevel
(< oldlevel gnus-level-zombie))
(setq entry (gnus-gethash entry gnus-newsrc-hashtb)))
(setq entry (gnus-group-entry entry)))
(if (and (not oldlevel)
(consp entry))
(setq oldlevel (gnus-info-level (nth 2 entry)))
(setq oldlevel (or oldlevel gnus-level-killed)))
(when (stringp previous)
(setq previous (gnus-gethash previous gnus-newsrc-hashtb)))
(setq previous (gnus-group-entry previous)))
(if (and (>= oldlevel gnus-level-zombie)
(gnus-gethash group gnus-newsrc-hashtb))
(gnus-group-entry group))
;; We are trying to subscribe a group that is already
;; subscribed.
() ; Do nothing.
@ -1367,8 +1377,7 @@ for new groups, and subscribe the new groups as zombies."
entry)
(gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb)
(when (nth 3 entry)
(setcdr (gnus-gethash (car (nth 3 entry))
gnus-newsrc-hashtb)
(setcdr (gnus-group-entry (car (nth 3 entry)))
(cdr entry)))
(setcdr (cdr entry) (cdddr entry)))))
@ -1428,7 +1437,7 @@ for new groups, and subscribe the new groups as zombies."
(gnus-sethash group (cons num previous)
gnus-newsrc-hashtb))
(when (cdr entry)
(setcdr (gnus-gethash (caadr entry) gnus-newsrc-hashtb) entry))
(setcdr (gnus-group-entry (caadr entry)) entry))
(gnus-dribble-enter
(format
"(gnus-group-set-info '%S)" info)))))
@ -1439,7 +1448,7 @@ for new groups, and subscribe the new groups as zombies."
(defun gnus-kill-newsgroup (newsgroup)
"Obsolete function. Kills a newsgroup."
(gnus-group-change-level
(gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed))
(gnus-group-entry newsgroup) gnus-level-killed))
(defun gnus-check-bogus-newsgroups (&optional confirm)
"Remove bogus newsgroups.
@ -1467,14 +1476,14 @@ newsgroup."
(lambda (group)
;; Remove all bogus subscribed groups by first killing them, and
;; then removing them from the list of killed groups.
(when (setq entry (gnus-gethash group gnus-newsrc-hashtb))
(when (setq entry (gnus-group-entry group))
(gnus-group-change-level entry gnus-level-killed)
(setq gnus-killed-list (delete group gnus-killed-list))))
bogus '("group" "groups" "remove"))
(while (setq group (pop bogus))
;; Remove all bogus subscribed groups by first killing them, and
;; then removing them from the list of killed groups.
(when (setq entry (gnus-gethash group gnus-newsrc-hashtb))
(when (setq entry (gnus-group-entry group))
(gnus-group-change-level entry gnus-level-killed)
(setq gnus-killed-list (delete group gnus-killed-list)))))
;; Then we remove all bogus groups from the list of killed and
@ -1543,8 +1552,8 @@ If SCAN, request a scan of that group as well."
;; command may have responded with the `(0 . 0)'. We
;; ignore this if we already have an active entry
;; for the group.
(if (and (zerop (car active))
(zerop (cdr active))
(if (and (zerop (or (car active) 0))
(zerop (or (cdr active) 0))
(gnus-active group))
(gnus-active group)
@ -1652,8 +1661,8 @@ If SCAN, request a scan of that group as well."
(setq num (max 0 (- (cdr active) num)))))
;; Set the number of unread articles.
(when (and info
(gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb))
(setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num))
(gnus-group-entry (gnus-info-group info)))
(setcar (gnus-group-entry (gnus-info-group info)) num))
num)))
;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb'
@ -1674,12 +1683,12 @@ If SCAN, request a scan of that group as well."
(methods-cache nil)
(type-cache nil)
scanned-methods info group active method retrieve-groups cmethod
method-type)
method-type ignore)
(gnus-message 6 "Checking new news...")
(while newsrc
(setq active (gnus-active (setq group (gnus-info-group
(setq info (pop newsrc))))))
(setq info (pop newsrc))))))
;; Check newsgroups. If the user doesn't want to check them, or
;; they can't be checked (for instance, if the news server can't
@ -1702,28 +1711,30 @@ If SCAN, request a scan of that group as well."
(when (and method
(not (setq method-type (cdr (assoc method type-cache)))))
(setq method-type
(cond
((gnus-secondary-method-p method)
'secondary)
((inline (gnus-server-equal gnus-select-method method))
'primary)
(t
'foreign)))
(cond
((gnus-secondary-method-p method)
'secondary)
((inline (gnus-server-equal gnus-select-method method))
'primary)
(t
'foreign)))
(push (cons method method-type) type-cache))
(setq ignore nil)
(cond ((and method (eq method-type 'foreign))
;; These groups are foreign. Check the level.
(when (and (<= (gnus-info-level info) foreign-level)
(setq active (gnus-activate-group group 'scan)))
;; Let the Gnus agent save the active file.
(when (and gnus-agent active (gnus-online method))
(gnus-agent-save-group-info
method (gnus-group-real-name group) active))
(unless (inline (gnus-virtual-group-p group))
(inline (gnus-close-group group)))
(when (fboundp (intern (concat (symbol-name (car method))
"-request-update-info")))
(inline (gnus-request-update-info info method)))))
(if (<= (gnus-info-level info) foreign-level)
(when (setq active (gnus-activate-group group 'scan))
;; Let the Gnus agent save the active file.
(when (and gnus-agent active (gnus-online method))
(gnus-agent-save-group-info
method (gnus-group-real-name group) active))
(unless (inline (gnus-virtual-group-p group))
(inline (gnus-close-group group)))
(when (fboundp (intern (concat (symbol-name (car method))
"-request-update-info")))
(inline (gnus-request-update-info info method))))
(setq ignore t)))
;; These groups are native or secondary.
((> (gnus-info-level info) level)
;; We don't want these groups.
@ -1762,13 +1773,17 @@ If SCAN, request a scan of that group as well."
((eq active 'ignore)
;; Don't do anything.
)
((and active ignore)
;; The level of the foreign group is higher than the specified
;; value.
)
(active
(inline (gnus-get-unread-articles-in-group info active t)))
(t
;; The group couldn't be reached, so we nix out the number of
;; unread articles and stuff.
(gnus-set-active group nil)
(let ((tmp (gnus-gethash group gnus-newsrc-hashtb)))
(let ((tmp (gnus-group-entry group)))
(when tmp
(setcar tmp t))))))
@ -1782,8 +1797,8 @@ If SCAN, request a scan of that group as well."
(when (gnus-check-backend-function 'request-scan (car method))
(gnus-request-scan nil method))
(gnus-read-active-file-2
(mapcar (lambda (group) (gnus-group-real-name group)) groups)
method)
(mapcar (lambda (group) (gnus-group-real-name group)) groups)
method)
(dolist (group groups)
(cond
((setq active (gnus-active (gnus-info-group
@ -1793,7 +1808,7 @@ If SCAN, request a scan of that group as well."
;; The group couldn't be reached, so we nix out the number of
;; unread articles and stuff.
(gnus-set-active group nil)
(setcar (gnus-gethash group gnus-newsrc-hashtb) t)))))))
(setcar (gnus-group-entry group) t)))))))
(gnus-message 6 "Checking new news...done")))
@ -1802,7 +1817,7 @@ If SCAN, request a scan of that group as well."
(defun gnus-make-hashtable-from-newsrc-alist ()
(let ((alist gnus-newsrc-alist)
(ohashtb gnus-newsrc-hashtb)
prev)
prev info method rest methods)
(setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)))
(setq alist
(setq prev (setq gnus-newsrc-alist
@ -1811,14 +1826,26 @@ If SCAN, request a scan of that group as well."
gnus-newsrc-alist
(cons (list "dummy.group" 0 nil) alist)))))
(while alist
(setq info (car alist))
;; Make the same select-methods identical Lisp objects.
(when (setq method (gnus-info-method info))
(if (setq rest (member method methods))
(gnus-info-set-method info (car rest))
(push method methods)))
(gnus-sethash
(caar alist)
(car info)
;; Preserve number of unread articles in groups.
(cons (and ohashtb (car (gnus-gethash (caar alist) ohashtb)))
(cons (and ohashtb (car (gnus-gethash (car info) ohashtb)))
prev)
gnus-newsrc-hashtb)
(setq prev alist
alist (cdr alist)))))
alist (cdr alist)))
;; Make the same select-methods in `gnus-server-alist' identical
;; as well.
(while methods
(setq method (pop methods))
(when (setq rest (rassoc method gnus-server-alist))
(setcdr rest method)))))
(defun gnus-make-hashtable-from-killed ()
"Create a hash table from the killed and zombie lists."
@ -1845,9 +1872,9 @@ If SCAN, request a scan of that group as well."
(defun gnus-make-articles-unread (group articles)
"Mark ARTICLES in GROUP as unread."
(let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb)
(gnus-gethash (gnus-group-real-name group)
gnus-newsrc-hashtb))))
(let* ((info (nth 2 (or (gnus-group-entry group)
(gnus-group-entry
(gnus-group-real-name group)))))
(ranges (gnus-info-read info))
news article)
(while articles
@ -1867,9 +1894,8 @@ If SCAN, request a scan of that group as well."
(defun gnus-make-ascending-articles-unread (group articles)
"Mark ascending ARTICLES in GROUP as unread."
(let* ((entry (or (gnus-gethash group gnus-newsrc-hashtb)
(gnus-gethash (gnus-group-real-name group)
gnus-newsrc-hashtb)))
(let* ((entry (or (gnus-group-entry group)
(gnus-group-entry (gnus-group-real-name group))))
(info (nth 2 entry))
(ranges (gnus-info-read info))
(r ranges)
@ -1941,7 +1967,7 @@ If SCAN, request a scan of that group as well."
(while lists
(setq killed (car lists))
(while killed
(gnus-sethash (car killed) nil hashtb)
(gnus-sethash (mm-string-as-unibyte (car killed)) nil hashtb)
(setq killed (cdr killed)))
(setq lists (cdr lists)))))
@ -2118,7 +2144,7 @@ If SCAN, request a scan of that group as well."
(while (not (eobp))
(condition-case ()
(progn
(narrow-to-region (point) (gnus-point-at-eol))
(narrow-to-region (point) (point-at-eol))
;; group gets set to a symbol interned in the hash table
;; (what a hack!!) - jwz
(setq group (let ((obarray hashtb)) (read cur)))
@ -2150,7 +2176,7 @@ If SCAN, request a scan of that group as well."
(unless ignore-errors
(gnus-message 3 "Warning - invalid active: %s"
(buffer-substring
(gnus-point-at-bol) (gnus-point-at-eol))))))
(point-at-bol) (point-at-eol))))))
(widen)
(forward-line 1)))))
@ -2387,6 +2413,8 @@ If FORCE is non-nil, the .newsrc file is read."
(setq gnus-format-specs gnus-default-format-specs)))
(when gnus-newsrc-assoc
(setq gnus-newsrc-alist gnus-newsrc-assoc))))
(dolist (elem gnus-newsrc-alist)
(setcar elem (mm-string-as-unibyte (car elem))))
(gnus-make-hashtable-from-newsrc-alist)
(when (file-newer-than-file-p file ding-file)
;; Old format quick file
@ -2502,10 +2530,10 @@ If FORCE is non-nil, the .newsrc file is read."
;; don't give a damn, frankly, my dear.
(concat gnus-newsrc-options
(buffer-substring
(gnus-point-at-bol)
(point-at-bol)
;; Options may continue on the next line.
(or (and (re-search-forward "^[^ \t]" nil 'move)
(progn (beginning-of-line) (point)))
(point-at-bol))
(point)))))
(forward-line -1))
(symbol
@ -2573,8 +2601,8 @@ If FORCE is non-nil, the .newsrc file is read."
;; The line was buggy.
(setq group nil)
(gnus-error 3.1 "Mangled line: %s"
(buffer-substring (gnus-point-at-bol)
(gnus-point-at-eol))))
(buffer-substring (point-at-bol)
(point-at-eol))))
nil))
;; Skip past ", ". Spaces are invalid in these ranges, but
;; we allow them, because it's a common mistake to put a
@ -2683,9 +2711,9 @@ If FORCE is non-nil, the .newsrc file is read."
(while (re-search-forward "[ \t]-n" nil t)
(setq eol
(or (save-excursion
(and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t)
(and (re-search-forward "[ \t]-n" (point-at-eol) t)
(- (point) 2)))
(gnus-point-at-eol)))
(point-at-eol)))
;; Search for all "words"...
(while (re-search-forward "[^ \t,\n]+" eol t)
(if (eq (char-after (match-beginning 0)) ?!)
@ -2793,7 +2821,7 @@ If FORCE is non-nil, the .newsrc file is read."
;; Replace the existing startup file with the temp file.
(rename-file working-file startup-file t)
(set-file-modes startup-file setmodes)))
(gnus-set-file-modes startup-file setmodes)))
(condition-case nil
(delete-file working-file)
(file-error nil)))))
@ -2845,7 +2873,7 @@ If FORCE is non-nil, the .newsrc file is read."
(while variables
(when (and (boundp (setq variable (pop variables)))
(symbol-value variable))
(princ "(setq ")
(princ "\n(setq ")
(princ (symbol-name variable))
(princ " '")
(prin1 (symbol-value variable))
@ -2872,6 +2900,10 @@ If FORCE is non-nil, the .newsrc file is read."
(setq default-directory (file-name-directory buffer-file-name))
(buffer-disable-undo)
(erase-buffer)
;; Use a unibyte buffer since group names are unibyte strings;
;; in particular, non-ASCII group names are the ones encoded by
;; a certain coding system.
(mm-disable-multibyte)
;; Write options.
(when gnus-newsrc-options
(insert gnus-newsrc-options))
@ -2914,7 +2946,8 @@ If FORCE is non-nil, the .newsrc file is read."
(delete-file gnus-startup-file)
(clear-visited-file-modtime))
(gnus-run-hooks 'gnus-save-standard-newsrc-hook)
(save-buffer)
(let ((coding-system-for-write 'raw-text))
(save-buffer))
(kill-buffer (current-buffer)))))
@ -2926,7 +2959,7 @@ If FORCE is non-nil, the .newsrc file is read."
(defun gnus-slave-mode ()
"Minor mode for slave Gnusae."
(gnus-add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap))
(add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap))
(gnus-run-hooks 'gnus-slave-mode-hook))
(defun gnus-slave-save-newsrc ()
@ -2939,7 +2972,7 @@ If FORCE is non-nil, the .newsrc file is read."
(let ((coding-system-for-write gnus-ding-file-coding-system))
(gnus-write-buffer slave-name))
(when modes
(set-file-modes slave-name modes)))))
(gnus-set-file-modes slave-name modes)))))
(defun gnus-master-read-slave-newsrc ()
(let ((slave-files
@ -3117,6 +3150,41 @@ If this variable is nil, don't do anything."
(symbol-value 'nnimap-mailbox-info)
(make-vector 1 0)))))
(defun gnus-check-reasonable-setup ()
;; Check whether nnml and nnfolder share a directory.
(let ((display-warn
(if (fboundp 'display-warning)
'display-warning
(lambda (type message)
(if noninteractive
(message "Warning (%s): %s" type message)
(let (window)
(with-current-buffer (get-buffer-create "*Warnings*")
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
(insert (format "Warning (%s): %s\n" type message))
(setq window (display-buffer (current-buffer)))
(set-window-start
window
(prog2
(forward-line (- 1 (window-height window)))
(point)
(goto-char (point-max))))))))))
method active actives match)
(dolist (server gnus-server-alist)
(setq method (gnus-server-to-method server)
active (intern (format "%s-active-file" (car method))))
(when (and (member (car method) '(nnml nnfolder))
(gnus-server-opened method)
(boundp active))
(when (setq match (assoc (symbol-value active) actives))
(funcall display-warn 'gnus-server
(format "%s and %s share the same active file %s"
(car method)
(cadr match)
(car match))))
(push (list (symbol-value active) method) actives)))))
(provide 'gnus-start)

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

File diff suppressed because it is too large Load Diff

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

@ -105,16 +105,16 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-group-topic-name ()
"The name of the topic on the current line."
(let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
(let ((topic (get-text-property (point-at-bol) 'gnus-topic)))
(and topic (symbol-name topic))))
(defun gnus-group-topic-level ()
"The level of the topic on the current line."
(get-text-property (gnus-point-at-bol) 'gnus-topic-level))
(get-text-property (point-at-bol) 'gnus-topic-level))
(defun gnus-group-topic-unread ()
"The number of unread articles in topic on the current line."
(get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
(get-text-property (point-at-bol) 'gnus-topic-unread))
(defun gnus-topic-unread (topic)
"Return the number of unread articles in TOPIC."
@ -127,7 +127,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-topic-visible-p ()
"Return non-nil if the current topic is visible."
(get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
(get-text-property (point-at-bol) 'gnus-topic-visible))
(defun gnus-topic-articles-in-topic (entries)
(let ((total 0)
@ -167,9 +167,11 @@ See Info node `(gnus)Formatting Variables'."
(list (completing-read "Go to topic: "
(mapcar 'list (gnus-topic-list))
nil t)))
(dolist (topic (gnus-current-topics topic))
(gnus-topic-goto-topic topic)
(gnus-topic-fold t))
(let ((buffer-read-only nil))
(dolist (topic (gnus-current-topics topic))
(unless (gnus-topic-goto-topic topic)
(gnus-topic-goto-missing-topic topic)
(gnus-topic-display-missing-topic topic))))
(gnus-topic-goto-topic topic))
(defun gnus-current-topic ()
@ -196,9 +198,7 @@ If TOPIC, start with that topic."
(defun gnus-group-active-topic-p ()
"Say whether the current topic comes from the active topics."
(save-excursion
(beginning-of-line)
(get-text-property (point) 'gnus-active)))
(get-text-property (point-at-bol) 'gnus-active))
(defun gnus-topic-find-groups (topic &optional level all lowest recursive)
"Return entries for all visible groups in TOPIC.
@ -210,7 +210,7 @@ If RECURSIVE is t, return groups in its subtopics too."
;; We go through the newsrc to look for matches.
(while groups
(when (setq group (pop groups))
(setq entry (gnus-gethash group gnus-newsrc-hashtb)
(setq entry (gnus-group-entry group)
info (nth 2 entry)
params (gnus-info-params info)
active (gnus-active group)
@ -244,13 +244,12 @@ If RECURSIVE is t, return groups in its subtopics too."
(when recursive
(if (eq recursive t)
(setq recursive (cdr (gnus-topic-find-topology topic))))
(mapcar (lambda (topic-topology)
(setq visible-groups
(nconc visible-groups
(gnus-topic-find-groups
(caar topic-topology)
level all lowest topic-topology))))
(cdr recursive)))
(dolist (topic-topology (cdr recursive))
(setq visible-groups
(nconc visible-groups
(gnus-topic-find-groups
(caar topic-topology)
level all lowest topic-topology)))))
visible-groups))
(defun gnus-topic-goto-previous-topic (n)
@ -351,7 +350,7 @@ If RECURSIVE is t, return groups in its subtopics too."
(setq topology gnus-topic-topology
gnus-tmp-topics nil))
(push (caar topology) gnus-tmp-topics)
(mapcar 'gnus-topic-list (cdr topology))
(mapc 'gnus-topic-list (cdr topology))
gnus-tmp-topics)
;;; Topic parameter jazz
@ -378,39 +377,50 @@ If RECURSIVE is t, return groups in its subtopics too."
(format "(gnus-topic-set-parameters %S '%S)" topic parameters))))
(defun gnus-group-topic-parameters (group)
"Compute the group parameters for GROUP taking into account inheritance from topics."
"Compute the group parameters for GROUP in topic mode.
Possibly inherit parameters from topics above GROUP."
(let ((params-list (copy-sequence (gnus-group-get-parameter group))))
(save-excursion
(nconc params-list
(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)))))))
(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))
params-list))))
(defun gnus-topic-hierarchical-parameters (topic)
"Return a topic list computed for TOPIC."
(let ((topics (gnus-current-topics topic))
params-list param out params)
(while topics
(push (gnus-topic-parameters (pop topics)) params-list))
;; We probably have lots of nil elements here, so
;; we remove them. Probably faster than doing this "properly".
(setq params-list (delq nil params-list))
(defun gnus-topic-hierarchical-parameters (topic &optional group-params-list)
"Compute the topic parameters for TOPIC.
Possibly inherit parameters from topics above TOPIC.
If optional argument GROUP-PARAMS-LIST is non-nil, use it as the basis for
inheritance."
(let ((params-list
;; We probably have lots of nil elements here, so we remove them.
;; Probably faster than doing this "properly".
(delq nil (cons group-params-list
(mapcar 'gnus-topic-parameters
(gnus-current-topics topic)))))
param out params)
;; Now we have all the parameters, so we go through them
;; and do inheritance in the obvious way.
(while (setq params (pop params-list))
(while (setq param (pop params))
(when (atom param)
(setq param (cons param t)))
;; Override any old versions of this param.
(gnus-pull (car param) out)
(push param out)))
(let (posting-style)
(while (setq params (pop params-list))
(while (setq param (pop params))
(when (atom param)
(setq param (cons param t)))
(cond ((eq (car param) 'posting-style)
(let ((param (cdr param))
elt)
(while (setq elt (pop param))
(unless (assoc (car elt) posting-style)
(push elt posting-style)))))
(t
(unless (assq (car param) out)
(push param out))))))
(and posting-style (push (cons 'posting-style posting-style) out)))
;; Return the resulting parameter list.
out))
@ -465,7 +475,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
(gnus-make-hashtable-from-killed))
(gnus-group-prepare-flat-list-dead
(gnus-remove-if (lambda (group)
(or (gnus-gethash group gnus-newsrc-hashtb)
(or (gnus-group-entry group)
(gnus-gethash group gnus-killed-hashtb)))
not-in-list)
gnus-level-killed ?K regexp)))
@ -727,6 +737,9 @@ articles in the topic and its subtopics."
(not (gnus-topic-goto-missing-topic (caadr parent))))
(gnus-topic-display-missing-topic (caadr parent))))
(gnus-topic-goto-missing-topic topic)
;; Skip past all groups in the topic we're in.
(while (gnus-group-group-name)
(forward-line 1))
(let* ((top (gnus-topic-find-topology topic))
(children (cddr top))
(type (cadr top))
@ -848,8 +861,7 @@ articles in the topic and its subtopics."
(pop topics)))
;; Go through all living groups and make sure that
;; they belong to some topic.
(let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
gnus-topic-alist)))
(let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist)))
(entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist)))
(newsrc (cdr gnus-newsrc-alist))
group)
@ -863,7 +875,7 @@ articles in the topic and its subtopics."
(while (setq topic (pop alist))
(while (cdr topic)
(if (and (cadr topic)
(gnus-gethash (cadr topic) gnus-newsrc-hashtb))
(gnus-group-entry (cadr topic)))
(setq topic (cdr topic))
(setcdr topic (cddr topic)))))))
@ -893,7 +905,7 @@ articles in the topic and its subtopics."
(let ((topic-name (pop topic))
group filtered-topic)
(while (setq group (pop topic))
(when (and (or (gnus-gethash group gnus-active-hashtb)
(when (and (or (gnus-active group)
(gnus-info-method (gnus-get-info group)))
(not (gnus-gethash group gnus-killed-hashtb)))
(push group filtered-topic)))
@ -1142,7 +1154,7 @@ articles in the topic and its subtopics."
(when (gnus-visual-p 'topic-menu 'menu)
(gnus-topic-make-menu-bar))
(gnus-set-format 'topic t)
(gnus-add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
(add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map)
(add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
(set (make-local-variable 'gnus-group-prepare-function)
'gnus-group-prepare-topics)
@ -1297,15 +1309,13 @@ If COPYP, copy the groups instead."
entry)
(if (and (not groups) (not copyp) start-topic)
(gnus-topic-move start-topic topic)
(mapcar
(lambda (g)
(gnus-group-remove-mark g use-marked)
(when (and
(setq entry (assoc (gnus-current-topic) gnus-topic-alist))
(not copyp))
(setcdr entry (gnus-delete-first g (cdr entry))))
(nconc topicl (list g)))
groups)
(dolist (g groups)
(gnus-group-remove-mark g use-marked)
(when (and
(setq entry (assoc (gnus-current-topic) gnus-topic-alist))
(not copyp))
(setcdr entry (gnus-delete-first g (cdr entry))))
(nconc topicl (list g)))
(gnus-topic-enter-dribble)
(if start-group
(gnus-group-goto-group start-group)
@ -1318,7 +1328,7 @@ If COPYP, copy the groups instead."
(let ((use-marked (and (not n) (not (gnus-region-active-p))
gnus-group-marked t))
(groups (gnus-group-process-prefix n)))
(mapcar
(mapc
(lambda (group)
(gnus-group-remove-mark group use-marked)
(let ((topicl (assoc (gnus-current-topic) gnus-topic-alist))
@ -1735,9 +1745,7 @@ If REVERSE, reverse the sorting order."
(if (gnus-topic-find-topology to current-top 0);; Don't care the level
(error "Can't move `%s' to its sub-level" current))
(gnus-topic-find-topology current nil nil 'delete)
(while (cdr to-top)
(setq to-top (cdr to-top)))
(setcdr to-top (list current-top))
(setcdr (last to-top) (list current-top))
(gnus-topic-enter-dribble)
(gnus-group-list-groups)
(gnus-topic-goto-topic current)))

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

@ -50,7 +50,6 @@
(require 'gnus-util)
(require 'gnus)
(require 'custom)
(defgroup gnus-undo nil
"Undoing in Gnus buffers."
@ -113,7 +112,7 @@
;; Set up the menu.
(when (gnus-visual-p 'undo-menu 'menu)
(gnus-undo-make-menu-bar))
(gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map)
(add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map)
(gnus-make-local-hook 'post-command-hook)
(add-hook 'post-command-hook 'gnus-undo-boundary nil t)
(gnus-run-hooks 'gnus-undo-mode-hook)))
@ -187,8 +186,7 @@ A numeric argument serves as a repeat count."
(error "Nothing further to undo"))
(setq gnus-undo-actions (delq action gnus-undo-actions))
(setq gnus-undo-boundary t)
(while action
(funcall (pop action)))))
(mapc 'funcall action)))
(provide 'gnus-undo)

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

@ -31,11 +31,10 @@
;; Gnus first.
;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
;; autoloads below...]
;; autoloads and defvars below...]
;;; Code:
(require 'custom)
(eval-when-compile
(require 'cl)
;; Fixme: this should be a gnus variable, not nnmail-.
@ -67,7 +66,7 @@
;; (replace-in-string "foo" "/*$" "/")
;; (replace-in-string "xe" "\\(x\\)?" "")
((fboundp 'replace-regexp-in-string)
(defun gnus-replace-in-string (string regexp newtext &optional literal)
(defun gnus-replace-in-string (string regexp newtext &optional literal)
"Replace all matches for REGEXP with NEWTEXT in STRING.
If LITERAL is non-nil, insert NEWTEXT literally. Return a new
string containing the replacements.
@ -75,25 +74,7 @@ string containing the replacements.
This is a compatibility function for different Emacsen."
(replace-regexp-in-string regexp newtext string nil literal)))
((fboundp 'replace-in-string)
(defalias 'gnus-replace-in-string 'replace-in-string))
(t
(defun gnus-replace-in-string (string regexp newtext &optional literal)
"Replace all matches for REGEXP with NEWTEXT in STRING.
If LITERAL is non-nil, insert NEWTEXT literally. Return a new
string containing the replacements.
This is a compatibility function for different Emacsen."
(let ((start 0) tail)
(while (string-match regexp string start)
(setq tail (- (length string) (match-end 0)))
(setq string (replace-match newtext nil literal string))
(setq start (- (length string) tail))))
string))))
;;; bring in the netrc functions as aliases
(defalias 'gnus-netrc-get 'netrc-get)
(defalias 'gnus-netrc-machine 'netrc-machine)
(defalias 'gnus-parse-netrc 'netrc-parse)
(defalias 'gnus-replace-in-string 'replace-in-string))))
(defun gnus-boundp (variable)
"Return non-nil if VARIABLE is bound and non-nil."
@ -128,15 +109,6 @@ This is a compatibility function for different Emacsen."
(set symbol nil))
symbol))
;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
;; to limit the length of a string. This function is necessary since
;; `(substr "abc" 0 30)' pukes with "Args out of range".
;; Fixme: Why not `truncate-string-to-width'?
(defsubst gnus-limit-string (str width)
(if (> (length str) width)
(substring str 0 width)
str))
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
@ -146,16 +118,6 @@ This is a compatibility function for different Emacsen."
(funcall (if (stringp buffer) 'get-buffer 'buffer-name)
buffer))))
(defalias 'gnus-point-at-bol
(if (fboundp 'point-at-bol)
'point-at-bol
'line-beginning-position))
(defalias 'gnus-point-at-eol
(if (fboundp 'point-at-eol)
'point-at-eol
'line-end-position))
;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and
;; XEmacs. In Emacs we don't need to call `make-local-hook' first.
;; It's harmless, though, so the main purpose of this alias is to shut
@ -180,7 +142,7 @@ This is a compatibility function for different Emacsen."
;; Delete the current line (and the next N lines).
(defmacro gnus-delete-line (&optional n)
`(delete-region (gnus-point-at-bol)
`(delete-region (point-at-bol)
(progn (forward-line ,(or n 1)) (point))))
(defun gnus-byte-code (func)
@ -235,8 +197,7 @@ is slower."
"Return the value of the header FIELD of current article."
(save-excursion
(save-restriction
(let ((case-fold-search t)
(inhibit-point-motion-hooks t))
(let ((inhibit-point-motion-hooks t))
(nnheader-narrow-to-headers)
(message-fetch-field field)))))
@ -248,7 +209,7 @@ is slower."
(defun gnus-goto-colon ()
(beginning-of-line)
(let ((eol (gnus-point-at-eol)))
(let ((eol (point-at-eol)))
(goto-char (or (text-property-any (point) eol 'gnus-position t)
(search-forward ":" eol t)
(point)))))
@ -263,12 +224,15 @@ is slower."
(defun gnus-remove-text-with-property (prop)
"Delete all text in the current buffer with text property PROP."
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(while (get-text-property (point) prop)
(delete-char 1))
(goto-char (next-single-property-change (point) prop nil (point-max))))))
(let ((start (point-min))
end)
(unless (get-text-property start prop)
(setq start (next-single-property-change start prop)))
(while start
(setq end (text-property-any start (point-max) prop nil))
(delete-region start (or end (point-max)))
(setq start (when end
(next-single-property-change start prop))))))
(defun gnus-newsgroup-directory-form (newsgroup)
"Make hierarchical directory name from NEWSGROUP name."
@ -501,6 +465,79 @@ jabbering all the time."
:group 'gnus-start
:type 'integer)
(defcustom gnus-add-timestamp-to-message nil
"Non-nil means add timestamps to messages that Gnus issues.
If it is `log', add timestamps to only the messages that go into the
\"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer).
If it is neither nil nor `log', add timestamps not only to log messages
but also to the ones displayed in the echo area."
:version "23.0" ;; No Gnus
:group 'gnus-various
:type '(choice :format "%{%t%}:\n %[Value Menu%] %v"
(const :tag "Logged messages only" log)
(sexp :tag "All messages"
:match (lambda (widget value) value)
:value t)
(const :tag "No timestamp" nil)))
(eval-when-compile
(defmacro gnus-message-with-timestamp-1 (format-string args)
(let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time)
"." (format "%03d" (/ (nth 2 time) 1000)) "> ")))
(if (featurep 'xemacs)
`(let (str time)
(if (or (and (null ,format-string) (null ,args))
(progn
(setq str (apply 'format ,format-string ,args))
(zerop (length str))))
(prog1
(and ,format-string str)
(clear-message nil))
(cond ((eq gnus-add-timestamp-to-message 'log)
(setq time (current-time))
(display-message 'no-log str)
(log-message 'message (concat ,@timestamp str)))
(gnus-add-timestamp-to-message
(setq time (current-time))
(display-message 'message (concat ,@timestamp str)))
(t
(display-message 'message str))))
str)
`(let (str time)
(cond ((eq gnus-add-timestamp-to-message 'log)
(setq str (let (message-log-max)
(apply 'message ,format-string ,args)))
(when (and message-log-max
(> message-log-max 0)
(/= (length str) 0))
(setq time (current-time))
(with-current-buffer (get-buffer-create "*Messages*")
(goto-char (point-max))
(insert ,@timestamp str "\n")
(forward-line (- message-log-max))
(delete-region (point-min) (point))
(goto-char (point-max))))
str)
(gnus-add-timestamp-to-message
(if (or (and (null ,format-string) (null ,args))
(progn
(setq str (apply 'format ,format-string ,args))
(zerop (length str))))
(prog1
(and ,format-string str)
(message nil))
(setq time (current-time))
(message "%s" (concat ,@timestamp str))
str))
(t
(apply 'message ,format-string ,args))))))))
(defun gnus-message-with-timestamp (format-string &rest args)
"Display message with timestamp. Arguments are the same as `message'.
The `gnus-add-timestamp-to-message' variable controls how to add
timestamp to message."
(gnus-message-with-timestamp-1 format-string args))
(defun gnus-message (level &rest args)
"If LEVEL is lower than `gnus-verbose' print ARGS using `message'.
@ -509,7 +546,9 @@ Guideline for numbers:
that take a long time, 7 - not very important messages on stuff, 9 - messages
inside loops."
(if (<= level gnus-verbose)
(apply 'message args)
(if gnus-add-timestamp-to-message
(apply 'gnus-message-with-timestamp args)
(apply 'message args))
;; We have to do this format thingy here even if the result isn't
;; shown - the return value has to be the same as the return value
;; from `message'.
@ -530,12 +569,23 @@ ARGS are passed to `message'."
(defun gnus-split-references (references)
"Return a list of Message-IDs in REFERENCES."
(let ((beg 0)
(references (or references ""))
ids)
(while (string-match "<[^<]+[^< \t]" references beg)
(push (substring references (match-beginning 0) (setq beg (match-end 0)))
ids))
(nreverse ids)))
(defun gnus-extract-references (references)
"Return a list of Message-IDs in REFERENCES (in In-Reply-To
format), trimmed to only contain the Message-IDs."
(let ((ids (gnus-split-references references))
refs)
(dolist (id ids)
(when (string-match "<[^<>]+>" id)
(push (match-string 0 id) refs)))
refs))
(defsubst gnus-parent-id (references &optional n)
"Return the last Message-ID in REFERENCES.
If N, return the Nth ancestor instead."
@ -709,11 +759,11 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
`print-level' to nil. See also `gnus-bind-print-variables'."
(gnus-bind-print-variables (prin1-to-string form)))
(defun gnus-pp (form)
(defun gnus-pp (form &optional stream)
"Use `pp' on FORM in the current buffer.
Bind `print-quoted' and `print-readably' to t, and `print-length' and
`print-level' to nil. See also `gnus-bind-print-variables'."
(gnus-bind-print-variables (pp form (current-buffer))))
(gnus-bind-print-variables (pp form (or stream (current-buffer)))))
(defun gnus-pp-to-string (form)
"The same as `pp-to-string'.
@ -732,9 +782,9 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and
(defun gnus-write-buffer (file)
"Write the current buffer's contents to FILE."
;; Make sure the directory exists.
(gnus-make-directory (file-name-directory file))
(let ((file-name-coding-system nnmail-pathname-coding-system))
;; Make sure the directory exists.
(gnus-make-directory (file-name-directory file))
;; Write the buffer.
(write-region (point-min) (point-max) file nil 'quietly)))
@ -1149,8 +1199,12 @@ Return the modified alist."
t))
(defun gnus-write-active-file (file hashtb &optional full-names)
;; `coding-system-for-write' should be `raw-text' or equivalent.
(let ((coding-system-for-write nnmail-active-file-coding-system))
(with-temp-file file
;; The buffer should be in the unibyte mode because group names
;; are ASCII text or encoded non-ASCII text (i.e., unibyte).
(mm-disable-multibyte)
(mapatoms
(lambda (sym)
(when (and sym
@ -1236,6 +1290,13 @@ Return the modified alist."
(remove-text-properties start end properties object))
t))
(defun gnus-string-remove-all-properties (string)
(condition-case ()
(let ((s string))
(set-text-properties 0 (length string) nil string)
s)
(error string)))
;; This might use `compare-strings' to reduce consing in the
;; case-insensitive case, but it has to cope with null args.
;; (`string-equal' uses symbol print names.)
@ -1350,32 +1411,12 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
`(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
(error "Invalid predicate specifier: %s" spec)))))
(defun gnus-local-map-property (map)
"Return a list suitable for a text property list specifying keymap MAP."
(cond
((featurep 'xemacs)
(list 'keymap map))
((>= emacs-major-version 21)
(list 'keymap map))
(t
(list 'local-map map))))
(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate
require-match initial-contents
history default)
"Like `completing-read', allowing for non-existent 7th arg in older XEmacsen."
`(completing-read ,prompt ,table ,predicate ,require-match
,initial-contents ,history
,@(if (and (featurep 'xemacs) (< emacs-minor-version 2))
()
(list default))))
(defun gnus-completing-read (prompt table &optional predicate require-match
history)
(when (and history
(not (boundp history)))
(set history nil))
(gnus-completing-read-maybe-default
(completing-read
(if (symbol-value history)
(concat prompt " (" (car (symbol-value history)) "): ")
(concat prompt ": "))
@ -1616,13 +1657,16 @@ predicate on the elements."
((or (featurep 'sxemacs) (featurep 'xemacs))
;; XEmacs or SXEmacs:
(concat emacsname "/" emacs-program-version
" ("
(when (and (memq 'codename lst)
codename)
(concat codename
(when system-v ", ")))
(when system-v system-v)
")"))
(let (plst)
(when (memq 'codename lst)
(push codename plst))
(when system-v
(push system-v plst))
(unless (featurep 'mule)
(push "no MULE" plst))
(when (> (length plst) 0)
(concat
" (" (mapconcat 'identity (reverse plst) ", ") ")")))))
(t emacs-version))))
(defun gnus-rename-file (old-path new-path &optional trim)
@ -1646,6 +1690,11 @@ empty directories from OLD-PATH."
(file-truename
(concat old-dir "..")))))))))
(defun gnus-set-file-modes (filename mode)
"Wrapper for set-file-modes."
(ignore-errors
(set-file-modes filename mode)))
(if (fboundp 'set-process-query-on-exit-flag)
(defalias 'gnus-set-process-query-on-exit-flag
'set-process-query-on-exit-flag)

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

@ -393,7 +393,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(list current-prefix-arg
(read-file-name
(if gnus-uu-save-separate-articles
"Save articles is dir: "
"Save articles in dir: "
"Save articles in file: ")
gnus-uu-default-dir
gnus-uu-default-dir)))
@ -482,11 +482,24 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(setq message-forward-as-mime (not message-forward-as-mime)
n nil))
(let ((gnus-article-reply (gnus-summary-work-articles n)))
(when (and (not n)
(= (length gnus-article-reply) 1))
;; The case where neither a number of articles nor a region is
;; specified.
(gnus-summary-top-thread)
(setq gnus-article-reply (nreverse (gnus-uu-find-articles-matching))))
(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)
;; Specify articles to be forwarded. Note that they should be
;; reversed; see `gnus-uu-get-list-of-articles'.
(let ((gnus-newsgroup-processable (reverse gnus-article-reply)))
(gnus-uu-decode-save n file)
(setq gnus-article-reply gnus-newsgroup-processable))
;; Restore the value of `gnus-newsgroup-processable' to which
;; it should be set when it is not `let'-bound.
(setq gnus-newsgroup-processable (reverse gnus-article-reply))
(switch-to-buffer gnus-uu-digest-buffer)
(let ((fs gnus-uu-digest-from-subject))
(when fs
@ -511,11 +524,11 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
"Various"))))
(goto-char (point-min))
(when (re-search-forward "^Subject: ")
(delete-region (point) (gnus-point-at-eol))
(delete-region (point) (point-at-eol))
(insert subject))
(goto-char (point-min))
(when (re-search-forward "^From:")
(delete-region (point) (gnus-point-at-eol))
(delete-region (point) (point-at-eol))
(insert " " from))
(let ((message-forward-decoded-p t))
(message-forward post t))))
@ -530,19 +543,19 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(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))))))
(gnus-message 6 "%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
@ -570,16 +583,18 @@ When called interactively, prompt for REGEXP."
(interactive "sUnmark (regexp): ")
(gnus-uu-mark-by-regexp regexp t))
(defun gnus-uu-mark-series ()
(defun gnus-uu-mark-series (&optional silent)
"Mark the current series with the process mark."
(interactive)
(let* ((articles (gnus-uu-find-articles-matching))
(l (length articles)))
(l (length articles)))
(while articles
(gnus-summary-set-process-mark (car articles))
(setq articles (cdr articles)))
(message "Marked %d articles" l))
(gnus-summary-position-point))
(unless silent
(gnus-message 6 "Marked %d articles" l))
(gnus-summary-position-point)
l))
(defun gnus-uu-mark-region (beg end &optional unmark)
"Set the process mark on all articles between point and mark."
@ -687,14 +702,16 @@ When called interactively, prompt for REGEXP."
(setq gnus-newsgroup-processable nil)
(save-excursion
(let ((data gnus-newsgroup-data)
(count 0)
number)
(while data
(when (and (not (memq (setq number (gnus-data-number (car data)))
gnus-newsgroup-processable))
(vectorp (gnus-data-header (car data))))
(gnus-summary-goto-subject number)
(gnus-uu-mark-series))
(setq data (cdr data)))))
(setq count (+ count (gnus-uu-mark-series t))))
(setq data (cdr data)))
(gnus-message 6 "Marked %d articles" count)))
(gnus-summary-position-point))
;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>.
@ -852,7 +869,7 @@ When called interactively, prompt for REGEXP."
(save-restriction
(set-buffer buffer)
(let (buffer-read-only)
(gnus-set-text-properties (point-min) (point-max) nil)
(set-text-properties (point-min) (point-max) nil)
;; These two are necessary for XEmacs 19.12 fascism.
(put-text-property (point-min) (point-max) 'invisible nil)
(put-text-property (point-min) (point-max) 'intangible nil))
@ -862,7 +879,7 @@ When called interactively, prompt for REGEXP."
(mm-enable-multibyte)
(mime-to-mml))
(goto-char (point-min))
(re-search-forward "\n\n")
(search-forward "\n\n")
(unless (and message-forward-as-mime gnus-uu-digest-buffer)
;; Quote all 30-dash lines.
(save-excursion
@ -1153,7 +1170,7 @@ When called interactively, prompt for REGEXP."
;; Expand numbers, sort, and return the list of article
;; numbers.
(mapcar (lambda (sub) (cdr sub))
(mapcar 'cdr
(sort (gnus-uu-expand-numbers
list-of-subjects
(not do-not-translate))
@ -1406,7 +1423,7 @@ When called interactively, prompt for REGEXP."
(setq part (match-string 0 subject))
(setq subject (substring subject (match-end 0)))))
(or part
(while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject)
(while (string-match "[0-9]+[^0-9]+[0-9]+" subject)
(setq part (match-string 0 subject))
(setq subject (substring subject (match-end 0)))))
(or part "")))
@ -1708,8 +1725,7 @@ Gnus might fail to display all of it.")
(defun gnus-uu-check-correct-stripped-uucode (start end)
(save-excursion
(let (found beg length)
(if (not gnus-uu-correct-stripped-uucode)
()
(unless gnus-uu-correct-stripped-uucode
(goto-char start)
(if (re-search-forward " \\|`" end t)
@ -1722,19 +1738,15 @@ Gnus might fail to display all of it.")
(forward-line 1))))
(while (not (eobp))
(if (looking-at (concat gnus-uu-begin-string "\\|"
gnus-uu-end-string))
()
(unless (looking-at (concat gnus-uu-begin-string "\\|"
gnus-uu-end-string))
(when (not found)
(beginning-of-line)
(setq beg (point))
(end-of-line)
(setq length (- (point) beg)))
(setq length (- (point-at-eol) (point-at-bol))))
(setq found t)
(beginning-of-line)
(setq beg (point))
(end-of-line)
(when (not (= length (- (point) beg)))
(unless (= length (- (point) beg))
(insert (make-string (- length (- (point) beg)) ? ))))
(forward-line 1)))))))
@ -1759,7 +1771,7 @@ Gnus might fail to display all of it.")
(setq gnus-uu-work-dir
(mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))
(set-file-modes gnus-uu-work-dir 448)
(gnus-set-file-modes gnus-uu-work-dir 448)
(setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))
(push (cons gnus-newsgroup-name gnus-uu-work-dir)
gnus-uu-tmp-alist))))
@ -1779,7 +1791,7 @@ Gnus might fail to display all of it.")
;; that the filename will be treated as a single argument when the shell
;; executes the command.
(defun gnus-uu-command (action file)
(let ((quoted-file (mm-quote-arg file)))
(let ((quoted-file (shell-quote-argument file)))
(if (string-match "%s" action)
(format action quoted-file)
(concat action " " quoted-file))))
@ -1903,7 +1915,7 @@ The user will be asked for a file name."
(when (gnus-uu-post-encode-file "uuencode" path file-name)
(goto-char (point-min))
(forward-line 1)
(while (re-search-forward " " nil t)
(while (search-forward " " nil t)
(replace-match "`"))
t))
@ -2034,8 +2046,7 @@ If no file has been included, the user will be asked for a file."
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$") nil t)
(beginning-of-line)
(setq header (buffer-substring (point-min) (point)))
(setq header (buffer-substring (point-min) (point-at-bol)))
(goto-char (point-min))
(when gnus-uu-post-separate-description
@ -2111,8 +2122,7 @@ If no file has been included, the user will be asked for a file."
(when (not gnus-uu-post-separate-description)
(set-buffer-modified-p nil)
(when (fboundp 'bury-buffer)
(bury-buffer)))))
(bury-buffer))))
(provide 'gnus-uu)

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

@ -120,6 +120,10 @@ used to display Gnus windows."
(vertical 1.0
(summary 0.25)
(edit-score 1.0 point)))
(edit-server
(vertical 1.0
(server 0.5)
(edit-form 1.0 point)))
(post
(vertical 1.0
(post 1.0 point)))
@ -166,8 +170,12 @@ used to display Gnus windows."
(article 0.5)
(message 1.0 point)))
(display-term
(vertical 1.0
("*display*" 1.0))))
(vertical 1.0
("*display*" 1.0)))
(mml-preview
(vertical 1.0
(message 0.5)
(mml-preview 1.0 point))))
"Window configuration for all possible Gnus buffers.
See the Gnus manual for an explanation of the syntax used.")
@ -195,7 +203,8 @@ See the Gnus manual for an explanation of the syntax used.")
(info . gnus-info-buffer)
(category . gnus-category-buffer)
(article-copy . gnus-article-copy)
(draft . gnus-draft-buffer))
(draft . gnus-draft-buffer)
(mml-preview . mml-preview-buffer))
"Mapping from short symbols to buffer names or buffer variables.")
(defcustom gnus-configure-windows-hook nil

296
lisp/gnus/gnus.el
View File

@ -289,10 +289,10 @@ is restarted, and sometimes reloaded."
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
(defconst gnus-version-number "5.11"
(defconst gnus-version-number "0.7"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Gnus v%s" gnus-version-number)
(defconst gnus-version (format "No Gnus v%s" gnus-version-number)
"Version string for this version of Gnus.")
(defcustom gnus-inhibit-startup-message nil
@ -310,9 +310,6 @@ be set in `.emacs' instead."
(unless (fboundp 'gnus-group-remove-excess-properties)
(defalias 'gnus-group-remove-excess-properties 'ignore))
(unless (fboundp 'gnus-set-text-properties)
(defalias 'gnus-set-text-properties 'set-text-properties))
(unless (featurep 'gnus-xmas)
(defalias 'gnus-make-overlay 'make-overlay)
(defalias 'gnus-delete-overlay 'delete-overlay)
@ -323,7 +320,6 @@ be set in `.emacs' instead."
(defalias 'gnus-overlay-end 'overlay-end)
(defalias 'gnus-extent-detached-p 'ignore)
(defalias 'gnus-extent-start-open 'ignore)
(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
(defalias 'gnus-character-to-event 'identity)
(defalias 'gnus-assq-delete-all 'assq-delete-all)
@ -563,7 +559,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-1
'((((class color)
(background dark))
(:foreground "aquamarine1" :bold t))
(:foreground "#e1ffe1" :bold t))
(((class color)
(background light))
(:foreground "DeepPink3" :bold t))
@ -577,7 +573,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-1-empty
'((((class color)
(background dark))
(:foreground "aquamarine1"))
(:foreground "#e1ffe1"))
(((class color)
(background light))
(:foreground "DeepPink3"))
@ -591,7 +587,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-2
'((((class color)
(background dark))
(:foreground "aquamarine2" :bold t))
(:foreground "DarkSeaGreen1" :bold t))
(((class color)
(background light))
(:foreground "HotPink3" :bold t))
@ -605,7 +601,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-2-empty
'((((class color)
(background dark))
(:foreground "aquamarine2"))
(:foreground "DarkSeaGreen1"))
(((class color)
(background light))
(:foreground "HotPink3"))
@ -619,7 +615,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-3
'((((class color)
(background dark))
(:foreground "aquamarine3" :bold t))
(:foreground "aquamarine1" :bold t))
(((class color)
(background light))
(:foreground "magenta4" :bold t))
@ -633,7 +629,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-3-empty
'((((class color)
(background dark))
(:foreground "aquamarine3"))
(:foreground "aquamarine1"))
(((class color)
(background light))
(:foreground "magenta4"))
@ -647,7 +643,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-low
'((((class color)
(background dark))
(:foreground "aquamarine4" :bold t))
(:foreground "aquamarine2" :bold t))
(((class color)
(background light))
(:foreground "DeepPink4" :bold t))
@ -661,7 +657,7 @@ be set in `.emacs' instead."
(defface gnus-group-mail-low-empty
'((((class color)
(background dark))
(:foreground "aquamarine4"))
(:foreground "aquamarine2"))
(((class color)
(background light))
(:foreground "DeepPink4"))
@ -923,7 +919,7 @@ be set in `.emacs' instead."
(defface gnus-splash
'((((class color)
(background dark))
(:foreground "#888888"))
(:foreground "#cccccc"))
(((class color)
(background light))
(:foreground "#888888"))
@ -978,12 +974,12 @@ be set in `.emacs' instead."
(storm "#666699" "#99ccff")
(pdino "#9999cc" "#99ccff")
(purp "#9999cc" "#666699")
(no "#000000" "#ff0000")
(no "#ff0000" "#ffff00")
(neutral "#b4b4b4" "#878787")
(september "#bf9900" "#ffcc00"))
"Color alist used for the Gnus logo.")
(defcustom gnus-logo-color-style 'oort
(defcustom gnus-logo-color-style 'no
"*Color styles used for the Gnus logo."
:type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem)))
gnus-logo-color-alist))
@ -1034,23 +1030,23 @@ be set in `.emacs' instead."
(t
(insert
(format " %s
_ ___ _ _
_ ___ __ ___ __ _ ___
__ _ ___ __ ___
_ ___ _
_ _ __ _
___ __ _
__ _
_ _ _
_ _ _
_ _ _
__ ___
_ _ _ _
_ _
_ _
_ _
_
__
_ ___ _ _
_ ___ __ ___ __ _ ___
__ _ ___ __ ___
_ ___ _
_ _ __ _
___ __ _
__ _
_ _ _
_ _ _
_ _ _
__ ___
_ _ _ _
_ _
_ _
_ _
_
__
"
""))
@ -1294,12 +1290,30 @@ see the manual for details."
(defcustom gnus-message-archive-method "archive"
"*Method used for archiving messages you've sent.
This should be a mail method."
This should be a mail method.
See also `gnus-update-message-archive-method'."
:group 'gnus-server
:group 'gnus-message
:type '(choice (const :tag "Default archive method" "archive")
gnus-select-method))
(defcustom gnus-update-message-archive-method nil
"Non-nil means always update the saved \"archive\" method.
The archive method is initially set according to the value of
`gnus-message-archive-method' and is saved in the \"~/.newsrc.eld\" file
so that it may be used as a real method of the server which is named
\"archive\" ever since. If it once has been saved, it will never be
updated if the value of this variable is nil, even if you change the
value of `gnus-message-archive-method' afterward. If you want the
saved \"archive\" method to be updated whenever you change the value of
`gnus-message-archive-method', set this variable to a non-nil value."
:version "23.0" ;; No Gnus
:group 'gnus-server
:group 'gnus-message
:type 'boolean)
(defcustom gnus-message-archive-group nil
"*Name of the group in which to save the messages you've written.
This can either be a string; a list of strings; or an alist
@ -1566,11 +1580,6 @@ cache to the full extent of the law."
:group 'gnus-meta
:type 'boolean)
(defcustom gnus-use-grouplens nil
"*If non-nil, use GroupLens ratings."
:group 'gnus-meta
:type 'boolean)
(defcustom gnus-keep-backlog 20
"*If non-nil, Gnus will keep read articles for later re-retrieval.
If it is a number N, then Gnus will only keep the last N articles
@ -2007,6 +2016,42 @@ When a spam group is entered, all unread articles are marked as
spam. There is other behavior associated with ham and no
classification when spam.el is loaded - see the manual.")
(gnus-define-group-parameter
spam-resend-to
:type list
:function-document
"The address to get spam resent (through spam-report-resend)."
:variable gnus-spam-resend-to
:variable-default nil
:variable-document
"The address to get spam resent (through spam-report-resend)."
:variable-group spam
:variable-type '(repeat
(list :tag "Group address for resending spam"
(regexp :tag "Group")
(string :tag "E-mail address for resending spam (requires the spam-use-resend exit processor)")))
:parameter-type 'string :tag "E-mail address for resending spam (requires the spam-use-resend exit processor)"
:parameter-document
"The address to get spam resent (through spam-report-resend).")
(gnus-define-group-parameter
ham-resend-to
:type list
:function-document
"The address to get ham resent (through spam-report-resend)."
:variable gnus-ham-resend-to
:variable-default nil
:variable-document
"The address to get ham resent (through spam-report-resend)."
:variable-group spam
:variable-type '(repeat
(list :tag "Group address for resending ham"
(regexp :tag "Group")
(string :tag "E-mail address for resending ham (requires the spam-use-resend exit processor)")))
:parameter-type 'string :tag "E-mail address for resending ham (requires the spam-use-resend exit processor)"
:parameter-document
"The address to get ham resent (through spam-report-resend).")
(defvar gnus-group-spam-exit-processor-ifile "ifile"
"OBSOLETE: The ifile summary exit spam processor.")
@ -2063,6 +2108,27 @@ Only applicable to non-spam (unclassified and ham) groups.")
:value nil
(list :tag "Spam Summary Exit Processor Choices"
(set
(const :tag "Spam: Bogofilter" (spam spam-use-bogofilter))
(const :tag "Spam: Blacklist" (spam spam-use-blacklist))
(const :tag "Spam: Bsfilter" (spam spam-use-bsfilter))
(const :tag "Spam: Gmane Report" (spam spam-use-gmane))
(const :tag "Spam: Resend Message"(spam spam-use-resend))
(const :tag "Spam: ifile" (spam spam-use-ifile))
(const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle))
(const :tag "Spam: Spam-stat" (spam spam-use-stat))
(const :tag "Spam: SpamAssassin" (spam spam-use-spamassassin))
(const :tag "Spam: CRM114" (spam spam-use-crm114))
(const :tag "Ham: BBDB" (ham spam-use-BBDB))
(const :tag "Ham: Bogofilter" (ham spam-use-bogofilter))
(const :tag "Ham: Bsfilter" (ham spam-use-bsfilter))
(const :tag "Ham: Copy" (ham spam-use-ham-copy))
(const :tag "Ham: Resend Message" (ham spam-use-resend))
(const :tag "Ham: ifile" (ham spam-use-ifile))
(const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle))
(const :tag "Ham: Spam-stat" (ham spam-use-stat))
(const :tag "Ham: SpamAssassin" (ham spam-use-spamassassin))
(const :tag "Ham: CRM114" (ham spam-use-crm114))
(const :tag "Ham: Whitelist" (ham spam-use-whitelist))
(variable-item gnus-group-spam-exit-processor-ifile)
(variable-item gnus-group-spam-exit-processor-stat)
(variable-item gnus-group-spam-exit-processor-bogofilter)
@ -2075,20 +2141,7 @@ Only applicable to non-spam (unclassified and ham) groups.")
(variable-item gnus-group-ham-exit-processor-whitelist)
(variable-item gnus-group-ham-exit-processor-BBDB)
(variable-item gnus-group-ham-exit-processor-spamoracle)
(variable-item gnus-group-ham-exit-processor-copy)
(const :tag "Spam: Gmane Report" (spam spam-use-gmane))
(const :tag "Spam: Bogofilter" (spam spam-use-bogofilter))
(const :tag "Spam: Blacklist" (spam spam-use-blacklist))
(const :tag "Spam: ifile" (spam spam-use-ifile))
(const :tag "Spam: Spam-stat" (spam spam-use-stat))
(const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle))
(const :tag "Ham: ifile" (ham spam-use-ifile))
(const :tag "Ham: Bogofilter" (ham spam-use-bogofilter))
(const :tag "Ham: Spam-stat" (ham spam-use-stat))
(const :tag "Ham: Whitelist" (ham spam-use-whitelist))
(const :tag "Ham: BBDB" (ham spam-use-BBDB))
(const :tag "Ham: Copy" (ham spam-use-ham-copy))
(const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle)))))
(variable-item gnus-group-ham-exit-processor-copy))))
:function-document
"Which spam or ham processors will be applied when the summary is exited."
:variable gnus-spam-process-newsgroups
@ -2105,6 +2158,27 @@ spam processing, associated with the appropriate processor."
(regexp :tag "Group Regexp")
(set
:tag "Spam/Ham Summary Exit Processor"
(const :tag "Spam: Bogofilter" (spam spam-use-bogofilter))
(const :tag "Spam: Blacklist" (spam spam-use-blacklist))
(const :tag "Spam: Bsfilter" (spam spam-use-bsfilter))
(const :tag "Spam: Gmane Report" (spam spam-use-gmane))
(const :tag "Spam: Resend Message"(spam spam-use-resend))
(const :tag "Spam: ifile" (spam spam-use-ifile))
(const :tag "Spam: Spam-stat" (spam spam-use-stat))
(const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle))
(const :tag "Spam: SpamAssassin" (spam spam-use-spamassassin))
(const :tag "Spam: CRM114" (spam spam-use-crm114))
(const :tag "Ham: BBDB" (ham spam-use-BBDB))
(const :tag "Ham: Bogofilter" (ham spam-use-bogofilter))
(const :tag "Ham: Bsfilter" (ham spam-use-bsfilter))
(const :tag "Ham: Copy" (ham spam-use-ham-copy))
(const :tag "Ham: Resend Message" (ham spam-use-resend))
(const :tag "Ham: ifile" (ham spam-use-ifile))
(const :tag "Ham: Spam-stat" (ham spam-use-stat))
(const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle))
(const :tag "Ham: SpamAssassin" (ham spam-use-spamassassin))
(const :tag "Ham: CRM114" (ham spam-use-crm114))
(const :tag "Ham: Whitelist" (ham spam-use-whitelist))
(variable-item gnus-group-spam-exit-processor-ifile)
(variable-item gnus-group-spam-exit-processor-stat)
(variable-item gnus-group-spam-exit-processor-bogofilter)
@ -2117,20 +2191,7 @@ spam processing, associated with the appropriate processor."
(variable-item gnus-group-ham-exit-processor-whitelist)
(variable-item gnus-group-ham-exit-processor-BBDB)
(variable-item gnus-group-ham-exit-processor-spamoracle)
(variable-item gnus-group-ham-exit-processor-copy)
(const :tag "Spam: Gmane Report" (spam spam-use-gmane))
(const :tag "Spam: Bogofilter" (spam spam-use-bogofilter))
(const :tag "Spam: Blacklist" (spam spam-use-blacklist))
(const :tag "Spam: ifile" (spam spam-use-ifile))
(const :tag "Spam: Spam-stat" (spam spam-use-stat))
(const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle))
(const :tag "Ham: ifile" (ham spam-use-ifile))
(const :tag "Ham: Bogofilter" (ham spam-use-bogofilter))
(const :tag "Ham: Spam-stat" (ham spam-use-stat))
(const :tag "Ham: Whitelist" (ham spam-use-whitelist))
(const :tag "Ham: BBDB" (ham spam-use-BBDB))
(const :tag "Ham: Copy" (ham spam-use-ham-copy))
(const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle)))))
(variable-item gnus-group-ham-exit-processor-copy))))
:parameter-document
"Which spam or ham processors will be applied when the summary is exited.")
@ -2169,12 +2230,18 @@ spam-autodetect-recheck-messages is set.")
(const default)
(set :tag "Use specific methods"
(variable-item spam-use-blacklist)
(variable-item spam-use-gmane-xref)
(variable-item spam-use-regex-headers)
(variable-item spam-use-regex-body)
(variable-item spam-use-whitelist)
(variable-item spam-use-BBDB)
(variable-item spam-use-ifile)
(variable-item spam-use-spamoracle)
(variable-item spam-use-crm114)
(variable-item spam-use-spamassassin)
(variable-item spam-use-spamassassin-headers)
(variable-item spam-use-bsfilter)
(variable-item spam-use-bsfilter-headers)
(variable-item spam-use-stat)
(variable-item spam-use-blackholes)
(variable-item spam-use-hashcash)
@ -2200,15 +2267,21 @@ set."
(const default)
(set :tag "Use specific methods"
(variable-item spam-use-blacklist)
(variable-item spam-use-gmane-xref)
(variable-item spam-use-regex-headers)
(variable-item spam-use-regex-body)
(variable-item spam-use-whitelist)
(variable-item spam-use-BBDB)
(variable-item spam-use-ifile)
(variable-item spam-use-spamoracle)
(variable-item spam-use-crm114)
(variable-item spam-use-stat)
(variable-item spam-use-blackholes)
(variable-item spam-use-hashcash)
(variable-item spam-use-spamassassin)
(variable-item spam-use-spamassassin-headers)
(variable-item spam-use-bsfilter)
(variable-item spam-use-bsfilter-headers)
(variable-item spam-use-bogofilter-headers)
(variable-item spam-use-bogofilter)))))
:parameter-document
@ -2387,8 +2460,7 @@ It is called with three parameters -- GROUP, LEVEL and OLDLEVEL."
summary-menu group-menu article-menu
tree-highlight menu highlight
browse-menu server-menu
page-marker tree-menu binary-menu pick-menu
grouplens-menu)
page-marker tree-menu binary-menu pick-menu)
"*Enable visual features.
If `visual' is disabled, there will be no menus and few faces. Most of
the visual customization options below will be ignored. Gnus will use
@ -2402,8 +2474,7 @@ instance, to switch off all visual things except menus, you can say:
Valid elements include `summary-highlight', `group-highlight',
`article-highlight', `mouse-face', `summary-menu', `group-menu',
`article-menu', `tree-highlight', `menu', `highlight', `browse-menu',
`server-menu', `page-marker', `tree-menu', `binary-menu', `pick-menu',
and `grouplens-menu'."
`server-menu', `page-marker', `tree-menu', `binary-menu', and`pick-menu'."
:group 'gnus-meta
:group 'gnus-visual
:type '(set (const summary-highlight)
@ -2421,8 +2492,7 @@ and `grouplens-menu'."
(const page-marker)
(const tree-menu)
(const binary-menu)
(const pick-menu)
(const grouplens-menu)))
(const pick-menu)))
;; Byte-compiler warning.
(defvar gnus-visual)
@ -2527,7 +2597,7 @@ a string, be sure to use a valid format, see RFC 2616."
(const codename :tag "Emacs codename")))
(string)))
;; Convert old (No Gnus < 2005-01-10, v5-10 < 2005-09-05) symbol type values:
;; Convert old (< 2005-01-10) symbol type values:
(when (symbolp gnus-user-agent)
(setq gnus-user-agent
(cond ((eq gnus-user-agent 'emacs-gnus-config)
@ -2642,7 +2712,6 @@ such as a mark that says whether an article is stored in the cache
(defvar gnus-headers-retrieved-by nil)
(defvar gnus-article-reply nil)
(defvar gnus-override-method nil)
(defvar gnus-article-check-size nil)
(defvar gnus-opened-servers nil)
(defvar gnus-current-kill-article nil)
@ -2737,7 +2806,7 @@ gnus-registry.el will populate this if it's loaded.")
;; This little mapcar goes through the list below and marks the
;; symbols in question as autoloaded functions.
(mapcar
(mapc
(lambda (package)
(let ((interactive (nth 1 (memq ':interactive package))))
(mapcar
@ -2836,7 +2905,7 @@ gnus-registry.el will populate this if it's loaded.")
gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view
gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view
gnus-uu-decode-binhex-view gnus-uu-unmark-thread
gnus-uu-mark-over gnus-uu-post-news)
gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable)
("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread)
("gnus-msg" (gnus-summary-send-map keymap)
gnus-article-mail gnus-copy-article-buffer gnus-extended-version)
@ -2854,8 +2923,6 @@ gnus-registry.el will populate this if it's loaded.")
gnus-summary-post-forward gnus-summary-wide-reply-with-original
gnus-summary-post-forward)
("gnus-picon" :interactive t gnus-treat-from-picon)
("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p
gnus-grouplens-mode)
("smiley" :interactive t smiley-region)
("gnus-win" gnus-configure-windows gnus-add-configuration)
("gnus-sum" gnus-summary-insert-line gnus-summary-read-group
@ -2890,14 +2957,15 @@ gnus-registry.el will populate this if it's loaded.")
gnus-article-hide-pem gnus-article-hide-signature
gnus-article-strip-leading-blank-lines gnus-article-date-local
gnus-article-date-original gnus-article-date-lapsed
;; gnus-article-show-all-headers
;;gnus-article-show-all-headers
gnus-article-edit-mode gnus-article-edit-article
gnus-article-edit-done gnus-article-decode-encoded-words
gnus-start-date-timer gnus-stop-date-timer
gnus-mime-view-all-parts)
("gnus-int" gnus-request-type)
("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1
gnus-dribble-enter gnus-read-init-file gnus-dribble-touch)
gnus-dribble-enter gnus-read-init-file gnus-dribble-touch
gnus-check-reasonable-setup)
("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article
gnus-dup-enter-articles)
("gnus-range" gnus-copy-sequence)
@ -2967,7 +3035,6 @@ with some simple extensions.
%z Article zcore (character)
%t Number of articles under the current thread (number).
%e Whether the thread is empty or not (character).
%l GroupLens score (string).
%V Total thread score (number).
%P The line number (number).
%O Download mark (character).
@ -3146,11 +3213,9 @@ Return nil if not defined."
(defun gnus-shutdown (symbol)
"Shut down everything that waits for SYMBOL."
(let ((alist gnus-shutdown-alist)
entry)
(while (setq entry (pop alist))
(when (memq symbol (cdr entry))
(funcall (car entry))))))
(dolist (entry gnus-shutdown-alist)
(when (memq symbol (cdr entry))
(funcall (car entry)))))
;;;
@ -3416,7 +3481,7 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-generate-new-group-name (leaf)
(let ((name leaf)
(num 0))
(while (gnus-gethash name gnus-newsrc-hashtb)
(while (gnus-group-entry name)
(setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">")))
name))
@ -3459,30 +3524,27 @@ that that variable is buffer-local to the summary buffers."
;; Perhaps it is already in the cache.
(mapc (lambda (name-method)
(if (equal (cdr name-method) method)
(throw 'server-name (car name-method))))
gnus-server-method-cache)
(if (equal (cdr name-method) method)
(throw 'server-name (car name-method))))
gnus-server-method-cache)
(mapc
(lambda (server-alist)
(mapc (lambda (name-method)
(when (gnus-methods-equal-p (cdr name-method) method)
(unless (member name-method gnus-server-method-cache)
(push name-method gnus-server-method-cache))
(throw 'server-name (car name-method))))
server-alist))
(let ((alists (list gnus-server-alist
gnus-predefined-server-alist)))
(if gnus-select-method
(push (list (cons "native" gnus-select-method)) alists))
alists))
(when (gnus-methods-equal-p (cdr name-method) method)
(unless (member name-method gnus-server-method-cache)
(push name-method gnus-server-method-cache))
(throw 'server-name (car name-method))))
server-alist))
(list gnus-server-alist
gnus-predefined-server-alist))
(let* ((name (if (member (cadr method) '(nil ""))
(format "%s" (car method))
(format "%s:%s" (car method) (cadr method))))
(name-method (cons name method)))
(format "%s" (car method))
(format "%s:%s" (car method) (cadr method))))
(name-method (cons name method)))
(unless (member name-method gnus-server-method-cache)
(push name-method gnus-server-method-cache))
(push name-method gnus-server-method-cache))
name)))
(defsubst gnus-server-to-method (server)
@ -3795,7 +3857,7 @@ The function `gnus-group-find-parameter' will do that for you."
(if simple-results
;; Found results; return them.
(car simple-results)
;; We didn't found it there, try `gnus-parameters'.
;; We didn't find it there, try `gnus-parameters'.
(let ((result nil)
(head nil)
(tail gnus-parameters))
@ -4082,12 +4144,12 @@ If NEWSGROUP is nil, return the global kill file name instead."
(and (not group)
gnus-select-method)
(and (not (gnus-group-entry group))
;; Killed or otherwise unknown group.
(or
;; If we know a virtual server by that name, return its method.
(gnus-server-to-method (gnus-group-server group))
;; Guess a new method as last resort.
(gnus-group-name-to-method group)))
;; Killed or otherwise unknown group.
(or
;; If we know a virtual server by that name, return its method.
(gnus-server-to-method (gnus-group-server group))
;; Guess a new method as last resort.
(gnus-group-name-to-method group)))
(let ((info (or info (gnus-get-info group)))
method)
(if (or (not info)
@ -4193,10 +4255,10 @@ Allow completion over sensible values."
"Say whether METHOD is covered by the agent."
(or (eq (car gnus-agent-method-p-cache) method)
(setq gnus-agent-method-p-cache
(cons method
(member (if (stringp method)
method
(gnus-method-to-server method)) gnus-agent-covered-methods))))
(cons method
(member (if (stringp method)
method
(gnus-method-to-server method)) gnus-agent-covered-methods))))
(cdr gnus-agent-method-p-cache))
(defun gnus-online (method)

370
lisp/gnus/hashcash.el Normal file
View File

@ -0,0 +1,370 @@
;;; hashcash.el --- Add hashcash payments to email
;; Copyright (C) 2003, 2004, 2005, 2007 Free Software Foundation
;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
;; Keywords: mail, hashcash
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; The hashcash binary is at http://www.hashcash.org/.
;;
;; Call mail-add-payment to add a hashcash payment to a mail message
;; in the current buffer.
;;
;; Call mail-add-payment-async after writing the addresses but before
;; writing the mail to start calculating the hashcash payment
;; asynchronously.
;;
;; The easiest way to do this automatically for all outgoing mail
;; is to set `message-generate-hashcash' to t. If you want more
;; control, try the following hooks.
;;
;; To automatically add payments to all outgoing mail when sending:
;; (add-hook 'message-send-hook 'mail-add-payment)
;;
;; To start calculations automatically when addresses are prefilled:
;; (add-hook 'message-setup-hook 'mail-add-payment-async)
;;
;; To check whether calculations are done before sending:
;; (add-hook 'message-send-hook 'hashcash-wait-or-cancel)
;;; Code:
(defgroup hashcash nil
"Hashcash configuration."
:group 'mail)
(defcustom hashcash-default-payment 20
"*The default number of bits to pay to unknown users.
If this is zero, no payment header will be generated.
See `hashcash-payment-alist'."
:type 'integer
:group 'hashcash)
(defcustom hashcash-payment-alist '()
"*An association list mapping email addresses to payment amounts.
Elements may consist of (ADDR AMOUNT) or (ADDR STRING AMOUNT), where
ADDR is the email address of the intended recipient and AMOUNT is
the value of hashcash payment to be made to that user. STRING, if
present, is the string to be hashed; if not present ADDR will be used."
:type '(repeat (choice (list :tag "Normal"
(string :name "Address")
(integer :name "Amount"))
(list :tag "Replace hash input"
(string :name "Address")
(string :name "Hash input")
(integer :name "Amount"))))
:group 'hashcash)
(defcustom hashcash-default-accept-payment 20
"*The default minimum number of bits to accept on incoming payments."
:type 'integer
:group 'hashcash)
(defcustom hashcash-accept-resources `((,user-mail-address nil))
"*An association list mapping hashcash resources to payment amounts.
Resources named here are to be accepted in incoming payments. If the
corresponding AMOUNT is NIL, the value of `hashcash-default-accept-payment'
is used instead."
:group 'hashcash)
(defcustom hashcash-path (executable-find "hashcash")
"*The path to the hashcash binary."
:group 'hashcash)
(defcustom hashcash-extra-generate-parameters nil
"*A list of parameter strings passed to `hashcash-path' when minting.
For example, you may want to set this to '(\"-Z2\") to reduce header length."
:type '(repeat string)
:group 'hashcash)
(defcustom hashcash-double-spend-database "hashcash.db"
"*The path to the double-spending database."
:group 'hashcash)
(defcustom hashcash-in-news nil
"*Specifies whether or not hashcash payments should be made to newsgroups."
:type 'boolean
:group 'hashcash)
(defvar hashcash-process-alist nil
"Alist of asynchronous hashcash processes and buffers.")
(require 'mail-utils)
(eval-and-compile
(if (fboundp 'point-at-bol)
(defalias 'hashcash-point-at-bol 'point-at-bol)
(defalias 'hashcash-point-at-bol 'line-beginning-position))
(if (fboundp 'point-at-eol)
(defalias 'hashcash-point-at-eol 'point-at-eol)
(defalias 'hashcash-point-at-eol 'line-end-position)))
(defun hashcash-strip-quoted-names (addr)
(setq addr (mail-strip-quoted-names addr))
(if (and addr (string-match "\\`\\([^+@]+\\)\\+[^@]*\\(@.+\\)" addr))
(concat (match-string 1 addr) (match-string 2 addr))
addr))
(defun hashcash-token-substring ()
(save-excursion
(let ((token ""))
(loop
(setq token
(concat token (buffer-substring (point) (hashcash-point-at-eol))))
(goto-char (hashcash-point-at-eol))
(forward-char 1)
(unless (looking-at "[ \t]") (return token))
(while (looking-at "[ \t]") (forward-char 1))))))
(defun hashcash-payment-required (addr)
"Return the hashcash payment value required for the given address."
(let ((val (assoc addr hashcash-payment-alist)))
(or (nth 2 val) (nth 1 val) hashcash-default-payment)))
(defun hashcash-payment-to (addr)
"Return the string with which hashcash payments should collide."
(let ((val (assoc addr hashcash-payment-alist)))
(or (nth 1 val) (nth 0 val) addr)))
(defun hashcash-generate-payment (str val)
"Generate a hashcash payment by finding a VAL-bit collison on STR."
(if (and (> val 0)
hashcash-path)
(save-excursion
(set-buffer (get-buffer-create " *hashcash*"))
(erase-buffer)
(apply 'call-process hashcash-path nil t nil
"-m" "-q" "-b" (number-to-string val) str
hashcash-extra-generate-parameters)
(goto-char (point-min))
(hashcash-token-substring))
(error "No `hashcash' binary found")))
(defun hashcash-generate-payment-async (str val callback)
"Generate a hashcash payment by finding a VAL-bit collison on STR.
Return immediately. Call CALLBACK with process and result when ready."
(if (and (> val 0)
hashcash-path)
(let ((process (apply 'start-process "hashcash" nil
hashcash-path "-m" "-q"
"-b" (number-to-string val) str
hashcash-extra-generate-parameters)))
(setq hashcash-process-alist (cons
(cons process (current-buffer))
hashcash-process-alist))
(set-process-filter process `(lambda (process output)
(funcall ,callback process output))))
(funcall callback nil nil)))
(defun hashcash-check-payment (token str val)
"Check the validity of a hashcash payment."
(if hashcash-path
(zerop (call-process hashcash-path nil nil nil "-c"
"-d" "-f" hashcash-double-spend-database
"-b" (number-to-string val)
"-r" str
token))
(progn
(message "No hashcash binary found")
(sleep-for 1)
nil)))
(defun hashcash-version (token)
"Find the format version of a hashcash token."
;; Version 1.2 looks like n:yymmdd:rrrrr:xxxxxxxxxxxxxxxx
;; This carries its own version number embedded in the token,
;; so no further format number changes should be necessary
;; in the X-Payment header.
;;
;; Version 1.1 looks like yymmdd:rrrrr:xxxxxxxxxxxxxxxx
;; You need to upgrade your hashcash binary.
;;
;; Version 1.0 looked like nnnnnrrrrrxxxxxxxxxxxxxxxx
;; This is no longer supported.
(cond ((equal (aref token 1) ?:) 1.2)
((equal (aref token 6) ?:) 1.1)
(t (error "Unknown hashcash format version"))))
(defun hashcash-already-paid-p (recipient)
"Check for hashcash token to RECIPIENT in current buffer."
(save-excursion
(save-restriction
(message-narrow-to-headers-or-head)
(let ((token (message-fetch-field "x-hashcash"))
(case-fold-search t))
(and (stringp token)
(string-match (regexp-quote recipient) token))))))
;;;###autoload
(defun hashcash-insert-payment (arg)
"Insert X-Payment and X-Hashcash headers with a payment for ARG"
(interactive "sPay to: ")
(unless (hashcash-already-paid-p arg)
(let ((pay (hashcash-generate-payment (hashcash-payment-to arg)
(hashcash-payment-required arg))))
(when pay
(insert-before-markers "X-Hashcash: " pay "\n")))))
;;;###autoload
(defun hashcash-insert-payment-async (arg)
"Insert X-Payment and X-Hashcash headers with a payment for ARG
Only start calculation. Results are inserted when ready."
(interactive "sPay to: ")
(unless (hashcash-already-paid-p arg)
(hashcash-generate-payment-async
(hashcash-payment-to arg)
(hashcash-payment-required arg)
`(lambda (process payment)
(hashcash-insert-payment-async-2 ,(current-buffer) process payment)))))
(defun hashcash-insert-payment-async-2 (buffer process pay)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(save-excursion
(save-restriction
(setq hashcash-process-alist (delq
(assq process hashcash-process-alist)
hashcash-process-alist))
(message-goto-eoh)
(when pay
(insert-before-markers "X-Hashcash: " pay)))))))
(defun hashcash-cancel-async (&optional buffer)
"Delete any hashcash processes associated with BUFFER.
BUFFER defaults to the current buffer."
(interactive)
(unless buffer (setq buffer (current-buffer)))
(let (entry)
(while (setq entry (rassq buffer hashcash-process-alist))
(delete-process (car entry))
(setq hashcash-process-alist
(delq entry hashcash-process-alist)))))
(defun hashcash-wait-async (&optional buffer)
"Wait for asynchronous hashcash processes in BUFFER to finish.
BUFFER defaults to the current buffer."
(interactive)
(unless buffer (setq buffer (current-buffer)))
(let (entry)
(while (setq entry (rassq buffer hashcash-process-alist))
(accept-process-output (car entry)))))
(defun hashcash-processes-running-p (buffer)
"Return non-nil if hashcash processes in BUFFER are still running."
(rassq buffer hashcash-process-alist))
(defun hashcash-wait-or-cancel ()
"Ask user whether to wait for hashcash processes to finish."
(interactive)
(when (hashcash-processes-running-p (current-buffer))
(if (y-or-n-p
"Hashcash process(es) still running; wait for them to finish? ")
(hashcash-wait-async)
(hashcash-cancel-async))))
;;;###autoload
(defun hashcash-verify-payment (token &optional resource amount)
"Verify a hashcash payment"
(let* ((split (split-string token ":"))
(key (if (< (hashcash-version token) 1.2)
(nth 1 split)
(case (string-to-number (nth 0 split))
(0 (nth 2 split))
(1 (nth 3 split))))))
(cond ((null resource)
(let ((elt (assoc key hashcash-accept-resources)))
(and elt (hashcash-check-payment token (car elt)
(or (cadr elt) hashcash-default-accept-payment)))))
((equal token key)
(hashcash-check-payment token resource
(or amount hashcash-default-accept-payment)))
(t nil))))
;;;###autoload
(defun mail-add-payment (&optional arg async)
"Add X-Payment: and X-Hashcash: headers with a hashcash payment
for each recipient address. Prefix arg sets default payment temporarily.
Set ASYNC to t to start asynchronous calculation. (See
`mail-add-payment-async')."
(interactive "P")
(let ((hashcash-default-payment (if arg (prefix-numeric-value arg)
hashcash-default-payment))
(addrlist nil))
(save-excursion
(save-restriction
(message-narrow-to-headers)
(let ((to (hashcash-strip-quoted-names (mail-fetch-field "To" nil t)))
(cc (hashcash-strip-quoted-names (mail-fetch-field "Cc" nil t)))
(ng (hashcash-strip-quoted-names (mail-fetch-field "Newsgroups"
nil t))))
(when to
(setq addrlist (split-string to ",[ \t\n]*")))
(when cc
(setq addrlist (nconc addrlist (split-string cc ",[ \t\n]*"))))
(when (and hashcash-in-news ng)
(setq addrlist (nconc addrlist (split-string ng ",[ \t\n]*")))))
(when addrlist
(mapc (if async
#'hashcash-insert-payment-async
#'hashcash-insert-payment)
addrlist)))))
t)
;;;###autoload
(defun mail-add-payment-async (&optional arg)
"Add X-Payment: and X-Hashcash: headers with a hashcash payment
for each recipient address. Prefix arg sets default payment temporarily.
Calculation is asynchronous."
(interactive "P")
(mail-add-payment arg t))
;;;###autoload
(defun mail-check-payment (&optional arg)
"Look for a valid X-Payment: or X-Hashcash: header.
Prefix arg sets default accept amount temporarily."
(interactive "P")
(let ((hashcash-default-accept-payment (if arg (prefix-numeric-value arg)
hashcash-default-accept-payment))
(version (hashcash-version (hashcash-generate-payment "x" 1))))
(save-excursion
(goto-char (point-min))
(search-forward "\n\n")
(beginning-of-line)
(let ((end (point))
(ok nil))
(goto-char (point-min))
(while (and (not ok) (search-forward "X-Payment: hashcash " end t))
(let ((value (split-string (hashcash-token-substring) " ")))
(when (equal (car value) (number-to-string version))
(setq ok (hashcash-verify-payment (cadr value))))))
(goto-char (point-min))
(while (and (not ok) (search-forward "X-Hashcash: " end t))
(setq ok (hashcash-verify-payment (hashcash-token-substring))))
(when ok
(message "Payment valid"))
ok))))
(provide 'hashcash)
;;; arch-tag: 0e7fe983-a124-4392-9788-0dbcbd2c4d62

86
lisp/gnus/hmac-def.el Normal file
View File

@ -0,0 +1,86 @@
;;; hmac-def.el --- A macro for defining HMAC functions.
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Keywords: HMAC, RFC 2104
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This program is implemented from RFC 2104,
;; "HMAC: Keyed-Hashing for Message Authentication".
;;; Code:
(defmacro define-hmac-function (name H B L &optional bit)
"Define a function NAME(TEXT KEY) which computes HMAC with function H.
HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)):
H is a cryptographic hash function, such as SHA1 and MD5, which takes
a string and return a digest of it (in binary form).
B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.)
L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.)
If BIT is non-nil, truncate output to specified bits."
`(defun ,name (text key)
,(concat "Compute "
(upcase (symbol-name name))
" over TEXT with KEY.")
(let ((key-xor-ipad (make-string ,B ?\x36))
(key-xor-opad (make-string ,B ?\x5C))
(len (length key))
(pos 0))
(unwind-protect
(progn
;; if `key' is longer than the block size, apply hash function
;; to `key' and use the result as a real `key'.
(if (> len ,B)
(setq key (,H key)
len ,L))
(while (< pos len)
(aset key-xor-ipad pos (logxor (aref key pos) ?\x36))
(aset key-xor-opad pos (logxor (aref key pos) ?\x5C))
(setq pos (1+ pos)))
(setq key-xor-ipad (unwind-protect
(concat key-xor-ipad text)
(fillarray key-xor-ipad 0))
key-xor-ipad (unwind-protect
(,H key-xor-ipad)
(fillarray key-xor-ipad 0))
key-xor-opad (unwind-protect
(concat key-xor-opad key-xor-ipad)
(fillarray key-xor-opad 0))
key-xor-opad (unwind-protect
(,H key-xor-opad)
(fillarray key-xor-opad 0)))
;; now `key-xor-opad' contains
;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)).
,(if (and bit (< (/ bit 8) L))
`(substring key-xor-opad 0 ,(/ bit 8))
;; return a copy of `key-xor-opad'.
`(concat key-xor-opad)))
;; cleanup.
(fillarray key-xor-ipad 0)
(fillarray key-xor-opad 0)))))
(provide 'hmac-def)
;;; arch-tag: 645adcef-b835-4900-a10a-11f636c982b9
;;; hmac-def.el ends here

85
lisp/gnus/hmac-md5.el Normal file
View File

@ -0,0 +1,85 @@
;;; hmac-md5.el --- Compute HMAC-MD5.
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
;;
;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b)))
;; => "9294727a3638bb1c13f48ef8158bfc9d"
;;
;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe"))
;; => "750c783e6ab0b503eaa86e310a5db738"
;;
;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa)))
;; => "56be34521d144c88dbb8c733f0e8b3f6"
;;
;; (encode-hex-string
;; (hmac-md5
;; (make-string 50 ?\xcd)
;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
;; => "697eaf0aca3a3aea3a75164746ffaa79"
;;
;; (encode-hex-string
;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c)))
;; => "56461ef2342edc00f9bab995690efd4c"
;;
;; (encode-hex-string
;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c)))
;; => "56461ef2342edc00f9bab995"
;;
;; (encode-hex-string
;; (hmac-md5
;; "Test Using Larger Than Block-Size Key - Hash Key First"
;; (make-string 80 ?\xaa)))
;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd"
;;
;; (encode-hex-string
;; (hmac-md5
;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
;; (make-string 80 ?\xaa)))
;; => "6f630fad67cda0ee1fb1f562db3aa53e"
;;; Code:
(eval-when-compile (require 'hmac-def))
(require 'hex-util) ; (decode-hex-string STRING)
(require 'md5) ; expects (md5 STRING)
(defun md5-binary (string)
"Return the MD5 of STRING in binary form."
(if (condition-case nil
;; `md5' of v21 takes 4th arg CODING (and 5th arg NOERROR).
(md5 "" nil nil 'binary) ; => "d41d8cd98f00b204e9800998ecf8427e"
(wrong-number-of-arguments nil))
(decode-hex-string (md5 string nil nil 'binary))
(decode-hex-string (md5 string))))
(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY)
(define-hmac-function hmac-md5-96 md5-binary 64 16 96)
(provide 'hmac-md5)
;;; arch-tag: 0ab3f4f6-3d4b-4167-a9fa-635b7fed7f27
;;; hmac-md5.el ends here

47
lisp/gnus/html2text.el
View File

@ -43,8 +43,42 @@
(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr)))
(defvar html2text-replace-list
'(("&nbsp;" . " ") ("&gt;" . ">") ("&lt;" . "<") ("&quot;" . "\"")
("&amp;" . "&") ("&apos;" . "'"))
'(("&acute;" . "`")
("&amp;" . "&")
("&apos;" . "'")
("&brvbar;" . "|")
("&cent;" . "c")
("&circ;" . "^")
("&copy;" . "(C)")
("&curren;" . "(#)")
("&deg;" . "degree")
("&divide;" . "/")
("&euro;" . "e")
("&frac12;" . "1/2")
("&gt;" . ">")
("&iquest;" . "?")
("&laquo;" . "<<")
("&ldquo" . "\"")
("&lsaquo;" . "(")
("&lsquo;" . "`")
("&lt;" . "<")
("&mdash;" . "--")
("&nbsp;" . " ")
("&ndash;" . "-")
("&permil;" . "%%")
("&plusmn;" . "+-")
("&pound;" . "£")
("&quot;" . "\"")
("&raquo;" . ">>")
("&rdquo" . "\"")
("&reg;" . "(R)")
("&rsaquo;" . ")")
("&rsquo;" . "'")
("&sect;" . "§")
("&sup1;" . "^1")
("&sup2;" . "^2")
("&sup3;" . "^3")
("&tilde;" . "~"))
"The map of entity to text.
This is an alist were each element is a dotted pair consisting of an
@ -229,12 +263,12 @@ formatting, and then moved afterward.")
(goto-char p1)
(let ((item-nr 0)
(items 0))
(while (re-search-forward "<li>" p2 t)
(while (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)
(search-forward "<li>" (point-max) t)
(cond
((string= list-type "ul") (insert " o "))
((string= list-type "ol") (insert (format " %s: " item-nr)))
@ -244,7 +278,7 @@ formatting, and then moved afterward.")
(goto-char p1)
(let ((items 0)
(item-nr 0))
(while (re-search-forward "<dt>" p2 t)
(while (search-forward "<dt>" p2 t)
(setq items (1+ items)))
(goto-char p1)
(while (< item-nr items)
@ -342,8 +376,7 @@ formatting, and then moved afterward.")
(defun html2text-fix-paragraph (p1 p2)
(goto-char p1)
(let ((has-br-line)
(refill-start)
(let ((refill-start)
(refill-stop))
(when (re-search-forward "<br>$" p2 t)
(goto-char p1)

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

@ -99,14 +99,14 @@ backslash and doublequote.")
(push c out)))
(range
(while (<= b c)
(push (mm-make-char 'ascii b) out)
(push (make-char 'ascii b) out)
(incf b))
(setq range nil))
((= i (length token))
(push (mm-make-char 'ascii c) out))
(push (make-char 'ascii c) out))
(t
(when b
(push (mm-make-char 'ascii b) out))
(push (make-char 'ascii b) out))
(setq b c))))
(nreverse out)))
@ -200,7 +200,9 @@ backslash and doublequote.")
(buffer-substring
(1+ (point))
(progn (forward-sexp 1) (1- (point))))))))
(t (error "Unknown symbol: %c" c))))
(t
(message "Unknown symbol: %c" c)
(forward-char 1))))
;; If we found no display-name, then we look for comments.
(if display-name
(setq display-string
@ -213,8 +215,10 @@ backslash and doublequote.")
(ietf-drums-get-comment string)))
(cons mailbox display-string)))))
(defun ietf-drums-parse-addresses (string)
"Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
(defun ietf-drums-parse-addresses (string &optional rawp)
"Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs.
If RAWP, don't actually parse the addresses, but instead return
a list of address strings."
(if (null string)
nil
(with-temp-buffer
@ -231,20 +235,24 @@ backslash and doublequote.")
(skip-chars-forward "^,"))))
((eq c ?,)
(setq address
(condition-case nil
(ietf-drums-parse-address
(buffer-substring beg (point)))
(error nil)))
(if rawp
(buffer-substring beg (point))
(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 rawp
(buffer-substring beg (point))
(condition-case nil
(ietf-drums-parse-address
(buffer-substring beg (point)))
(error nil))))
(if address (push address pairs))
(nreverse pairs)))))
@ -274,6 +282,11 @@ backslash and doublequote.")
(concat "\"" string "\"")
string))
(defun ietf-drums-make-address (name address)
(if name
(concat (ietf-drums-quote-string name) " <" address ">")
address))
(provide 'ietf-drums)
;;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9

359
lisp/gnus/imap.el
View File

@ -74,13 +74,13 @@
;; explanatory for someone that know IMAP. All functions have
;; additional documentation on how to invoke them.
;;
;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented
;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
;; LOGINDISABLED) (with use of external library starttls.el and
;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731
;; (with use of external program `imtest'). It also takes advantage of
;; the UNSELECT extension in Cyrus IMAPD.
;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731
;; (with use of external program `imtest'), RFC2971 (ID). It also
;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
;;
;; Without the work of John McClary Prevost and Jim Radford this library
;; would not have seen the light of day. Many thanks.
@ -140,29 +140,19 @@
(eval-when-compile (require 'cl))
(eval-and-compile
(autoload 'base64-decode-string "base64")
(autoload 'base64-encode-string "base64")
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'sasl-find-mechanism "sasl")
(autoload 'digest-md5-parse-digest-challenge "digest-md5")
(autoload 'digest-md5-digest-response "digest-md5")
(autoload 'digest-md5-digest-uri "digest-md5")
(autoload 'digest-md5-challenge "digest-md5")
(autoload 'rfc2104-hash "rfc2104")
(autoload 'md5 "md5")
(autoload 'utf7-encode "utf7")
(autoload 'utf7-decode "utf7")
(autoload 'format-spec "format-spec")
(autoload 'format-spec-make "format-spec")
(autoload 'open-tls-stream "tls")
;; Avoid use gnus-point-at-eol so we're independent of Gnus. These
;; days we have point-at-eol anyhow.
(if (fboundp 'point-at-eol)
(defalias 'imap-point-at-eol 'point-at-eol)
(defun imap-point-at-eol ()
(save-excursion
(end-of-line)
(point)))))
(autoload 'open-tls-stream "tls"))
;; User variables.
@ -311,6 +301,7 @@ stream.")
kerberos4
digest-md5
cram-md5
;;sasl
login
anonymous)
"Priority of authenticators to consider when authenticating to server.")
@ -318,6 +309,7 @@ stream.")
(defvar imap-authenticator-alist
'((gssapi imap-gssapi-auth-p imap-gssapi-auth)
(kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth)
(sasl imap-sasl-auth-p imap-sasl-auth)
(cram-md5 imap-cram-md5-p imap-cram-md5-auth)
(login imap-login-p imap-login-auth)
(anonymous imap-anonymous-p imap-anonymous-auth)
@ -333,6 +325,13 @@ for doing the actual authentication.")
(defvar imap-error nil
"Error codes from the last command.")
(defvar imap-logout-timeout nil
"Close server immediately if it can't logout in this number of seconds.
If it is nil, never close server until logout completes. Normally,
the value of this variable will be bound to a certain value to which
an application program that uses this module specifies on a per-server
basis.")
;; Internal constants. Change these and die.
(defconst imap-default-port 143)
@ -353,6 +352,7 @@ for doing the actual authentication.")
imap-current-target-mailbox
imap-message-data
imap-capability
imap-id
imap-namespace
imap-state
imap-reached-tag
@ -408,6 +408,10 @@ and `examine'.")
(defvar imap-capability nil
"Capability for server.")
(defvar imap-id nil
"Identity of server.
See RFC 2971.")
(defvar imap-namespace nil
"Namespace for current server.")
@ -557,7 +561,7 @@ sure of changing the value of `foo'."
(not (string-match "failed" response))))
(setq done process)
(if (memq (process-status process) '(open run))
(imap-send-command "LOGOUT"))
(imap-logout))
(delete-process process)
nil)))))
done))
@ -632,7 +636,7 @@ sure of changing the value of `foo'."
(not (string-match "failed" response))))
(setq done process)
(if (memq (process-status process) '(open run))
(imap-send-command "LOGOUT"))
(imap-logout))
(delete-process process)
nil)))))
done))
@ -915,14 +919,27 @@ Returns t if login was successful, nil otherwise."
(and (not (imap-capability 'LOGINDISABLED buffer))
(not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
(defun imap-quote-specials (string)
(with-temp-buffer
(insert string)
(goto-char (point-min))
(while (re-search-forward "[\\\"]" nil t)
(forward-char -1)
(insert "\\")
(forward-char 1))
(buffer-string)))
(defun imap-login-auth (buffer)
"Login to server using the LOGIN command."
(message "imap: Plaintext authentication...")
(imap-interactive-login buffer
(lambda (user passwd)
(imap-ok-p (imap-send-command-wait
(concat "LOGIN \"" user "\" \""
passwd "\""))))))
(concat "LOGIN \""
(imap-quote-specials user)
"\" \""
(imap-quote-specials passwd)
"\""))))))
(defun imap-anonymous-p (buffer)
t)
@ -934,6 +951,66 @@ Returns t if login was successful, nil otherwise."
(concat "LOGIN anonymous \"" (concat (user-login-name) "@"
(system-name)) "\"")))))
;;; Compiler directives.
(defvar imap-sasl-client)
(defvar imap-sasl-step)
(defun imap-sasl-make-mechanisms (buffer)
(let ((mecs '()))
(mapc (lambda (sym)
(let ((name (symbol-name sym)))
(if (and (> (length name) 5)
(string-equal "AUTH=" (substring name 0 5 )))
(setq mecs (cons (substring name 5) mecs)))))
(imap-capability nil buffer))
mecs))
(defun imap-sasl-auth-p (buffer)
(and (condition-case ()
(require 'sasl)
(error nil))
(sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
(defun imap-sasl-auth (buffer)
"Login to server using the SASL method."
(message "imap: Authenticating using SASL...")
(with-current-buffer buffer
(make-local-variable 'imap-username)
(make-local-variable 'imap-sasl-client)
(make-local-variable 'imap-sasl-step)
(let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
logged user)
(while (not logged)
(setq user (or imap-username
(read-from-minibuffer
(concat "IMAP username for " imap-server " using SASL "
(sasl-mechanism-name mechanism) ": ")
(or user imap-default-user))))
(when user
(setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
imap-sasl-step (sasl-next-step imap-sasl-client nil))
(let ((tag (imap-send-command
(if (sasl-step-data imap-sasl-step)
(format "AUTHENTICATE %s %s"
(sasl-mechanism-name mechanism)
(sasl-step-data imap-sasl-step))
(format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
buffer)))
(while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
(sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
(setq imap-continuation nil
imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
(imap-send-command-1 (if (sasl-step-data imap-sasl-step)
(base64-encode-string (sasl-step-data imap-sasl-step) t)
"")))
(if (imap-ok-p (imap-wait-for-tag tag))
(setq imap-username user
logged t)
(message "Login failed...")
(sit-for 1)))))
logged)))
(defun imap-digest-md5-p (buffer)
(and (imap-capability 'AUTH=DIGEST-MD5 buffer)
(condition-case ()
@ -1006,7 +1083,7 @@ necessary. If nil, the buffer name is generated."
(with-current-buffer (get-buffer-create buffer)
(if (imap-opened buffer)
(imap-close buffer))
(mapcar 'make-local-variable imap-local-variables)
(mapc 'make-local-variable imap-local-variables)
(imap-disable-multibyte)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
@ -1029,7 +1106,7 @@ necessary. If nil, the buffer name is generated."
(if (not (eq imap-default-stream stream))
(with-current-buffer (get-buffer-create
(generate-new-buffer-name " *temp*"))
(mapcar 'make-local-variable imap-local-variables)
(mapc 'make-local-variable imap-local-variables)
(imap-disable-multibyte)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
@ -1084,7 +1161,7 @@ password is remembered in the buffer."
(with-current-buffer (or buffer (current-buffer))
(if (not (eq imap-state 'nonauth))
(or (eq imap-state 'auth)
(eq imap-state 'select)
(eq imap-state 'selected)
(eq imap-state 'examine))
(make-local-variable 'imap-username)
(make-local-variable 'imap-password)
@ -1118,7 +1195,7 @@ If BUFFER is nil, the current buffer is used."
(with-current-buffer (or buffer (current-buffer))
(when (imap-opened)
(condition-case nil
(imap-send-command-wait "LOGOUT")
(imap-logout-wait)
(quit nil)))
(when (and imap-process
(memq (process-status imap-process) '(open run)))
@ -1141,6 +1218,26 @@ If BUFFER is nil, the current buffer is assumed."
(memq (intern (upcase (symbol-name identifier))) imap-capability)
imap-capability)))
(defun imap-id (&optional list-of-values buffer)
"Identify client to server in BUFFER, and return server identity.
LIST-OF-VALUES is nil, or a plist with identifier and value
strings to send to the server to identify the client.
Return a list of identifiers which server in BUFFER support, or
nil if it doesn't support ID or returns no information.
If BUFFER is nil, the current buffer is assumed."
(with-current-buffer (or buffer (current-buffer))
(when (and (imap-capability 'ID)
(imap-ok-p (imap-send-command-wait
(if (null list-of-values)
"ID NIL"
(concat "ID (" (mapconcat (lambda (el)
(concat "\"" el "\""))
list-of-values
" ") ")")))))
imap-id)))
(defun imap-namespace (&optional buffer)
"Return a namespace hierarchy at server in BUFFER.
If BUFFER is nil, the current buffer is assumed."
@ -1153,6 +1250,28 @@ If BUFFER is nil, the current buffer is assumed."
(defun imap-send-command-wait (command &optional buffer)
(imap-wait-for-tag (imap-send-command command buffer) buffer))
(defun imap-logout (&optional buffer)
(or buffer (setq buffer (current-buffer)))
(if imap-logout-timeout
(with-timeout (imap-logout-timeout
(condition-case nil
(with-current-buffer buffer
(delete-process imap-process))
(error)))
(imap-send-command "LOGOUT" buffer))
(imap-send-command "LOGOUT" buffer)))
(defun imap-logout-wait (&optional buffer)
(or buffer (setq buffer (current-buffer)))
(if imap-logout-timeout
(with-timeout (imap-logout-timeout
(condition-case nil
(with-current-buffer buffer
(delete-process imap-process))
(error)))
(imap-send-command-wait "LOGOUT" buffer))
(imap-send-command-wait "LOGOUT" buffer)))
;; Mailbox functions:
@ -2106,6 +2225,8 @@ Return nil if no complete line has arrived."
(read (concat "(" (upcase (buffer-substring
(point) (point-max)))
")"))))
(ID (setq imap-id (read (buffer-substring (point)
(point-max)))))
(ACL (imap-parse-acl))
(t (case (prog1 (read (current-buffer))
(imap-forward))
@ -2460,7 +2581,7 @@ Return nil if no complete line has arrived."
;; next line for Courier IMAP bug.
(skip-chars-forward " ")
(point)))
(> (skip-chars-forward "^ )" (imap-point-at-eol)) 0))
(> (skip-chars-forward "^ )" (point-at-eol)) 0))
(push (buffer-substring start (point)) flag-list))
(assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
(imap-forward)
@ -2740,99 +2861,99 @@ Return nil if no complete line has arrived."
(when imap-debug ; (untrace-all)
(require 'trace)
(buffer-disable-undo (get-buffer-create imap-debug-buffer))
(mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
'(
imap-utf7-encode
imap-utf7-decode
imap-error-text
imap-kerberos4s-p
imap-kerberos4-open
imap-ssl-p
imap-ssl-open
imap-network-p
imap-network-open
imap-interactive-login
imap-kerberos4a-p
imap-kerberos4-auth
imap-cram-md5-p
imap-cram-md5-auth
imap-login-p
imap-login-auth
imap-anonymous-p
imap-anonymous-auth
imap-open-1
imap-open
imap-opened
imap-authenticate
imap-close
imap-capability
imap-namespace
imap-send-command-wait
imap-mailbox-put
imap-mailbox-get
imap-mailbox-map-1
imap-mailbox-map
imap-current-mailbox
imap-current-mailbox-p-1
imap-current-mailbox-p
imap-mailbox-select-1
imap-mailbox-select
imap-mailbox-examine-1
imap-mailbox-examine
imap-mailbox-unselect
imap-mailbox-expunge
imap-mailbox-close
imap-mailbox-create-1
imap-mailbox-create
imap-mailbox-delete
imap-mailbox-rename
imap-mailbox-lsub
imap-mailbox-list
imap-mailbox-subscribe
imap-mailbox-unsubscribe
imap-mailbox-status
imap-mailbox-acl-get
imap-mailbox-acl-set
imap-mailbox-acl-delete
imap-current-message
imap-list-to-message-set
imap-fetch-asynch
imap-fetch
imap-message-put
imap-message-get
imap-message-map
imap-search
imap-message-flag-permanent-p
imap-message-flags-set
imap-message-flags-del
imap-message-flags-add
imap-message-copyuid-1
imap-message-copyuid
imap-message-copy
imap-message-appenduid-1
imap-message-appenduid
imap-message-append
imap-body-lines
imap-envelope-from
imap-send-command-1
imap-send-command
imap-wait-for-tag
imap-sentinel
imap-find-next-line
imap-arrival-filter
imap-parse-greeting
imap-parse-response
imap-parse-resp-text
imap-parse-resp-text-code
imap-parse-data-list
imap-parse-fetch
imap-parse-status
imap-parse-acl
imap-parse-flag-list
imap-parse-envelope
imap-parse-body-extension
imap-parse-body
)))
(mapc (lambda (f) (trace-function-background f imap-debug-buffer))
'(
imap-utf7-encode
imap-utf7-decode
imap-error-text
imap-kerberos4s-p
imap-kerberos4-open
imap-ssl-p
imap-ssl-open
imap-network-p
imap-network-open
imap-interactive-login
imap-kerberos4a-p
imap-kerberos4-auth
imap-cram-md5-p
imap-cram-md5-auth
imap-login-p
imap-login-auth
imap-anonymous-p
imap-anonymous-auth
imap-open-1
imap-open
imap-opened
imap-authenticate
imap-close
imap-capability
imap-namespace
imap-send-command-wait
imap-mailbox-put
imap-mailbox-get
imap-mailbox-map-1
imap-mailbox-map
imap-current-mailbox
imap-current-mailbox-p-1
imap-current-mailbox-p
imap-mailbox-select-1
imap-mailbox-select
imap-mailbox-examine-1
imap-mailbox-examine
imap-mailbox-unselect
imap-mailbox-expunge
imap-mailbox-close
imap-mailbox-create-1
imap-mailbox-create
imap-mailbox-delete
imap-mailbox-rename
imap-mailbox-lsub
imap-mailbox-list
imap-mailbox-subscribe
imap-mailbox-unsubscribe
imap-mailbox-status
imap-mailbox-acl-get
imap-mailbox-acl-set
imap-mailbox-acl-delete
imap-current-message
imap-list-to-message-set
imap-fetch-asynch
imap-fetch
imap-message-put
imap-message-get
imap-message-map
imap-search
imap-message-flag-permanent-p
imap-message-flags-set
imap-message-flags-del
imap-message-flags-add
imap-message-copyuid-1
imap-message-copyuid
imap-message-copy
imap-message-appenduid-1
imap-message-appenduid
imap-message-append
imap-body-lines
imap-envelope-from
imap-send-command-1
imap-send-command
imap-wait-for-tag
imap-sentinel
imap-find-next-line
imap-arrival-filter
imap-parse-greeting
imap-parse-response
imap-parse-resp-text
imap-parse-resp-text-code
imap-parse-data-list
imap-parse-fetch
imap-parse-status
imap-parse-acl
imap-parse-flag-list
imap-parse-envelope
imap-parse-body-extension
imap-parse-body
)))
(provide 'imap)

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