mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-23 22:20:24 -08:00
Merge changes made in Gnus trunk.
nnir.el: Batch header retrieval. proto-stream.el: New library to provide protocol-specific TLS/STARTTLS connections for IMAP, NNTP, SMTP, POP3 and similar protocols. nnimap.el (nnimap-open-connection): Use it. proto-stream.el (open-proto-stream): Complete the documentation. nnimap.el (nnimap-open-connection): Check for "OK" from the greeting. nntp.el: Use proto-streams for the relevant connections types. nntp.el (nntp-open-connection): Switch on STARTTLS on supported servers. proto-stream.el (open-proto-stream): Add a way to specify what the end of a command is. proto-stream.el (proto-stream-open-tls): Delete output from openssl if we're using tls.el. proto-stream.el (proto-stream-open-network): If we don't have gnutls-cli or gnutls built in, then don't try to establish a STARTTLS connection. color.el (color-lab->srgb): Fix function call name. proto-stream.el: Fix the syntax in the comment. nntp.el (nntp-open-connection): Fix the STARTTLS command syntax. proto-stream.el (proto-stream-open-starttls): Actually implement the starttls.el STARTTLS. proto-stream.el (proto-stream-always-use-starttls): New variable. proto-stream.el (proto-stream-open-starttls): De-duplicate the starttls code. proto-stream.el (proto-stream-open-starttls): Folded back into the main function. proto-stream.el (proto-stream-command): Refactor out. nnimap.el (nnimap-stream): Change default to `undecided'. nnimap.el (nnimap-open-connection): If `nnimap-stream' is `undecided', try ssl first, and then network. nnimap.el (nnimap-open-connection-1): Respect nnimap-server-port. nnimap.el (nnimap-open-connection): Be more backwards-compatible. proto-stream.el (open-protocol-stream): Renamed from open-proto-stream. proto-stream.el (proto-stream-open-network): When doing opportunistic TLS upgrades we don't really care about the identity of the peer. gnus.texi (Customizing the IMAP Connection): Note the new defaults. gnus.texi (Direct Functions): Note the STARTTLS upgrade. proto-stream.el (proto-stream-open-network): Force starttls.el to use gnutls-cli, since that what we've checked for. proto-stream.el (proto-stream-always-use-starttls): Only default to t if open-gnutls-stream exists. proto-stream.el (proto-stream-open-network): If STARTTLS failed, then just open a normal connection. proto-stream.el (proto-stream-open-network): Wait until the greeting before doing STARTTLS. nnimap.el (nnimap-open-connection-1): Always upgrade to STARTTLS (for backwards compatibility). nnimap.el (nnimap-open-connection-1): Really respect nnimap-server-port. nntp.el (nntp-open-connection): Provide a :success condition. nnimap.el (nnimap-open-connection-1): Ditto. proto-stream.el (proto-stream-open-network): See what the response to the STARTTLS command is. proto-stream.el (proto-stream-open-network): Add some comments. proto-stream.el: Fix example. proto-stream.el (open-protocol-stream): Actually mention the STARTTLS upgrade. nnir.el (nnir-get-active): Skip nnir-ignored-newsgroups when searching. nnir.el (nnir-ignore-newsgroups): Fix default value. nnir.el (nnir-run-gmane): Use mm-delete-duplicates instead of delete-dups that is not available in XEmacs 21.4. mm-util.el (mm-delete-duplicates): Add comment. gnus-sum.el (gnus-summary-delete-article): If delete fails don't change the registry. nnimap.el (nnimap-open-connection-1): w32 open-network-stream doesn't seem to accept strings-with-numbers as port numbers. color.el: fix docstring to use English rather than math notation for intervals. shr.el (shr-find-fill-point): Don't break before apostrophes. nnir.el (nnir-request-move-article): Bail out if no move support in group. color.el (color-rgb->hsv): Fix docstring. nnir.el (nnir-get-active): Improve active list retrieval. shr.el (shr-find-fill-point): Work better for kinsoku chars and apostrophes. gnus-gravatar.el (gnus-gravatar-size): Set gnus-gravatar-size to nil. nnimap.el (nnimap-open-connection-1): Use gnus-string-match-p. nnimap.el (nnimap-open-connection-1): Fix PREAUTH. proto-stream.el (open-protocol-stream): All starttls connections are handled by the network handler. gnus-gravatar.el (gnus-gravatar-insert): Delete unnecessary binding to t of inhibit-read-only since it is inside gnus-with-article-headers. gnus-gravatar.el (gnus-gravatar-transform-address): Use mail-extract-address-components that supports non-ASCII names rather than mail-header-parse-addresses. shr.el (shr-find-fill-point): Don't break line between kinsoku-bol characters. gnus-gravatar.el (gnus-gravatar-insert): Allow LWSP in the middle of names. nnmaildir.el (nnmaildir-request-set-mark): Add article to add-mark funcall. gnus-msg.el: Remove nastygram thing. message.el (message-from-style): Fix comment. message.el (message-user-organization): Do not use gnus-local-organization. gnus.el: Remove gnus-local-organization. rtree.el: New file to handle range trees. nnir.el, gnus-sum.el: Redo the way nnir handles registry updates. rtree.el (rtree-extract): Simplify. gnus-win.el (gnus-configure-windows): Remove Gnus 3.x setting support. gnus-msg.el: Mark gnus-outgoing-message-group as obsolete. gnus.texi (Archived Messages): Remove gnus-outgoing-message-group. gnus-win.el (gnus-configure-frame): Remove old compatibility code. rtree.el (rtree-memq): Rewrite it as a non-recursive function. rtree.el (rtree-add, rtree-delq, rtree-length): Implement. rtree.el (rtree-add): Make code slightly faster. nnir.el: Allow modified summary-line-format in nnir summary buffers.
This commit is contained in:
Gnus developers
Katsumi Yamaoka
parent
66feec8bbe
commit
ed79719399
18 changed files with 1518 additions and 821 deletions
|
|
@ -1,3 +1,12 @@
|
|||
2010-12-02 Julien Danjou <julien@danjou.info>
|
||||
|
||||
* gnus.texi (Archived Messages): Remove gnus-outgoing-message-group.
|
||||
|
||||
2010-11-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* gnus.texi (Customizing the IMAP Connection): Note the new defaults.
|
||||
(Direct Functions): Note the STARTTLS upgrade.
|
||||
|
||||
2010-11-27 Glenn Morris <rgm@gnu.org>
|
||||
James Clark <none@example.com>
|
||||
|
||||
|
|
|
|||
|
|
@ -13342,21 +13342,6 @@ case you should set @code{gnus-message-archive-group} to @code{nil};
|
|||
this will disable archiving.
|
||||
|
||||
@table @code
|
||||
@item gnus-outgoing-message-group
|
||||
@vindex gnus-outgoing-message-group
|
||||
All outgoing messages will be put in this group. If you want to store
|
||||
all your outgoing mail and articles in the group @samp{nnml:archive},
|
||||
you set this variable to that value. This variable can also be a list of
|
||||
group names.
|
||||
|
||||
If you want to have greater control over what group to put each
|
||||
message in, you can set this variable to a function that checks the
|
||||
current newsgroup name and then returns a suitable group name (or list
|
||||
of names).
|
||||
|
||||
This variable can be used instead of @code{gnus-message-archive-group},
|
||||
but the latter is the preferred method.
|
||||
|
||||
@item gnus-gcc-mark-as-read
|
||||
@vindex gnus-gcc-mark-as-read
|
||||
If non-@code{nil}, automatically mark @code{Gcc} articles as read.
|
||||
|
|
@ -14453,7 +14438,9 @@ functions is also affected by commonly understood variables
|
|||
@findex nntp-open-network-stream
|
||||
@item nntp-open-network-stream
|
||||
This is the default, and simply connects to some port or other on the
|
||||
remote system.
|
||||
remote system. If both Emacs and the server supports it, the
|
||||
connection will be upgraded to an encrypted @acronym{STARTTLS}
|
||||
connection automatically.
|
||||
|
||||
@findex nntp-open-tls-stream
|
||||
@item nntp-open-tls-stream
|
||||
|
|
@ -14887,12 +14874,17 @@ typical port would be @code{"imap"} or @code{"imaps"}.
|
|||
How @code{nnimap} should connect to the server. Possible values are:
|
||||
|
||||
@table @code
|
||||
@item undecided
|
||||
This is the default, and this first tries the @code{ssl} setting, and
|
||||
then tries the @code{network} setting.
|
||||
|
||||
@item ssl
|
||||
This is the default, and this uses standard
|
||||
@acronym{TLS}/@acronym{SSL} connection.
|
||||
This uses standard @acronym{TLS}/@acronym{SSL} connections.
|
||||
|
||||
@item network
|
||||
Non-encrypted and unsafe straight socket connection.
|
||||
Non-encrypted and unsafe straight socket connection, but will upgrade
|
||||
to encrypted @acronym{STARTTLS} if both Emacs and the server
|
||||
supports it.
|
||||
|
||||
@item starttls
|
||||
Encrypted @acronym{STARTTLS} over the normal @acronym{IMAP} port.
|
||||
|
|
|
|||
|
|
@ -1,3 +1,228 @@
|
|||
2010-12-02 Andrew Cohen <cohen@andy.bu.edu>
|
||||
|
||||
* nnir.el (nnir-summary-line-format): New variable.
|
||||
(nnir-mode): Use it.
|
||||
(nnir-artlist-*,nnir-aritem-*): Reimplement as macros.
|
||||
(nnir-article-ids): Reimplement as defsubst.
|
||||
(nnir-retrieve-headers): Don't mangle the subject header.
|
||||
(nnir-run-imap): Use 100 as RSV score.
|
||||
(nnir-run-find-grep): Fix for full server searching.
|
||||
(nnir-run-gmane): Better restriction to gmane groups.
|
||||
|
||||
* gnus-sum.el (gnus-summary-line-format-alist): Add specs for nnir
|
||||
summary buffers.
|
||||
|
||||
2010-12-02 Julien Danjou <julien@danjou.info>
|
||||
|
||||
* gnus-win.el (gnus-configure-frame): Remove old compatibility code.
|
||||
|
||||
* gnus-msg.el: Mark gnus-outgoing-message-group as obsolete.
|
||||
|
||||
* gnus-win.el (gnus-configure-windows): Remove Gnus 3.x setting
|
||||
support.
|
||||
|
||||
2010-12-01 Andrew Cohen <cohen@andy.bu.edu>
|
||||
|
||||
* nnir.el: Update to handle the registry better.
|
||||
(autoload): Silence byte-compiler.
|
||||
(nnir-open-server): Add a hook for nnir groups.
|
||||
(nnir-request-move-article): Don't mangle the header. Better to use
|
||||
formating variables (which will be added in the future).
|
||||
(nnir-registry-action): Update the registry using the original article
|
||||
group name.
|
||||
(nnir-mode): Install nnir-specific hooks for updating the registry.
|
||||
|
||||
* gnus-sum.el
|
||||
(gnus-article-original-subject,gnus-newsgroup-original-name): Remove
|
||||
obsolete variables.
|
||||
(gnus-summary-move-article): Remove use of obsolete variables.
|
||||
(gnus-summary-local-variables): Make move and delete hooks local to
|
||||
summary buffers.
|
||||
|
||||
2010-12-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* rtree.el: New file.
|
||||
|
||||
2010-12-01 Julien Danjou <julien@danjou.info>
|
||||
|
||||
* message.el (message-user-organization): Do not use
|
||||
gnus-local-organization.
|
||||
|
||||
* gnus.el: Remove gnus-local-organization.
|
||||
|
||||
* gnus-msg.el: Remove nastygram thing.
|
||||
|
||||
2010-12-01 Teodor Zlatanov <tzz@lifelogs.com>
|
||||
|
||||
* nnmaildir.el (nnmaildir-request-set-mark): Add article to add-mark
|
||||
funcall.
|
||||
|
||||
2010-12-01 Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
|
||||
* gnus-gravatar.el (gnus-gravatar-insert): Allow LWSP in the middle of
|
||||
names.
|
||||
|
||||
* shr.el (shr-find-fill-point): Don't break line between kinsoku-bol
|
||||
characters.
|
||||
|
||||
* gnus-gravatar.el (gnus-gravatar-insert): Delete unnecessary binding
|
||||
to t of inhibit-read-only since it is inside gnus-with-article-headers.
|
||||
Suggested by Štěpán Němec <stepnem@gmail.com>.
|
||||
(gnus-gravatar-transform-address): Use mail-extract-address-components
|
||||
that supports non-ASCII names rather than mail-header-parse-addresses.
|
||||
|
||||
2010-11-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* proto-stream.el (open-protocol-stream): All starttls connections are
|
||||
handled by the network handler.
|
||||
|
||||
2010-11-30 Julien Danjou <julien@danjou.info>
|
||||
|
||||
* nnimap.el (nnimap-open-connection-1): Use gnus-string-match-p.
|
||||
(nnimap-open-connection-1): Fix PREAUTH.
|
||||
|
||||
* gnus-gravatar.el (gnus-gravatar-size): Set gnus-gravatar-size to nil.
|
||||
|
||||
2010-11-30 Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
|
||||
* shr.el (shr-char-breakable-p, shr-char-nospace-p)
|
||||
(shr-char-kinsoku-bol-p, shr-char-kinsoku-eol-p): New macros.
|
||||
(shr-insert): Use them.
|
||||
(shr-find-fill-point): Work better for kinsoku chars and apostrophes.
|
||||
|
||||
2010-11-29 Andrew Cohen <cohen@andy.bu.edu>
|
||||
|
||||
* nnir.el (nnir-request-move-article): Bail out if original group
|
||||
doesn't support article moves.
|
||||
(nnir-get-active): Improve active list retrieval.
|
||||
|
||||
2010-11-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* shr.el (shr-find-fill-point): Don't break before apostrophes.
|
||||
|
||||
2010-11-29 Binjo <binjo.cn@gmail.com> (tiny change)
|
||||
|
||||
* nnimap.el (nnimap-open-connection-1): w32 open-network-stream doesn't
|
||||
seem to accept strings-with-numbers as port numbers,
|
||||
|
||||
2010-11-29 Andrew Cohen <cohen@andy.bu.edu>
|
||||
|
||||
* gnus-sum.el (gnus-summary-delete-article): If delete fails don't
|
||||
change the registry.
|
||||
|
||||
2010-11-29 Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
|
||||
* nnir.el (nnir-run-gmane): Use mm-delete-duplicates instead of
|
||||
delete-dups that is not available in XEmacs 21.4.
|
||||
|
||||
* mm-util.el (mm-delete-duplicates): Add comment.
|
||||
|
||||
2010-11-28 Andrew Cohen <cohen@andy.bu.edu>
|
||||
|
||||
* nnir.el (nnir-ignored-newsgroups): New variable.
|
||||
(nnir-get-active): Use it.
|
||||
|
||||
2010-11-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* proto-stream.el (proto-stream-open-network): Add some comments.
|
||||
|
||||
* nntp.el (nntp-open-connection): Provide a :success condition.
|
||||
|
||||
* nnimap.el (nnimap-open-connection-1): Ditto.
|
||||
|
||||
* proto-stream.el (proto-stream-open-network): See what the response to
|
||||
the STARTTLS command is.
|
||||
|
||||
* nnimap.el (nnimap-open-connection-1): Always upgrade to STARTTLS (for
|
||||
backwards compatibility).
|
||||
(nnimap-open-connection-1): Really respect nnimap-server-port.
|
||||
|
||||
* proto-stream.el (proto-stream-open-network): When doing opportunistic
|
||||
TLS upgrades we don't really care about the identity of the peer.
|
||||
(proto-stream-open-network): Force starttls.el to use gnutls-cli, since
|
||||
that what we've checked for.
|
||||
(proto-stream-always-use-starttls): Only default to t if
|
||||
open-gnutls-stream exists.
|
||||
(proto-stream-open-network): If STARTTLS failed, then just open a
|
||||
normal connection.
|
||||
(proto-stream-open-network): Wait until the greeting before doing
|
||||
STARTTLS.
|
||||
|
||||
* nntp.el (nntp-open-connection): Report what the connection error is.
|
||||
|
||||
* proto-stream.el (open-protocol-stream): Renamed from
|
||||
open-proto-stream.
|
||||
|
||||
2010-11-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* nnimap.el (nnimap-stream): Change default to `undecided'.
|
||||
(nnimap-open-connection): If `nnimap-stream' is `undecided', try ssl
|
||||
first, and then network.
|
||||
(nnimap-open-connection-1): Respect nnimap-server-port.
|
||||
(nnimap-open-connection): Be more backwards-compatible.
|
||||
|
||||
* proto-stream.el (proto-stream-always-use-starttls): New variable.
|
||||
(proto-stream-open-starttls): De-duplicate the starttls code.
|
||||
(proto-stream-open-starttls): Folded back into the main function.
|
||||
(proto-stream-open-network): Fix typo in the gnutls path.
|
||||
(proto-stream-command): Refactor out.
|
||||
|
||||
* nntp.el (nntp-open-connection): Fix the STARTTLS command syntax.
|
||||
|
||||
* proto-stream.el (proto-stream-open-starttls): Actually implement the
|
||||
starttls.el STARTTLS.
|
||||
|
||||
* color.el (color-lab->srgb): Fix function call name.
|
||||
|
||||
* proto-stream.el (proto-stream-open-tls): Delete output from openssl
|
||||
if we're using tls.el.
|
||||
(proto-stream-open-network): If we don't have gnutls-cli or gnutls
|
||||
built in, then don't try to establish a STARTTLS connection.
|
||||
|
||||
* nntp.el (nntp-open-connection): Switch on STARTTLS on supported
|
||||
servers.
|
||||
|
||||
* proto-stream.el (open-proto-stream): Use network, not stream.
|
||||
(open-proto-stream): Add a way to specify what the end of a command is.
|
||||
|
||||
* nntp.el (nntp-open-connection): Use proto-streams for the relevant
|
||||
connections types.
|
||||
(nntp-open-network-stream): Remove.
|
||||
(nntp-open-ssl-stream): Remove.
|
||||
(nntp-open-tls-stream): Remove.
|
||||
(nntp-ssl-program): Remove.
|
||||
|
||||
* nnimap.el (nnimap-open-connection): Check for "OK" from the greeting.
|
||||
|
||||
2010-11-27 Andrew Cohen <cohen@andy.bu.edu>
|
||||
|
||||
* nnir.el: Fix typos.
|
||||
(nnir-retrieve-headers-override-function): Rename variable to reflect
|
||||
new semantics.
|
||||
(nnir-article-group, nnir-article-number, nnir-article-rsv): New helper
|
||||
macros.
|
||||
(nnir-request-article, nnir-request-move-article): Use them.
|
||||
(nnir-categorize): New function.
|
||||
(nnir-run-query): Use it.
|
||||
(nnir-retrieve-headers): Rewrite to batch header retrieval.
|
||||
(nnir-run-gmane): nnir-retrieve-headers now returns the headers already
|
||||
sorted.
|
||||
(nnir-group-full-name): Use gnus-group-full-name instead.
|
||||
(nnir-artlist-artitem-group, nnir-artlist-artitem-number)
|
||||
(nnir-artlist-artitem-rsv, nnir-sort-groups-by-server): Obsolete.
|
||||
|
||||
2010-11-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* nnimap.el (nnimap-open-connection): Fix typo in STARTTLS command.
|
||||
|
||||
* proto-stream.el: New library to provide protocol-specific
|
||||
TLS/STARTTLS connections for IMAP, NNTP, SMTP, POP3 and similar
|
||||
protocols.
|
||||
(open-proto-stream): Complete the documentation.
|
||||
(proto-stream-open-network): Fix some typos.
|
||||
|
||||
* nnimap.el (nnimap-open-connection): Use it.
|
||||
|
||||
2010-11-27 Yuri Karaban <tech@askold.net> (tiny change)
|
||||
|
||||
* pop3.el (pop3-open-server): Read server greeting before starting TLS
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
|
||||
(defun color-rgb->hex (red green blue)
|
||||
"Return hexadecimal notation for RED GREEN BLUE color.
|
||||
RED GREEN BLUE must be values between [0,1]."
|
||||
RED GREEN BLUE must be values between 0 and 1 inclusively."
|
||||
(format "#%02x%02x%02x"
|
||||
(* red 255) (* green 255) (* blue 255)))
|
||||
|
||||
|
|
@ -53,7 +53,8 @@ RED GREEN BLUE must be values between [0,1]."
|
|||
|
||||
(defun color-rgb->hsv (red green blue)
|
||||
"Convert RED GREEN BLUE values to HSV representation.
|
||||
Hue is in radian. Saturation and values are between [0,1]."
|
||||
Hue is in radians. Saturation and values are between 0 and 1
|
||||
inclusively."
|
||||
(let* ((r (float red))
|
||||
(g (float green))
|
||||
(b (float blue))
|
||||
|
|
@ -80,7 +81,7 @@ Hue is in radian. Saturation and values are between [0,1]."
|
|||
|
||||
(defun color-rgb->hsl (red green blue)
|
||||
"Convert RED GREEN BLUE colors to their HSL representation.
|
||||
RED, GREEN and BLUE must be between [0,1]."
|
||||
RED, GREEN and BLUE must be between 0 and 1 inclusively."
|
||||
(let* ((r red)
|
||||
(g green)
|
||||
(b blue)
|
||||
|
|
@ -108,7 +109,7 @@ RED, GREEN and BLUE must be between [0,1]."
|
|||
|
||||
(defun color-srgb->xyz (red green blue)
|
||||
"Converts RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
|
||||
RED, BLUE and GREEN must be between [0,1]."
|
||||
RED, BLUE and GREEN must be between 0 and 1 inclusively."
|
||||
(let ((r (if (<= red 0.04045)
|
||||
(/ red 12.95)
|
||||
(expt (/ (+ red 0.055) 1.055) 2.4)))
|
||||
|
|
@ -191,12 +192,12 @@ none is set, `color-d65-xyz' is used."
|
|||
(apply 'color-xyz->lab (color-srgb->xyz red green blue)))
|
||||
|
||||
(defun color-rgb->normalize (color)
|
||||
"Normalize a RGB color to values between [0,1]."
|
||||
"Normalize a RGB color to values between 0 and 1 inclusively."
|
||||
(mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))
|
||||
|
||||
(defun color-lab->srgb (L a b)
|
||||
"Converts CIE L*a*b* to RGB."
|
||||
(apply 'color-xyz->rgb (color-lab->xyz L a b)))
|
||||
(apply 'color-xyz->srgb (color-lab->xyz L a b)))
|
||||
|
||||
(defun color-cie-de2000 (color1 color2 &optional kL kC kH)
|
||||
"Computes the CIEDE2000 color distance between COLOR1 and COLOR2.
|
||||
|
|
|
|||
|
|
@ -26,13 +26,15 @@
|
|||
|
||||
(require 'gravatar)
|
||||
(require 'gnus-art)
|
||||
(require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'.
|
||||
|
||||
(defgroup gnus-gravatar nil
|
||||
"Gnus Gravatar."
|
||||
:group 'gnus-visual)
|
||||
|
||||
(defcustom gnus-gravatar-size 32
|
||||
"How big should gravatars be displayed."
|
||||
(defcustom gnus-gravatar-size nil
|
||||
"How big should gravatars be displayed.
|
||||
If nil, default to `gravatar-size'."
|
||||
:type 'integer
|
||||
:version "24.1"
|
||||
:group 'gnus-gravatar)
|
||||
|
|
@ -51,30 +53,25 @@
|
|||
|
||||
(defun gnus-gravatar-transform-address (header category &optional force)
|
||||
(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))))
|
||||
(let* ((mail-extr-disable-voodoo t)
|
||||
(addresses (mail-extract-address-components
|
||||
(or (mail-fetch-field header) "") t))
|
||||
(gravatar-size gnus-gravatar-size)
|
||||
name)
|
||||
(dolist (address addresses)
|
||||
(when (setq name (cdr address))
|
||||
(setcdr address (setq name (mail-decode-encoded-word-string name))))
|
||||
(when (and (setq name (car address))
|
||||
(string-match "\\` +" name))
|
||||
(setcar address (setq name (substring name (match-end 0)))))
|
||||
(when (or force
|
||||
(not (and gnus-gravatar-too-ugly
|
||||
(or (string-match gnus-gravatar-too-ugly
|
||||
(car address))
|
||||
(cadr address))
|
||||
(and name
|
||||
(string-match gnus-gravatar-too-ugly
|
||||
name))))))
|
||||
(ignore-errors
|
||||
(gravatar-retrieve
|
||||
(car address)
|
||||
(cadr address)
|
||||
'gnus-gravatar-insert
|
||||
(list header address category))))))))
|
||||
|
||||
|
|
@ -87,10 +84,13 @@ Set image category to CATEGORY."
|
|||
(when (buffer-live-p (current-buffer))
|
||||
(gnus-article-goto-header header)
|
||||
(mail-header-narrow-to-field)
|
||||
(let ((real-name (cdr address))
|
||||
(mail-address (car address)))
|
||||
(let ((real-name (car address))
|
||||
(mail-address (cadr address)))
|
||||
(when (if real-name
|
||||
(re-search-forward (concat (regexp-quote real-name) "\\|"
|
||||
(re-search-forward
|
||||
(concat (gnus-replace-in-string
|
||||
(regexp-quote real-name) "[\t ]+" "[\t\n ]+")
|
||||
"\\|"
|
||||
(regexp-quote mail-address))
|
||||
nil t)
|
||||
(search-forward mail-address nil t))
|
||||
|
|
@ -103,8 +103,7 @@ Set image category to CATEGORY."
|
|||
;; example we were fetching someaddress, and then we change to
|
||||
;; another mail with the same someaddress.
|
||||
(unless (memq 'gnus-gravatar (text-properties-at (point)))
|
||||
(let ((inhibit-read-only t)
|
||||
(point (point)))
|
||||
(let ((point (point)))
|
||||
(unless (featurep 'xemacs)
|
||||
(setq gravatar (append gravatar gnus-gravatar-properties)))
|
||||
(gnus-put-image gravatar nil category)
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ method to use when posting."
|
|||
(sexp :tag "Methods" ,gnus-select-method)))
|
||||
|
||||
(defcustom gnus-outgoing-message-group nil
|
||||
"*All outgoing messages will be put in this group.
|
||||
"All outgoing messages will be put in this group.
|
||||
If you want to store all your outgoing mail and articles in the group
|
||||
\"nnml:archive\", you set this variable to that value. This variable
|
||||
can also be a list of group names.
|
||||
|
|
@ -70,6 +70,8 @@ of names)."
|
|||
(string :tag "Group")
|
||||
(repeat :tag "List of groups" (string :tag "Group"))))
|
||||
|
||||
(make-obsolete-variable 'gnus-outgoing-message-group 'gnus-message-archive-group "24.1")
|
||||
|
||||
(defcustom gnus-mailing-list-groups nil
|
||||
"*If non-nil a regexp matching groups that are really mailing lists.
|
||||
This is useful when you're reading a mailing list that has been
|
||||
|
|
@ -397,7 +399,6 @@ Thank you for your help in stamping out bugs.
|
|||
(message-mode-hook (copy-sequence message-mode-hook)))
|
||||
(setq mml-buffer-list nil)
|
||||
(add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
|
||||
(add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
|
||||
;; message-newsreader and message-mailer were formerly set in
|
||||
;; gnus-inews-add-send-actions, but this is too late when
|
||||
;; message-generate-headers-first is used. --ansel
|
||||
|
|
@ -826,7 +827,6 @@ header line with the old Message-ID."
|
|||
(gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
|
||||
message-send-actions)
|
||||
;; Add Gcc header.
|
||||
(gnus-inews-insert-archive-gcc)
|
||||
(gnus-inews-insert-gcc))))
|
||||
|
||||
|
||||
|
|
@ -1294,7 +1294,6 @@ composing a new message."
|
|||
(goto-char (point-max))
|
||||
(insert mail-header-separator)
|
||||
;; Add Gcc header.
|
||||
(gnus-inews-insert-archive-gcc)
|
||||
(gnus-inews-insert-gcc)
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward "^To:\\|^Newsgroups:" nil 'move)
|
||||
|
|
@ -1307,24 +1306,6 @@ See `gnus-summary-mail-forward' for ARG."
|
|||
(interactive "P")
|
||||
(gnus-summary-mail-forward arg t))
|
||||
|
||||
(defvar gnus-nastygram-message
|
||||
"The following article was inappropriately posted to %s.\n\n"
|
||||
"Format string to insert in nastygrams.
|
||||
The current group name will be inserted at \"%s\".")
|
||||
|
||||
(defun gnus-summary-mail-nastygram (n)
|
||||
"Send a nastygram to the author of the current article."
|
||||
(interactive "P")
|
||||
(when (or gnus-expert-user
|
||||
(gnus-y-or-n-p
|
||||
"Really send a nastygram to the author of the current article? "))
|
||||
(let ((group gnus-newsgroup-name))
|
||||
(gnus-summary-reply-with-original n)
|
||||
(set-buffer gnus-message-buffer)
|
||||
(message-goto-body)
|
||||
(insert (format gnus-nastygram-message group))
|
||||
(message-send-and-exit))))
|
||||
|
||||
(defun gnus-summary-mail-crosspost-complaint (n)
|
||||
"Send a complaint about crossposting to the current article(s)."
|
||||
(interactive "P")
|
||||
|
|
@ -1580,7 +1561,6 @@ this is a reply."
|
|||
(gnus-setup-message 'compose-bounce
|
||||
(message-bounce)
|
||||
;; Add Gcc header.
|
||||
(gnus-inews-insert-archive-gcc)
|
||||
(gnus-inews-insert-gcc)
|
||||
;; If there are references, we fetch the article we answered to.
|
||||
(when parent
|
||||
|
|
@ -1694,44 +1674,13 @@ this is a reply."
|
|||
(gnus-group-mark-article-read group (cdr group-art)))
|
||||
(kill-buffer (current-buffer)))))))))
|
||||
|
||||
(defun gnus-inews-insert-gcc ()
|
||||
"Insert Gcc headers based on `gnus-outgoing-message-group'."
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(message-narrow-to-headers)
|
||||
(let* ((group gnus-outgoing-message-group)
|
||||
(gcc (cond
|
||||
((functionp group)
|
||||
(funcall group))
|
||||
((or (stringp group) (listp group))
|
||||
group))))
|
||||
(when gcc
|
||||
(insert "Gcc: "
|
||||
(if (stringp gcc)
|
||||
(if (string-match " " gcc)
|
||||
(concat "\"" gcc "\"")
|
||||
gcc)
|
||||
(mapconcat (lambda (group)
|
||||
(if (string-match " " group)
|
||||
(concat "\"" group "\"")
|
||||
group))
|
||||
gcc " "))
|
||||
"\n"))))))
|
||||
|
||||
(defun gnus-inews-insert-archive-gcc (&optional group)
|
||||
(defun gnus-inews-insert-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)
|
||||
(let* ((group (or group gnus-newsgroup-name))
|
||||
(group (when group (gnus-group-decoded-name group)))
|
||||
(var (or gnus-outgoing-message-group gnus-message-archive-group))
|
||||
(gcc-self-val
|
||||
(and gnus-newsgroup-name
|
||||
(not (equal gnus-newsgroup-name ""))
|
||||
(gnus-group-find-parameter
|
||||
gnus-newsgroup-name 'gcc-self)))
|
||||
(and group (gnus-group-find-parameter group 'gcc-self)))
|
||||
result
|
||||
(groups
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -1310,7 +1310,6 @@ the normal Gnus MIME machinery."
|
|||
(defvar gnus-article-decoded-p nil)
|
||||
(defvar gnus-article-charset nil)
|
||||
(defvar gnus-article-ignored-charsets nil)
|
||||
(defvar gnus-article-original-subject nil)
|
||||
(defvar gnus-scores-exclude-files nil)
|
||||
(defvar gnus-page-broken nil)
|
||||
|
||||
|
|
@ -1336,7 +1335,6 @@ the normal Gnus MIME machinery."
|
|||
(defvar gnus-current-copy-group nil)
|
||||
(defvar gnus-current-crosspost-group nil)
|
||||
(defvar gnus-newsgroup-display nil)
|
||||
(defvar gnus-newsgroup-original-name nil)
|
||||
|
||||
(defvar gnus-newsgroup-dependencies nil)
|
||||
(defvar gnus-newsgroup-adaptive nil)
|
||||
|
|
@ -1363,6 +1361,16 @@ the normal Gnus MIME machinery."
|
|||
(?c (or (mail-header-chars gnus-tmp-header) 0) ?d)
|
||||
(?k (gnus-summary-line-message-size gnus-tmp-header) ?s)
|
||||
(?L gnus-tmp-lines ?s)
|
||||
(?Z (or ,(macroexpand-all
|
||||
'(nnir-article-rsv (mail-header-number gnus-tmp-header)))
|
||||
0) ?d)
|
||||
(?G (or ,(macroexpand-all
|
||||
'(nnir-article-group (mail-header-number gnus-tmp-header)))
|
||||
"") ?s)
|
||||
(?g (or ,(macroexpand-all
|
||||
'(gnus-group-short-name
|
||||
(nnir-article-group (mail-header-number gnus-tmp-header))))
|
||||
"") ?s)
|
||||
(?O gnus-tmp-downloaded ?c)
|
||||
(?I gnus-tmp-indentation ?s)
|
||||
(?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s)
|
||||
|
|
@ -1583,6 +1591,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
|
|||
gnus-newsgroup-prepared gnus-summary-highlight-line-function
|
||||
gnus-current-article gnus-current-headers gnus-have-all-headers
|
||||
gnus-last-article gnus-article-internal-prepare-hook
|
||||
(gnus-summary-article-delete-hook . global)
|
||||
(gnus-summary-article-move-hook . global)
|
||||
gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay
|
||||
gnus-newsgroup-scored gnus-newsgroup-kill-headers
|
||||
gnus-thread-expunge-below
|
||||
|
|
@ -9731,10 +9741,6 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
|
|||
;; Set any marks that may have changed in the summary buffer.
|
||||
(when gnus-preserve-marks
|
||||
(gnus-summary-push-marks-to-backend article))
|
||||
(let ((gnus-newsgroup-original-name gnus-newsgroup-name)
|
||||
(gnus-article-original-subject
|
||||
(mail-header-subject
|
||||
(gnus-data-header (assoc article (gnus-data-list nil))))))
|
||||
(setq
|
||||
art-group
|
||||
(cond
|
||||
|
|
@ -9817,7 +9823,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
|
|||
action
|
||||
(gnus-data-header
|
||||
(assoc article (gnus-data-list nil)))
|
||||
gnus-newsgroup-original-name nil
|
||||
gnus-newsgroup-name nil
|
||||
select-method)))
|
||||
(t
|
||||
(let* ((pto-group (gnus-group-prefixed-name
|
||||
|
|
@ -9916,16 +9922,13 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
|
|||
article gnus-newsgroup-name (current-buffer) t)))
|
||||
|
||||
;; run the move/copy/crosspost/respool hook
|
||||
(let ((header (gnus-data-header
|
||||
(assoc article (gnus-data-list nil)))))
|
||||
(mail-header-set-subject header gnus-article-original-subject)
|
||||
(run-hook-with-args 'gnus-summary-article-move-hook
|
||||
action
|
||||
(gnus-data-header
|
||||
(assoc article (gnus-data-list nil)))
|
||||
gnus-newsgroup-original-name
|
||||
gnus-newsgroup-name
|
||||
to-newsgroup
|
||||
select-method)))
|
||||
select-method))
|
||||
|
||||
;;;!!!Why is this necessary?
|
||||
(set-buffer gnus-summary-buffer)
|
||||
|
|
@ -9934,7 +9937,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
|
|||
(save-excursion
|
||||
(gnus-summary-goto-subject article)
|
||||
(gnus-summary-mark-article article gnus-canceled-mark)))))
|
||||
(push article articles-to-update-marks)))
|
||||
(push article articles-to-update-marks))
|
||||
|
||||
(save-excursion
|
||||
(apply 'gnus-summary-remove-process-mark articles-to-update-marks))
|
||||
|
|
@ -10213,13 +10216,13 @@ confirmation before the articles are deleted."
|
|||
;; The backend might not have been able to delete the article
|
||||
;; after all.
|
||||
(unless (memq (car articles) not-deleted)
|
||||
(gnus-summary-mark-article (car articles) gnus-canceled-mark))
|
||||
(gnus-summary-mark-article (car articles) gnus-canceled-mark)
|
||||
(let* ((article (car articles))
|
||||
(ghead (gnus-data-header
|
||||
(assoc article (gnus-data-list nil)))))
|
||||
(run-hook-with-args 'gnus-summary-article-delete-hook
|
||||
'delete ghead gnus-newsgroup-name nil
|
||||
nil))
|
||||
nil)))
|
||||
(setq articles (cdr articles))))
|
||||
(when not-deleted
|
||||
(gnus-message 4 "Couldn't delete articles %s" not-deleted)))
|
||||
|
|
|
|||
|
|
@ -228,50 +228,6 @@ See the Gnus manual for an explanation of the syntax used.")
|
|||
(pop list))
|
||||
(cadr (assq (car list) gnus-window-configuration)))
|
||||
|
||||
(defun gnus-windows-old-to-new (setting)
|
||||
;; First we take care of the really, really old Gnus 3 actions.
|
||||
(when (symbolp setting)
|
||||
(setq setting
|
||||
;; Take care of ooold GNUS 3.x values.
|
||||
(cond ((eq setting 'SelectArticle) 'article)
|
||||
((memq setting '(SelectNewsgroup SelectSubject ExpandSubject))
|
||||
'summary)
|
||||
((memq setting '(ExitNewsgroup)) 'group)
|
||||
(t setting))))
|
||||
(if (or (listp setting)
|
||||
(not (and gnus-window-configuration
|
||||
(memq setting '(group summary article)))))
|
||||
setting
|
||||
(let* ((elem
|
||||
(cond
|
||||
((eq setting 'group)
|
||||
(gnus-window-configuration-element
|
||||
'(group newsgroups ExitNewsgroup)))
|
||||
((eq setting 'summary)
|
||||
(gnus-window-configuration-element
|
||||
'(summary SelectNewsgroup SelectSubject ExpandSubject)))
|
||||
((eq setting 'article)
|
||||
(gnus-window-configuration-element
|
||||
'(article SelectArticle)))))
|
||||
(total (apply '+ elem))
|
||||
(types '(group summary article))
|
||||
(pbuf (if (eq setting 'newsgroups) 'group 'summary))
|
||||
(i 0)
|
||||
perc out)
|
||||
(while (< i 3)
|
||||
(or (not (numberp (nth i elem)))
|
||||
(zerop (nth i elem))
|
||||
(progn
|
||||
(setq perc (if (= i 2)
|
||||
1.0
|
||||
(/ (float (nth i elem)) total)))
|
||||
(push (if (eq pbuf (nth i types))
|
||||
(list (nth i types) perc 'point)
|
||||
(list (nth i types) perc))
|
||||
out)))
|
||||
(incf i))
|
||||
`(vertical 1.0 ,@(nreverse out)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun gnus-add-configuration (conf)
|
||||
"Add the window configuration CONF to `gnus-buffer-configuration'."
|
||||
|
|
@ -293,18 +249,9 @@ See the Gnus manual for an explanation of the syntax used.")
|
|||
|
||||
(defun gnus-configure-frame (split &optional window)
|
||||
"Split WINDOW according to SPLIT."
|
||||
(let ((current-window
|
||||
(or (get-buffer-window (current-buffer)) (selected-window))))
|
||||
(unless window
|
||||
(setq window current-window))
|
||||
(let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window)))
|
||||
(window (or window current-window)))
|
||||
(select-window window)
|
||||
;; This might be an old-style buffer config.
|
||||
(when (vectorp split)
|
||||
(setq split (append split nil)))
|
||||
(when (or (consp (car split))
|
||||
(vectorp (car split)))
|
||||
(push 1.0 split)
|
||||
(push 'vertical split))
|
||||
;; The SPLIT might be something that is to be evaled to
|
||||
;; return a new SPLIT.
|
||||
(while (and (not (assq (car split) gnus-window-to-buffer))
|
||||
|
|
@ -423,7 +370,6 @@ See the Gnus manual for an explanation of the syntax used.")
|
|||
(set-window-configuration setting)
|
||||
(setq gnus-current-window-configuration setting)
|
||||
(setq force (or force gnus-always-force-window-configuration))
|
||||
(setq setting (gnus-windows-old-to-new setting))
|
||||
(let ((split (if (symbolp setting)
|
||||
(cadr (assq setting gnus-buffer-configuration))
|
||||
setting))
|
||||
|
|
|
|||
|
|
@ -1401,10 +1401,6 @@ no need to set this variable."
|
|||
string))
|
||||
(make-obsolete-variable 'gnus-local-domain nil "Emacs 24.1")
|
||||
|
||||
(defvar gnus-local-organization nil
|
||||
"String with a description of what organization (if any) the user belongs to.
|
||||
Obsolete variable; use `message-user-organization' instead.")
|
||||
|
||||
;; Customization variables
|
||||
|
||||
(defcustom gnus-refer-article-method 'current
|
||||
|
|
|
|||
|
|
@ -160,8 +160,12 @@ If this variable is nil, no such courtesy message will be added."
|
|||
:group 'message-interface
|
||||
:type 'regexp)
|
||||
|
||||
(defcustom message-from-style mail-from-style
|
||||
"*Specifies how \"From\" headers look.
|
||||
(defcustom message-from-style 'default
|
||||
;; In Emacs 24.1 this defaults to the value of `mail-from-style'
|
||||
;; that defaults to:
|
||||
;; `angles' in Emacs 22.1~23.1, XEmacs 21.4, 21.5, and SXEmacs 22.1;
|
||||
;; `system-default' in Emacs 23.2, and 24.1
|
||||
"Specifies how \"From\" headers look.
|
||||
|
||||
If nil, they contain just the return address like:
|
||||
king@grassland.com
|
||||
|
|
@ -507,14 +511,9 @@ This is used by `message-kill-buffer'."
|
|||
:group 'message-buffers
|
||||
:type 'boolean)
|
||||
|
||||
(defvar gnus-local-organization)
|
||||
(defcustom message-user-organization
|
||||
(or (and (boundp 'gnus-local-organization)
|
||||
(stringp gnus-local-organization)
|
||||
gnus-local-organization)
|
||||
(getenv "ORGANIZATION")
|
||||
t)
|
||||
"*String to be used as an Organization header.
|
||||
(or (getenv "ORGANIZATION") t)
|
||||
"String to be used as an Organization header.
|
||||
If t, use `message-user-organization-file'."
|
||||
:group 'message-headers
|
||||
:type '(choice string
|
||||
|
|
|
|||
|
|
@ -974,6 +974,7 @@ If the charset is `composition', return the actual one."
|
|||
;; This is for XEmacs.
|
||||
(mm-mule-charset-to-mime-charset charset)))
|
||||
|
||||
;; `delete-dups' is not available in XEmacs 21.4.
|
||||
(if (fboundp 'delete-dups)
|
||||
(defalias 'mm-delete-duplicates 'delete-dups)
|
||||
(defun mm-delete-duplicates (list)
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@
|
|||
(require 'tls)
|
||||
(require 'parse-time)
|
||||
(require 'nnmail)
|
||||
(require 'proto-stream)
|
||||
|
||||
(eval-when-compile
|
||||
(require 'gnus-sum))
|
||||
|
|
@ -62,9 +63,10 @@
|
|||
If nnimap-stream is `ssl', this will default to `imaps'. If not,
|
||||
it will default to `imap'.")
|
||||
|
||||
(defvoo nnimap-stream 'ssl
|
||||
(defvoo nnimap-stream 'undecided
|
||||
"How nnimap will talk to the IMAP server.
|
||||
Values are `ssl', `network', `starttls' or `shell'.")
|
||||
Values are `ssl', `network', `starttls' or `shell'.
|
||||
The default is to try `ssl' first, and then `network'.")
|
||||
|
||||
(defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
|
||||
(if (listp imap-shell-program)
|
||||
|
|
@ -271,16 +273,6 @@ textual parts.")
|
|||
(push (current-buffer) nnimap-process-buffers)
|
||||
(current-buffer)))
|
||||
|
||||
(defun nnimap-open-shell-stream (name buffer host port)
|
||||
(let ((process-connection-type nil))
|
||||
(start-process name buffer shell-file-name
|
||||
shell-command-switch
|
||||
(format-spec
|
||||
nnimap-shell-program
|
||||
(format-spec-make
|
||||
?s host
|
||||
?p port)))))
|
||||
|
||||
(defun nnimap-credentials (address ports &optional inhibit-create)
|
||||
(let (port credentials)
|
||||
;; Request the credentials from all ports, but only query on the
|
||||
|
|
@ -310,14 +302,28 @@ textual parts.")
|
|||
(* 5 60)))
|
||||
(nnimap-send-command "NOOP")))))))
|
||||
|
||||
(declare-function gnutls-negotiate "gnutls"
|
||||
(proc type &optional priority-string trustfiles keyfiles))
|
||||
|
||||
(defun nnimap-open-connection (buffer)
|
||||
;; Be backwards-compatible -- the earlier value of nnimap-stream was
|
||||
;; `ssl' when nnimap-server-port was nil. Sort of.
|
||||
(when (and nnimap-server-port
|
||||
(eq nnimap-stream 'undecided))
|
||||
(setq nnimap-stream 'ssl))
|
||||
(let ((stream
|
||||
(if (eq nnimap-stream 'undecided)
|
||||
(loop for type in '(ssl network)
|
||||
for stream = (let ((nnimap-stream type))
|
||||
(nnimap-open-connection-1 buffer))
|
||||
while (eq stream 'no-connect)
|
||||
finally (return stream))
|
||||
(nnimap-open-connection-1 buffer))))
|
||||
(if (eq stream 'no-connect)
|
||||
nil
|
||||
stream)))
|
||||
|
||||
(defun nnimap-open-connection-1 (buffer)
|
||||
(unless nnimap-keepalive-timer
|
||||
(setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
|
||||
'nnimap-keepalive)))
|
||||
(block nil
|
||||
(with-current-buffer (nnimap-make-process-buffer buffer)
|
||||
(let* ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary)
|
||||
|
|
@ -325,96 +331,50 @@ textual parts.")
|
|||
(ports
|
||||
(cond
|
||||
((or (eq nnimap-stream 'network)
|
||||
(and (eq nnimap-stream 'starttls)
|
||||
(fboundp 'open-gnutls-stream)))
|
||||
(eq nnimap-stream 'starttls))
|
||||
(nnheader-message 7 "Opening connection to %s..."
|
||||
nnimap-address)
|
||||
(open-network-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(setq port
|
||||
(or nnimap-server-port
|
||||
(if (netrc-find-service-number "imap")
|
||||
"imap"
|
||||
"143"))))
|
||||
'("143" "imap"))
|
||||
((eq nnimap-stream 'shell)
|
||||
(nnheader-message 7 "Opening connection to %s via shell..."
|
||||
nnimap-address)
|
||||
(nnimap-open-shell-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(setq port (or nnimap-server-port "imap")))
|
||||
'("imap"))
|
||||
((eq nnimap-stream 'starttls)
|
||||
(nnheader-message 7 "Opening connection to %s via starttls..."
|
||||
nnimap-address)
|
||||
(let ((tls-program
|
||||
'("openssl s_client -connect %h:%p -no_ssl2 -ign_eof -starttls imap")))
|
||||
(open-tls-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(setq port (or nnimap-server-port "imap"))))
|
||||
'("imap"))
|
||||
((memq nnimap-stream '(ssl tls))
|
||||
(nnheader-message 7 "Opening connection to %s via tls..."
|
||||
nnimap-address)
|
||||
(funcall (if (fboundp 'open-gnutls-stream)
|
||||
'open-gnutls-stream
|
||||
'open-tls-stream)
|
||||
"*nnimap*" (current-buffer) nnimap-address
|
||||
(setq port
|
||||
(or nnimap-server-port
|
||||
(if (netrc-find-service-number "imaps")
|
||||
"imaps"
|
||||
"993"))))
|
||||
'("143" "993" "imap" "imaps"))
|
||||
(t
|
||||
(error "Unknown stream type: %s" nnimap-stream))))
|
||||
connection-result login-result credentials)
|
||||
(setf (nnimap-process nnimap-object)
|
||||
(get-buffer-process (current-buffer)))
|
||||
(if (not (and (nnimap-process nnimap-object)
|
||||
(memq (process-status (nnimap-process nnimap-object))
|
||||
'(open run))))
|
||||
(proto-stream-always-use-starttls t)
|
||||
login-result credentials)
|
||||
(when nnimap-server-port
|
||||
(setq ports (append ports (list nnimap-server-port))))
|
||||
(destructuring-bind (stream greeting capabilities)
|
||||
(open-protocol-stream
|
||||
"*nnimap*" (current-buffer) nnimap-address (car (last ports))
|
||||
:type nnimap-stream
|
||||
:shell-command nnimap-shell-program
|
||||
:capability-command "1 CAPABILITY\r\n"
|
||||
:success " OK "
|
||||
:starttls-function
|
||||
(lambda (capabilities)
|
||||
(when (gnus-string-match-p "STARTTLS" capabilities)
|
||||
"1 STARTTLS\r\n")))
|
||||
(setf (nnimap-process nnimap-object) stream)
|
||||
(if (not stream)
|
||||
(progn
|
||||
(nnheader-report 'nnimap "Unable to contact %s:%s via %s"
|
||||
nnimap-address port nnimap-stream)
|
||||
(gnus-set-process-query-on-exit-flag
|
||||
(nnimap-process nnimap-object) nil)
|
||||
(if (not (setq connection-result (nnimap-wait-for-connection)))
|
||||
(nnheader-report 'nnimap
|
||||
"%s" (buffer-substring
|
||||
(point) (line-end-position)))
|
||||
'no-connect)
|
||||
(gnus-set-process-query-on-exit-flag stream nil)
|
||||
(if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
|
||||
(nnheader-report 'nnimap "%s" greeting)
|
||||
;; Store the greeting (for debugging purposes).
|
||||
(setf (nnimap-greeting nnimap-object)
|
||||
(buffer-substring (line-beginning-position)
|
||||
(line-end-position)))
|
||||
(nnimap-get-capabilities)
|
||||
(when nnimap-server-port
|
||||
(push (format "%s" nnimap-server-port) ports))
|
||||
;; If this is a STARTTLS-capable server, then sever the
|
||||
;; connection and start a STARTTLS connection instead.
|
||||
(cond
|
||||
((and (or (and (eq nnimap-stream 'network)
|
||||
(nnimap-capability "STARTTLS"))
|
||||
(eq nnimap-stream 'starttls))
|
||||
(fboundp 'open-gnutls-stream))
|
||||
(nnimap-command "STARTTLS")
|
||||
(gnutls-negotiate (nnimap-process nnimap-object) nil)
|
||||
;; Get the capabilities again -- they may have changed
|
||||
;; after doing STARTTLS.
|
||||
(nnimap-get-capabilities))
|
||||
((and (eq nnimap-stream 'network)
|
||||
(nnimap-capability "STARTTLS"))
|
||||
(let ((nnimap-stream 'starttls))
|
||||
(let ((tls-process
|
||||
(nnimap-open-connection buffer)))
|
||||
;; If the STARTTLS connection was successful, we
|
||||
;; kill our first non-encrypted connection. If it
|
||||
;; wasn't successful, we just use our unencrypted
|
||||
;; connection.
|
||||
(when (memq (process-status tls-process) '(open run))
|
||||
(delete-process (nnimap-process nnimap-object))
|
||||
(kill-buffer (current-buffer))
|
||||
(return tls-process))))))
|
||||
(unless (equal connection-result "PREAUTH")
|
||||
(setf (nnimap-greeting nnimap-object) greeting)
|
||||
(setf (nnimap-capabilities nnimap-object)
|
||||
(mapcar #'upcase
|
||||
(split-string capabilities)))
|
||||
(unless (gnus-string-match-p "[*.] PREAUTH" greeting)
|
||||
(if (not (setq credentials
|
||||
(if (eq nnimap-authenticator 'anonymous)
|
||||
(list "anonymous"
|
||||
|
|
@ -456,13 +416,6 @@ textual parts.")
|
|||
(nnimap-command "ENABLE QRESYNC"))
|
||||
(nnimap-process nnimap-object))))))))
|
||||
|
||||
(defun nnimap-get-capabilities ()
|
||||
(setf (nnimap-capabilities nnimap-object)
|
||||
(mapcar
|
||||
#'upcase
|
||||
(nnimap-find-parameter
|
||||
"CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
|
||||
|
||||
(defun nnimap-quote-specials (string)
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
|
||||
;; When looking at the retrieval result (in the Summary buffer) you
|
||||
;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You
|
||||
;; will be warped into the group this article came from. Typing `A W'
|
||||
;; will be warped into the group this article came from. Typing `A T'
|
||||
;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and
|
||||
;; also show the thread this article is part of.
|
||||
|
||||
|
|
@ -181,7 +181,8 @@
|
|||
(eval-when-compile
|
||||
(autoload 'nnimap-buffer "nnimap")
|
||||
(autoload 'nnimap-command "nnimap")
|
||||
(autoload 'nnimap-possibly-change-group "nnimap"))
|
||||
(autoload 'nnimap-possibly-change-group "nnimap")
|
||||
(autoload 'gnus-registry-action "gnus-registry"))
|
||||
|
||||
(nnoo-declare nnir)
|
||||
(nnoo-define-basics nnir)
|
||||
|
|
@ -198,14 +199,34 @@
|
|||
(defcustom nnir-method-default-engines
|
||||
'((nnimap . imap)
|
||||
(nntp . gmane))
|
||||
"*Alist of default search engines keyed by server method"
|
||||
"*Alist of default search engines keyed by server method."
|
||||
:type '(alist)
|
||||
:group 'nnir)
|
||||
|
||||
(defcustom nnir-ignored-newsgroups ""
|
||||
"*A regexp to match newsgroups in the active file that should
|
||||
be skipped when searching."
|
||||
:type '(regexp)
|
||||
:group 'nnir)
|
||||
|
||||
(defcustom nnir-summary-line-format nil
|
||||
"*The format specification of the lines in an nnir summary buffer.
|
||||
|
||||
All the items from `gnus-summary-line-format' are available, along
|
||||
with three items unique to nnir summary buffers:
|
||||
|
||||
%Z Search retrieval score value (integer)
|
||||
%G Article original full group name (string)
|
||||
%g Article original short group name (string)
|
||||
|
||||
If nil this will use `gnus-summary-line-format'."
|
||||
:type '(regexp)
|
||||
:group 'nnir)
|
||||
|
||||
(defcustom nnir-imap-default-search-key "Whole message"
|
||||
"*The default IMAP search key for an nnir search. Must be one of
|
||||
the keys in `nnir-imap-search-arguments'. To use raw imap queries
|
||||
by default set this to \"Imap\""
|
||||
by default set this to \"Imap\"."
|
||||
:type '(string)
|
||||
:group 'nnir)
|
||||
|
||||
|
|
@ -423,9 +444,11 @@ needs the variables `nnir-namazu-program',
|
|||
|
||||
Add an entry here when adding a new search engine.")
|
||||
|
||||
(defvar nnir-get-article-nov-override-function nil
|
||||
"If non-nil, a function that will be passed each search result. This
|
||||
should return a message's headers in NOV format.
|
||||
(defvar nnir-retrieve-headers-override-function nil
|
||||
"If non-nil, a function that accepts an article list and group
|
||||
and populates the `nntp-server-buffer' with the retrieved
|
||||
headers. Must return either 'nov or 'headers indicating the
|
||||
retrieved header format.
|
||||
|
||||
If this variable is nil, or if the provided function returns nil for a search
|
||||
result, `gnus-retrieve-headers' will be called instead.")
|
||||
|
|
@ -455,6 +478,68 @@ result, `gnus-retrieve-headers' will be called instead.")
|
|||
|
||||
;;; Code:
|
||||
|
||||
;;; Helper macros
|
||||
|
||||
;; Data type article list.
|
||||
|
||||
(defmacro nnir-artlist-length (artlist)
|
||||
"Returns number of articles in artlist."
|
||||
`(length ,artlist))
|
||||
|
||||
(defmacro nnir-artlist-article (artlist n)
|
||||
"Returns from ARTLIST the Nth artitem (counting starting at 1)."
|
||||
`(when (> ,n 0)
|
||||
(elt ,artlist (1- ,n))))
|
||||
|
||||
(defmacro nnir-artitem-group (artitem)
|
||||
"Returns the group from the ARTITEM."
|
||||
`(elt ,artitem 0))
|
||||
|
||||
(defmacro nnir-artitem-number (artitem)
|
||||
"Returns the number from the ARTITEM."
|
||||
`(elt ,artitem 1))
|
||||
|
||||
(defmacro nnir-artitem-rsv (artitem)
|
||||
"Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
|
||||
`(elt ,artitem 2))
|
||||
|
||||
(defmacro nnir-article-group (article)
|
||||
"Returns the group for ARTICLE"
|
||||
`(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article)))
|
||||
|
||||
(defmacro nnir-article-number (article)
|
||||
"Returns the number for ARTICLE"
|
||||
`(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article)))
|
||||
|
||||
(defmacro nnir-article-rsv (article)
|
||||
"Returns the rsv for ARTICLE"
|
||||
`(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article)))
|
||||
|
||||
(defsubst nnir-article-ids (article)
|
||||
"Returns the pair `(nnir id . real id)' of ARTICLE"
|
||||
(cons article (nnir-article-number article)))
|
||||
|
||||
(defmacro nnir-categorize (sequence keyfunc &optional valuefunc)
|
||||
"Sorts a sequence into categories and returns a list of the form
|
||||
`((key1 (element11 element12)) (key2 (element21 element22))'.
|
||||
The category key for a member of the sequence is obtained
|
||||
as `(keyfunc member)' and the corresponding element is just
|
||||
`member'. If `valuefunc' is non-nil, the element of the list
|
||||
is `(valuefunc member)'."
|
||||
`(unless (null ,sequence)
|
||||
(let (value)
|
||||
(mapcar
|
||||
(lambda (member)
|
||||
(let ((y (,keyfunc member))
|
||||
(x ,(if valuefunc
|
||||
`(,valuefunc member)
|
||||
'member)))
|
||||
(if (assoc y value)
|
||||
(push x (cadr (assoc y value)))
|
||||
(push (list y (list x)) value))))
|
||||
,sequence)
|
||||
value)))
|
||||
|
||||
;; Gnus glue.
|
||||
|
||||
(defun gnus-group-make-nnir-group (nnir-extra-parms)
|
||||
|
|
@ -479,6 +564,7 @@ result, `gnus-retrieve-headers' will be called instead.")
|
|||
|
||||
(deffoo nnir-open-server (server &optional definitions)
|
||||
;; Just set the server variables appropriately.
|
||||
(add-hook 'gnus-summary-mode-hook 'nnir-mode)
|
||||
(nnoo-change-server 'nnir server definitions))
|
||||
|
||||
(deffoo nnir-request-group (group &optional server fast info)
|
||||
|
|
@ -506,72 +592,71 @@ result, `gnus-retrieve-headers' will be called instead.")
|
|||
group)))) ; group name
|
||||
|
||||
(deffoo nnir-retrieve-headers (articles &optional group server fetch-old)
|
||||
(save-excursion
|
||||
(let ((artlist (copy-sequence articles))
|
||||
art artitem artgroup artno artrsv artfullgroup
|
||||
novitem novdata foo server)
|
||||
(while (not (null artlist))
|
||||
(setq art (car artlist))
|
||||
(or (numberp art)
|
||||
(nnheader-report
|
||||
'nnir
|
||||
"nnir-retrieve-headers doesn't grok message ids: %s"
|
||||
art))
|
||||
(setq artitem (nnir-artlist-article nnir-artlist art))
|
||||
(setq artrsv (nnir-artitem-rsv artitem))
|
||||
(setq artfullgroup (nnir-artitem-group artitem))
|
||||
(setq artno (nnir-artitem-number artitem))
|
||||
(setq artgroup (gnus-group-real-name artfullgroup))
|
||||
(setq server (gnus-group-server artfullgroup))
|
||||
;; retrieve NOV or HEAD data for this article, transform into
|
||||
;; NOV data and prepend to `novdata'
|
||||
(set-buffer nntp-server-buffer)
|
||||
(with-current-buffer nntp-server-buffer
|
||||
(let ((gnus-inhibit-demon t)
|
||||
(articles-by-group (nnir-categorize
|
||||
articles nnir-article-group nnir-article-ids))
|
||||
headers)
|
||||
(while (not (null articles-by-group))
|
||||
(let* ((group-articles (pop articles-by-group))
|
||||
(artgroup (car group-articles))
|
||||
(articleids (cadr group-articles))
|
||||
(artlist (sort (mapcar 'cdr articleids) '<))
|
||||
(server (gnus-group-server artgroup))
|
||||
(gnus-override-method (gnus-server-to-method server))
|
||||
parsefunc)
|
||||
;; (or (numberp art)
|
||||
;; (nnheader-report
|
||||
;; 'nnir
|
||||
;; "nnir-retrieve-headers doesn't grok message ids: %s"
|
||||
;; art))
|
||||
(nnir-possibly-change-server server)
|
||||
(let ((gnus-override-method
|
||||
(gnus-server-to-method server)))
|
||||
;; if nnir-get-article-nov-override-function is set, use it
|
||||
(if nnir-get-article-nov-override-function
|
||||
(setq novitem (funcall nnir-get-article-nov-override-function
|
||||
artitem))
|
||||
;; else, set novitem through nnheader-parse-nov/nnheader-parse-head
|
||||
(case (setq foo (gnus-retrieve-headers (list artno)
|
||||
artfullgroup nil))
|
||||
;; is this needed?
|
||||
(erase-buffer)
|
||||
(case (setq gnus-headers-retrieved-by
|
||||
(or
|
||||
(and
|
||||
nnir-retrieve-headers-override-function
|
||||
(funcall nnir-retrieve-headers-override-function
|
||||
artlist artgroup))
|
||||
(gnus-retrieve-headers artlist artgroup nil)))
|
||||
(nov
|
||||
(goto-char (point-min))
|
||||
(setq novitem (nnheader-parse-nov)))
|
||||
(setq parsefunc 'nnheader-parse-nov))
|
||||
(headers
|
||||
(setq parsefunc 'nnheader-parse-head))
|
||||
(t (error "Unknown header type %s while requesting articles \
|
||||
of group %s" gnus-headers-retrieved-by artgroup)))
|
||||
(goto-char (point-min))
|
||||
(setq novitem (nnheader-parse-head)))
|
||||
(t (error "Unknown header type %s while requesting article %s of group %s"
|
||||
foo artno artfullgroup)))))
|
||||
;; replace article number in original group with article number
|
||||
;; in nnir group
|
||||
(when novitem
|
||||
(while (not (eobp))
|
||||
(let* ((novitem (funcall parsefunc))
|
||||
(artno (mail-header-number novitem))
|
||||
(art (car (rassoc artno articleids))))
|
||||
(when art
|
||||
(mail-header-set-number novitem art)
|
||||
(mail-header-set-subject
|
||||
novitem
|
||||
(format "[%d: %s/%d] %s"
|
||||
artrsv artgroup artno
|
||||
(mail-header-subject novitem)))
|
||||
(push novitem novdata)
|
||||
(setq artlist (cdr artlist))))
|
||||
(setq novdata (nreverse novdata))
|
||||
(set-buffer nntp-server-buffer) (erase-buffer)
|
||||
(mapc 'nnheader-insert-nov novdata)
|
||||
;; (mail-header-set-subject
|
||||
;; novitem
|
||||
;; (format "[%d: %s/%d] %s"
|
||||
;; (nnir-article-rsv art) artgroup artno
|
||||
;; (mail-header-subject novitem)))
|
||||
(push novitem headers))
|
||||
(forward-line 1)))))
|
||||
(setq headers
|
||||
(sort headers
|
||||
(lambda (x y)
|
||||
(< (mail-header-number x) (mail-header-number y)))))
|
||||
(erase-buffer)
|
||||
(mapc 'nnheader-insert-nov headers)
|
||||
'nov)))
|
||||
|
||||
(deffoo nnir-request-article (article
|
||||
&optional group server to-buffer)
|
||||
(deffoo nnir-request-article (article &optional group server to-buffer)
|
||||
(if (stringp article)
|
||||
(nnheader-report
|
||||
'nnir
|
||||
"nnir-retrieve-headers doesn't grok message ids: %s"
|
||||
article)
|
||||
(save-excursion
|
||||
(let* ((artitem (nnir-artlist-article nnir-artlist
|
||||
article))
|
||||
(artfullgroup (nnir-artitem-group artitem))
|
||||
(artno (nnir-artitem-number artitem))
|
||||
(let ((artfullgroup (nnir-article-group article))
|
||||
(artno (nnir-article-number article))
|
||||
;; Bug?
|
||||
;; Why must we bind nntp-server-buffer here? It won't
|
||||
;; work if `buf' is used, say. (Of course, the set-buffer
|
||||
|
|
@ -586,10 +671,8 @@ result, `gnus-retrieve-headers' will be called instead.")
|
|||
|
||||
(deffoo nnir-request-move-article (article group server accept-form
|
||||
&optional last internal-move-group)
|
||||
(let* ((artitem (nnir-artlist-article nnir-artlist
|
||||
article))
|
||||
(artfullgroup (nnir-artitem-group artitem))
|
||||
(artno (nnir-artitem-number artitem))
|
||||
(let* ((artfullgroup (nnir-article-group article))
|
||||
(artno (nnir-article-number article))
|
||||
(to-newsgroup (nth 1 accept-form))
|
||||
(to-method (gnus-find-method-for-group to-newsgroup))
|
||||
(from-method (gnus-find-method-for-group artfullgroup))
|
||||
|
|
@ -597,9 +680,9 @@ result, `gnus-retrieve-headers' will be called instead.")
|
|||
(artsubject (mail-header-subject
|
||||
(gnus-data-header
|
||||
(assoc article (gnus-data-list nil))))))
|
||||
(setq gnus-newsgroup-original-name artfullgroup)
|
||||
(string-match "^\\[[0-9]+:.+/[0-9]+\\] " artsubject)
|
||||
(setq gnus-article-original-subject (substring artsubject (match-end 0)))
|
||||
(unless (gnus-check-backend-function
|
||||
'request-move-article artfullgroup)
|
||||
(error "The group %s does not support article moving" artfullgroup))
|
||||
(gnus-request-move-article
|
||||
artno
|
||||
artfullgroup
|
||||
|
|
@ -614,8 +697,8 @@ result, `gnus-retrieve-headers' will be called instead.")
|
|||
(let* ((cur (if (> (gnus-summary-article-number) 0)
|
||||
(gnus-summary-article-number)
|
||||
(error "This is not a real article.")))
|
||||
(gnus-newsgroup-name (nnir-artlist-artitem-group nnir-artlist cur))
|
||||
(backend-number (nnir-artlist-artitem-number nnir-artlist cur)))
|
||||
(gnus-newsgroup-name (nnir-article-group cur))
|
||||
(backend-number (nnir-article-number cur)))
|
||||
(gnus-summary-read-group-1 gnus-newsgroup-name t t gnus-summary-buffer
|
||||
nil (list backend-number))))
|
||||
|
||||
|
|
@ -654,7 +737,7 @@ ready to be added to the list of search results."
|
|||
(gnus-replace-in-string dirnam "^[./\\]" "" t)
|
||||
"[/\\]" "." t)))
|
||||
|
||||
(vector (nnir-group-full-name group server)
|
||||
(vector (gnus-group-full-name group server)
|
||||
(if (string= (gnus-group-server server) "nnmaildir")
|
||||
(nnmaildir-base-name-to-article-number
|
||||
(substring article 0 (string-match ":" article))
|
||||
|
|
@ -696,7 +779,7 @@ details on the language and supported extensions"
|
|||
(nnir-imap-make-query
|
||||
criteria qstring)))))
|
||||
(mapc
|
||||
(lambda (artnum) (push (vector group artnum 1) artlist)
|
||||
(lambda (artnum) (push (vector group artnum 100) artlist)
|
||||
(setq arts (1+ arts)))
|
||||
(and (car result)
|
||||
(delete 0 (mapcar #'string-to-number
|
||||
|
|
@ -1056,7 +1139,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
|
|||
;; Windows "\\" -> "."
|
||||
(setq group (gnus-replace-in-string group "\\\\" "."))
|
||||
|
||||
(push (vector (nnir-group-full-name group server)
|
||||
(push (vector (gnus-group-full-name group server)
|
||||
(string-to-number artno)
|
||||
(string-to-number score))
|
||||
artlist))))
|
||||
|
|
@ -1125,7 +1208,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
|
|||
score (match-string 3))
|
||||
(when (string-match prefix dirnam)
|
||||
(setq dirnam (replace-match "" t t dirnam)))
|
||||
(push (vector (nnir-group-full-name
|
||||
(push (vector (gnus-group-full-name
|
||||
(gnus-replace-in-string dirnam "/" ".") server)
|
||||
(string-to-number artno)
|
||||
(string-to-number score))
|
||||
|
|
@ -1218,6 +1301,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
|
|||
(directory (cadr (assoc sym (cddr method))))
|
||||
(regexp (cdr (assoc 'query query)))
|
||||
(grep-options (cdr (assoc 'grep-options query)))
|
||||
(grouplist (or grouplist (nnir-get-active server)))
|
||||
artlist)
|
||||
(unless directory
|
||||
(error "No directory found in method specification of server %s"
|
||||
|
|
@ -1283,7 +1367,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
|
|||
(nreverse res))
|
||||
".")))
|
||||
(push
|
||||
(vector (nnir-group-full-name group server) art 0)
|
||||
(vector (gnus-group-full-name group server) art 0)
|
||||
artlist))
|
||||
(forward-line 1)))
|
||||
(message "Searching %s using find-grep...done"
|
||||
|
|
@ -1297,15 +1381,14 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
|
|||
;; gmane interface
|
||||
(defun nnir-run-gmane (query srv &optional groups)
|
||||
"Run a search against a gmane back-end server."
|
||||
(if (gnus-string-match-p "gmane" srv)
|
||||
(if (gnus-string-match-p "gmane.org$" srv)
|
||||
(let* ((case-fold-search t)
|
||||
(qstring (cdr (assq 'query query)))
|
||||
(server (cadr (gnus-server-to-method srv)))
|
||||
(groupspec (if groups
|
||||
(mapconcat
|
||||
(function (lambda (x)
|
||||
(format "group:%s"
|
||||
(gnus-group-short-name x))))
|
||||
(lambda (x)
|
||||
(format "group:%s" (gnus-group-short-name x)))
|
||||
groups " ") ""))
|
||||
(authorspec
|
||||
(if (assq 'author query)
|
||||
|
|
@ -1341,12 +1424,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
|
|||
(string-to-number (match-string 2 xref)) xscore)
|
||||
artlist)))))
|
||||
(forward-line 1)))
|
||||
;; Sort by score
|
||||
(apply 'vector
|
||||
(sort artlist
|
||||
(function (lambda (x y)
|
||||
(> (nnir-artitem-rsv x)
|
||||
(nnir-artitem-rsv y)))))))
|
||||
(apply 'vector (nreverse (mm-delete-duplicates artlist))))
|
||||
(message "Can't search non-gmane nntp groups")
|
||||
nil))
|
||||
|
||||
|
|
@ -1380,14 +1458,16 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
|
|||
(groups (if (string= "all-ephemeral" nserver)
|
||||
(with-current-buffer gnus-server-buffer
|
||||
(list (list (gnus-server-server-name))))
|
||||
(nnir-sort-groups-by-server
|
||||
(nnir-categorize
|
||||
(or gnus-group-marked
|
||||
(if (gnus-group-group-name)
|
||||
(list (gnus-group-group-name))
|
||||
(cdr (assoc (gnus-group-topic-name)
|
||||
gnus-topic-alist))))))))
|
||||
gnus-topic-alist))))
|
||||
gnus-group-server))))
|
||||
(apply 'vconcat
|
||||
(mapcar (lambda (x)
|
||||
(mapcar
|
||||
(lambda (x)
|
||||
(let* ((server (car x))
|
||||
(nnir-search-engine
|
||||
(or (nnir-read-server-parm 'nnir-search-engine
|
||||
|
|
@ -1396,15 +1476,14 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
|
|||
(gnus-server-to-method server))
|
||||
nnir-method-default-engines))))
|
||||
search-func)
|
||||
(setq search-func (cadr
|
||||
(assoc nnir-search-engine
|
||||
(setq search-func (cadr (assoc nnir-search-engine
|
||||
nnir-engines)))
|
||||
(if search-func
|
||||
(funcall search-func
|
||||
(if nnir-extra-parms
|
||||
(nnir-read-parms q nnir-search-engine)
|
||||
q)
|
||||
server (cdr x))
|
||||
server (cadr x))
|
||||
nil)))
|
||||
groups))))
|
||||
|
||||
|
|
@ -1416,50 +1495,11 @@ server is of form 'backend:name'."
|
|||
(nth 1 (assq key (cddr method))))
|
||||
(t nil))))
|
||||
|
||||
(defun nnir-group-full-name (shortname server)
|
||||
"For the given group name, return a full Gnus group name.
|
||||
The Gnus backend/server information is added."
|
||||
(gnus-group-prefixed-name shortname (gnus-server-to-method server)))
|
||||
|
||||
(defun nnir-possibly-change-server (server)
|
||||
(unless (and server (nnir-server-opened server))
|
||||
(nnir-open-server server)))
|
||||
|
||||
|
||||
;; Data type article list.
|
||||
|
||||
(defun nnir-artlist-length (artlist)
|
||||
"Returns number of articles in artlist."
|
||||
(length artlist))
|
||||
|
||||
(defun nnir-artlist-article (artlist n)
|
||||
"Returns from ARTLIST the Nth artitem (counting starting at 1)."
|
||||
(elt artlist (1- n)))
|
||||
|
||||
(defun nnir-artitem-group (artitem)
|
||||
"Returns the group from the ARTITEM."
|
||||
(elt artitem 0))
|
||||
|
||||
(defun nnir-artlist-artitem-group (artlist n)
|
||||
"Returns from ARTLIST the group of the Nth artitem (counting from 1)."
|
||||
(nnir-artitem-group (nnir-artlist-article artlist n)))
|
||||
|
||||
(defun nnir-artitem-number (artitem)
|
||||
"Returns the number from the ARTITEM."
|
||||
(elt artitem 1))
|
||||
|
||||
(defun nnir-artlist-artitem-number (artlist n)
|
||||
"Returns from ARTLIST the number of the Nth artitem (counting from 1)."
|
||||
(nnir-artitem-number (nnir-artlist-article artlist n)))
|
||||
|
||||
(defun nnir-artitem-rsv (artitem)
|
||||
"Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
|
||||
(elt artitem 2))
|
||||
|
||||
(defun nnir-artlist-artitem-rsv (artlist n)
|
||||
"Returns from ARTLIST the Retrieval Status Value of the Nth
|
||||
artitem (counting from 1)."
|
||||
(nnir-artitem-rsv (nnir-artlist-article artlist n)))
|
||||
|
||||
;; unused?
|
||||
(defun nnir-artlist-groups (artlist)
|
||||
|
|
@ -1473,18 +1513,6 @@ artitem (counting from 1)."
|
|||
with-dups)
|
||||
res))
|
||||
|
||||
(defun nnir-sort-groups-by-server (groups)
|
||||
"sorts a list of groups into an alist keyed by server"
|
||||
(if (car groups)
|
||||
(let (value)
|
||||
(dolist (var groups value)
|
||||
(let ((server (gnus-group-server var)))
|
||||
(if (assoc server value)
|
||||
(nconc (cdr (assoc server value)) (list var))
|
||||
(push (cons server (list var)) value))))
|
||||
value)
|
||||
nil))
|
||||
|
||||
(defun nnir-get-active (srv)
|
||||
(let ((method (gnus-server-to-method srv))
|
||||
groups)
|
||||
|
|
@ -1493,19 +1521,59 @@ artitem (counting from 1)."
|
|||
(let ((cur (current-buffer))
|
||||
name)
|
||||
(goto-char (point-min))
|
||||
(unless (string= gnus-ignored-newsgroups "")
|
||||
(delete-matching-lines gnus-ignored-newsgroups))
|
||||
(unless (string= nnir-ignored-newsgroups "")
|
||||
(delete-matching-lines nnir-ignored-newsgroups))
|
||||
(if (eq (car method) 'nntp)
|
||||
(while (not (eobp))
|
||||
(ignore-errors
|
||||
(push (mm-string-as-unibyte
|
||||
(let ((p (point)))
|
||||
(gnus-group-full-name
|
||||
(buffer-substring
|
||||
(point)
|
||||
(progn
|
||||
(skip-chars-forward "^ \t")
|
||||
(point))) method))
|
||||
groups))
|
||||
(forward-line))
|
||||
(while (not (eobp))
|
||||
(ignore-errors
|
||||
(push (mm-string-as-unibyte
|
||||
(if (eq (char-after) ?\")
|
||||
(gnus-group-full-name (read cur) method)
|
||||
(let ((p (point)) (name ""))
|
||||
(skip-chars-forward "^ \t\\\\")
|
||||
(setq name (buffer-substring (+ p 1) (- (point) 1)))
|
||||
(gnus-group-full-name name method)))
|
||||
(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)))))
|
||||
(gnus-group-full-name name method))))
|
||||
groups))
|
||||
(forward-line))))
|
||||
(forward-line)))))
|
||||
groups))
|
||||
|
||||
(defun nnir-registry-action (action data-header from &optional to method)
|
||||
"Call `gnus-registry-action' with the original article group."
|
||||
(gnus-registry-action
|
||||
action
|
||||
data-header
|
||||
(nnir-article-group (mail-header-number data-header))
|
||||
to
|
||||
method))
|
||||
|
||||
(defun nnir-mode ()
|
||||
(when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir)
|
||||
(setq gnus-summary-line-format
|
||||
(or nnir-summary-line-format gnus-summary-line-format))
|
||||
(remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t)
|
||||
(remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t)
|
||||
(add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t)
|
||||
(add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t)))
|
||||
|
||||
|
||||
|
||||
;; The end.
|
||||
(provide 'nnir)
|
||||
|
||||
|
|
|
|||
|
|
@ -1559,7 +1559,7 @@ by nnmaildir-request-article.")
|
|||
(t (signal (car err) (cdr err))))))
|
||||
todo-marks))
|
||||
set-action (lambda (article)
|
||||
(funcall add-action)
|
||||
(funcall add-action article)
|
||||
(mapcar (lambda (mark)
|
||||
(unless (memq mark todo-marks)
|
||||
(funcall del-mark mark)))
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@
|
|||
(require 'nnoo)
|
||||
(require 'gnus-util)
|
||||
(require 'gnus)
|
||||
(require 'proto-stream)
|
||||
(require 'gnus-group) ;; gnus-group-name-charset
|
||||
|
||||
(nnoo-declare nntp)
|
||||
|
|
@ -305,13 +306,6 @@ update their active files often, this can help.")
|
|||
(defvar nntp-async-timer nil)
|
||||
(defvar nntp-async-process-list nil)
|
||||
|
||||
(defvar nntp-ssl-program
|
||||
"openssl s_client -quiet -ssl3 -connect %s:%p"
|
||||
"A string containing commands for SSL connections.
|
||||
Within a string, %s is replaced with the server address and %p with
|
||||
port number on server. The program should accept IMAP commands on
|
||||
stdin and return responses to stdout.")
|
||||
|
||||
(defvar nntp-authinfo-rejected nil
|
||||
"A custom error condition used to report 'Authentication Rejected' errors.
|
||||
Condition handlers that match just this condition ensure that the nntp
|
||||
|
|
@ -1268,11 +1262,28 @@ password contained in '~/.nntp-authinfo'."
|
|||
`(lambda ()
|
||||
(nntp-kill-buffer ,pbuffer)))))
|
||||
(process
|
||||
(condition-case ()
|
||||
(condition-case err
|
||||
(let ((coding-system-for-read nntp-coding-system-for-read)
|
||||
(coding-system-for-write nntp-coding-system-for-write))
|
||||
(funcall nntp-open-connection-function pbuffer))
|
||||
(error nil)
|
||||
(coding-system-for-write nntp-coding-system-for-write)
|
||||
(map '((nntp-open-network-stream network)
|
||||
(nntp-open-ssl-stream tls)
|
||||
(nntp-open-tls-stream tls))))
|
||||
(if (assoc nntp-open-connection-function map)
|
||||
(car (open-protocol-stream
|
||||
"nntpd" pbuffer nntp-address nntp-port-number
|
||||
:type (cadr
|
||||
(assoc nntp-open-connection-function map))
|
||||
:end-of-command "^\\([2345]\\|[.]\\).*\n"
|
||||
:capability-command "CAPABILITIES\r\n"
|
||||
:success "^3"
|
||||
:starttls-function
|
||||
(lambda (capabilities)
|
||||
(if (not (string-match "STARTTLS" capabilities))
|
||||
nil
|
||||
"STARTTLS\r\n"))))
|
||||
(funcall nntp-open-connection-function pbuffer)))
|
||||
(error
|
||||
(nnheader-report 'nntp "%s" err))
|
||||
(quit
|
||||
(message "Quit opening connection to %s" nntp-address)
|
||||
(nntp-kill-buffer pbuffer)
|
||||
|
|
@ -1300,40 +1311,6 @@ password contained in '~/.nntp-authinfo'."
|
|||
(nntp-kill-buffer (process-buffer process))
|
||||
nil))))
|
||||
|
||||
(defun nntp-open-network-stream (buffer)
|
||||
(open-network-stream "nntpd" buffer nntp-address nntp-port-number))
|
||||
|
||||
(autoload 'format-spec "format-spec")
|
||||
(autoload 'format-spec-make "format-spec")
|
||||
(autoload 'open-tls-stream "tls")
|
||||
|
||||
(defun nntp-open-ssl-stream (buffer)
|
||||
(let* ((process-connection-type nil)
|
||||
(proc (start-process "nntpd" buffer
|
||||
shell-file-name
|
||||
shell-command-switch
|
||||
(format-spec nntp-ssl-program
|
||||
(format-spec-make
|
||||
?s nntp-address
|
||||
?p nntp-port-number)))))
|
||||
(gnus-set-process-query-on-exit-flag proc nil)
|
||||
(with-current-buffer buffer
|
||||
(let ((nntp-connection-alist (list proc buffer nil)))
|
||||
(nntp-wait-for-string "^\r*20[01]"))
|
||||
(beginning-of-line)
|
||||
(delete-region (point-min) (point))
|
||||
proc)))
|
||||
|
||||
(defun nntp-open-tls-stream (buffer)
|
||||
(let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number)))
|
||||
(gnus-set-process-query-on-exit-flag proc nil)
|
||||
(with-current-buffer buffer
|
||||
(let ((nntp-connection-alist (list proc buffer nil)))
|
||||
(nntp-wait-for-string "^\r*20[01]"))
|
||||
(beginning-of-line)
|
||||
(delete-region (point-min) (point))
|
||||
proc)))
|
||||
|
||||
(defun nntp-read-server-type ()
|
||||
"Find out what the name of the server we have connected to is."
|
||||
;; Wait for the status string to arrive.
|
||||
|
|
|
|||
262
lisp/gnus/proto-stream.el
Normal file
262
lisp/gnus/proto-stream.el
Normal file
|
|
@ -0,0 +1,262 @@
|
|||
;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
|
||||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
;; Keywords: network
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 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 library is meant to provide the glue between modules that want
|
||||
;; to establish a network connection to a server for protocols such as
|
||||
;; IMAP, NNTP, SMTP and POP3.
|
||||
|
||||
;; The main problem is that there's more than a couple of interfaces
|
||||
;; towards doing this. You have normal, plain connections, which are
|
||||
;; no trouble at all, but you also have TLS/SSL connections, and you
|
||||
;; have STARTTLS. Negotiating this for each protocol can be rather
|
||||
;; tedious, so this library provides a single entry point, and hides
|
||||
;; much of the ugliness.
|
||||
|
||||
;; Usage example:
|
||||
|
||||
;; (open-protocol-stream
|
||||
;; "*nnimap*" buffer address port
|
||||
;; :type 'network
|
||||
;; :capability-command "1 CAPABILITY\r\n"
|
||||
;; :success " OK "
|
||||
;; :starttls-function
|
||||
;; (lambda (capabilities)
|
||||
;; (if (not (string-match "STARTTLS" capabilities))
|
||||
;; nil
|
||||
;; "1 STARTTLS\r\n")))
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile
|
||||
(require 'cl))
|
||||
(require 'tls)
|
||||
(require 'starttls)
|
||||
(require 'format-spec)
|
||||
|
||||
(defcustom proto-stream-always-use-starttls (fboundp 'open-gnutls-stream)
|
||||
"If non-nil, always try to upgrade network connections with STARTTLS."
|
||||
:version "24.1"
|
||||
:type 'boolean
|
||||
:group 'comm)
|
||||
|
||||
(declare-function gnutls-negotiate "gnutls"
|
||||
(proc type &optional priority-string trustfiles keyfiles))
|
||||
|
||||
;;;###autoload
|
||||
(defun open-protocol-stream (name buffer host service &rest parameters)
|
||||
"Open a network stream to HOST, upgrading to STARTTLS if possible.
|
||||
The first four parameters have the same meaning as in
|
||||
`open-network-stream'. The function returns a list where the
|
||||
first element is the stream, the second element is the greeting
|
||||
the server replied with after connecting, and the third element
|
||||
is a string representing the capabilities of the server (if any).
|
||||
|
||||
The PARAMETERS is a keyword list that can have the following
|
||||
values:
|
||||
|
||||
:type -- either `network', `tls', `shell' or `starttls'. If
|
||||
omitted, the default is `network'. `network' will be
|
||||
opportunistically upgraded to STARTTLS if both the server and
|
||||
Emacs supports it.
|
||||
|
||||
:end-of-command -- a regexp saying what the end of a command is.
|
||||
This defaults to \"\\n\".
|
||||
|
||||
:success -- a regexp saying whether the STARTTLS command was
|
||||
successful or not. For instance, for NNTP this is \"^3\".
|
||||
|
||||
:capability-command -- a string representing the command used to
|
||||
query server for capabilities. For instance, for IMAP this is
|
||||
\"1 CAPABILITY\\r\\n\".
|
||||
|
||||
:starttls-function -- a function that takes one parameter, which
|
||||
is the response to the capaibility command. It should return nil
|
||||
if it turns out that the server doesn't support STARTTLS, or the
|
||||
command to switch on STARTTLS otherwise."
|
||||
(let ((type (or (cadr (memq :type parameters)) 'network)))
|
||||
(cond
|
||||
((eq type 'starttls)
|
||||
(setq type 'network))
|
||||
((eq type 'ssl)
|
||||
(setq type 'tls)))
|
||||
(destructuring-bind (stream greeting capabilities)
|
||||
(funcall (intern (format "proto-stream-open-%s" type) obarray)
|
||||
name buffer host service parameters)
|
||||
(list (and stream
|
||||
(memq (process-status stream)
|
||||
'(open run))
|
||||
stream)
|
||||
greeting capabilities))))
|
||||
|
||||
(defun proto-stream-open-network (name buffer host service parameters)
|
||||
(let* ((start (with-current-buffer buffer (point)))
|
||||
(stream (open-network-stream name buffer host service))
|
||||
(capability-command (cadr (memq :capability-command parameters)))
|
||||
(eoc (proto-stream-eoc parameters))
|
||||
(type (cadr (memq :type parameters)))
|
||||
(greeting (proto-stream-get-response stream start eoc))
|
||||
success)
|
||||
(if (not capability-command)
|
||||
(list stream greeting nil)
|
||||
(let* ((capabilities
|
||||
(proto-stream-command stream capability-command eoc))
|
||||
(starttls-command
|
||||
(funcall (cadr (memq :starttls-function parameters))
|
||||
capabilities)))
|
||||
(cond
|
||||
;; If this server doesn't support STARTTLS, but we have
|
||||
;; requested it explicitly, then close the connection and
|
||||
;; return nil.
|
||||
((or (not starttls-command)
|
||||
(and (not (eq type 'starttls))
|
||||
(not proto-stream-always-use-starttls)))
|
||||
(if (eq type 'starttls)
|
||||
(progn
|
||||
(delete-process stream)
|
||||
nil)
|
||||
;; Otherwise, just return this plain network connection.
|
||||
(list stream greeting capabilities)))
|
||||
;; We have some kind of STARTTLS support, so we try to
|
||||
;; upgrade the connection opportunistically.
|
||||
((or (fboundp 'open-gnutls-stream)
|
||||
(executable-find "gnutls-cli"))
|
||||
(unless (fboundp 'open-gnutls-stream)
|
||||
(delete-process stream)
|
||||
(setq start (with-current-buffer buffer (point-max)))
|
||||
(let* ((starttls-use-gnutls t)
|
||||
(starttls-extra-arguments
|
||||
(if (not (eq type 'starttls))
|
||||
;; When doing opportunistic TLS upgrades we
|
||||
;; don't really care about the identity of the
|
||||
;; peer.
|
||||
(cons "--insecure" starttls-extra-arguments)
|
||||
starttls-extra-arguments)))
|
||||
(setq stream (starttls-open-stream name buffer host service)))
|
||||
(proto-stream-get-response stream start eoc))
|
||||
(if (not
|
||||
(string-match
|
||||
(cadr (memq :success parameters))
|
||||
(proto-stream-command stream starttls-command eoc)))
|
||||
;; We got an error back from the STARTTLS command.
|
||||
(progn
|
||||
(if (eq type 'starttls)
|
||||
(progn
|
||||
(delete-process stream)
|
||||
nil)
|
||||
(list stream greeting capabilities)))
|
||||
;; The server said it was OK to start doing STARTTLS negotiations.
|
||||
(if (fboundp 'open-gnutls-stream)
|
||||
(gnutls-negotiate stream nil)
|
||||
(unless (starttls-negotiate stream)
|
||||
(delete-process stream)
|
||||
(setq stream nil)))
|
||||
(when (or (null stream)
|
||||
(not (memq (process-status stream)
|
||||
'(open run))))
|
||||
;; It didn't successfully negotiate STARTTLS, so we reopen
|
||||
;; the connection.
|
||||
(setq stream (open-network-stream name buffer host service))
|
||||
(proto-stream-get-response stream start eoc))
|
||||
;; Re-get the capabilities, since they may have changed
|
||||
;; after switching to TLS.
|
||||
(list stream greeting
|
||||
(proto-stream-command stream capability-command eoc))))
|
||||
;; We don't have STARTTLS support available, but the caller
|
||||
;; requested a STARTTLS connection, so we give up.
|
||||
((eq (cadr (memq :type parameters)) 'starttls)
|
||||
(delete-process stream)
|
||||
nil)
|
||||
;; Fall back on using a plain network stream.
|
||||
(t
|
||||
(list stream greeting capabilities)))))))
|
||||
|
||||
(defun proto-stream-command (stream command eoc)
|
||||
(let ((start (with-current-buffer (process-buffer stream) (point-max))))
|
||||
(process-send-string stream command)
|
||||
(proto-stream-get-response stream start eoc)))
|
||||
|
||||
(defun proto-stream-get-response (stream start end-of-command)
|
||||
(with-current-buffer (process-buffer stream)
|
||||
(save-excursion
|
||||
(goto-char start)
|
||||
(while (and (memq (process-status stream)
|
||||
'(open run))
|
||||
(not (re-search-forward end-of-command nil t)))
|
||||
(accept-process-output stream 0 50)
|
||||
(goto-char start))
|
||||
(if (= start (point))
|
||||
;; The process died; return nil.
|
||||
nil
|
||||
;; Return the data we got back.
|
||||
(buffer-substring start (point))))))
|
||||
|
||||
(defun proto-stream-open-tls (name buffer host service parameters)
|
||||
(with-current-buffer buffer
|
||||
(let ((start (point-max))
|
||||
(stream
|
||||
(funcall (if (fboundp 'open-gnutls-stream)
|
||||
'open-gnutls-stream
|
||||
'open-tls-stream)
|
||||
name buffer host service)))
|
||||
;; If we're using tls.el, we have to delete the output from
|
||||
;; openssl/gnutls-cli.
|
||||
(unless (fboundp 'open-gnutls-stream)
|
||||
(proto-stream-get-response
|
||||
stream start (proto-stream-eoc parameters))
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward (proto-stream-eoc parameters) nil t)
|
||||
(goto-char (match-beginning 0))
|
||||
(delete-region (point-min) (line-beginning-position))))
|
||||
(proto-stream-capability-open start stream parameters))))
|
||||
|
||||
(defun proto-stream-open-shell (name buffer host service parameters)
|
||||
(proto-stream-capability-open
|
||||
(with-current-buffer buffer (point))
|
||||
(let ((process-connection-type nil))
|
||||
(start-process name buffer shell-file-name
|
||||
shell-command-switch
|
||||
(format-spec
|
||||
(cadr (memq :shell-command parameters))
|
||||
(format-spec-make
|
||||
?s host
|
||||
?p service))))
|
||||
parameters))
|
||||
|
||||
(defun proto-stream-capability-open (start stream parameters)
|
||||
(let ((capability-command (cadr (memq :capability-command parameters)))
|
||||
(greeting (proto-stream-get-response
|
||||
stream start (proto-stream-eoc parameters))))
|
||||
(list stream greeting
|
||||
(and capability-command
|
||||
(proto-stream-command
|
||||
stream capability-command (proto-stream-eoc parameters))))))
|
||||
|
||||
(defun proto-stream-eoc (parameters)
|
||||
(or (cadr (memq :end-of-command parameters))
|
||||
"\r\n"))
|
||||
|
||||
(provide 'proto-stream)
|
||||
|
||||
;;; proto-stream.el ends here
|
||||
279
lisp/gnus/rtree.el
Normal file
279
lisp/gnus/rtree.el
Normal file
|
|
@ -0,0 +1,279 @@
|
|||
;;; rtree.el --- functions for manipulating range trees
|
||||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation; either version 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:
|
||||
|
||||
;; A "range tree" is a binary tree that stores ranges. They are
|
||||
;; similar to interval trees, but do not allow overlapping intervals.
|
||||
|
||||
;; A range is an ordered list of number intervals, like this:
|
||||
|
||||
;; ((10 . 25) 56 78 (98 . 201))
|
||||
|
||||
;; Common operations, like lookup, deletion and insertion are O(n) in
|
||||
;; a range, but an rtree is O(log n) in all these operations.
|
||||
;; Transformation between a range and an rtree is O(n).
|
||||
|
||||
;; The rtrees are quite simple. The structure of each node is
|
||||
|
||||
;; (cons (cons low high) (cons left right))
|
||||
|
||||
;; That is, they are three cons cells, where the car of the top cell
|
||||
;; is the actual range, and the cdr has the left and right child. The
|
||||
;; rtrees aren't automatically balanced, but are balanced when
|
||||
;; created, and can be rebalanced when deemed necessary.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile
|
||||
(require 'cl))
|
||||
|
||||
(defmacro rtree-make-node ()
|
||||
`(list (list nil) nil))
|
||||
|
||||
(defmacro rtree-set-left (node left)
|
||||
`(setcar (cdr ,node) ,left))
|
||||
|
||||
(defmacro rtree-set-right (node right)
|
||||
`(setcdr (cdr ,node) ,right))
|
||||
|
||||
(defmacro rtree-set-range (node range)
|
||||
`(setcar ,node ,range))
|
||||
|
||||
(defmacro rtree-low (node)
|
||||
`(caar ,node))
|
||||
|
||||
(defmacro rtree-high (node)
|
||||
`(cdar ,node))
|
||||
|
||||
(defmacro rtree-set-low (node number)
|
||||
`(setcar (car ,node) ,number))
|
||||
|
||||
(defmacro rtree-set-high (node number)
|
||||
`(setcdr (car ,node) ,number))
|
||||
|
||||
(defmacro rtree-left (node)
|
||||
`(cadr ,node))
|
||||
|
||||
(defmacro rtree-right (node)
|
||||
`(cddr ,node))
|
||||
|
||||
(defmacro rtree-range (node)
|
||||
`(car ,node))
|
||||
|
||||
(defsubst rtree-normalise-range (range)
|
||||
(when (numberp range)
|
||||
(setq range (cons range range)))
|
||||
range)
|
||||
|
||||
(defun rtree-make (range)
|
||||
"Make an rtree from RANGE."
|
||||
;; Normalize the range.
|
||||
(unless (listp (cdr-safe range))
|
||||
(setq range (list range)))
|
||||
(rtree-make-1 (cons nil range) (length range)))
|
||||
|
||||
(defun rtree-make-1 (range length)
|
||||
(let ((mid (/ length 2))
|
||||
(node (rtree-make-node)))
|
||||
(when (> mid 0)
|
||||
(rtree-set-left node (rtree-make-1 range mid)))
|
||||
(rtree-set-range node (rtree-normalise-range (cadr range)))
|
||||
(setcdr range (cddr range))
|
||||
(when (> (- length mid 1) 0)
|
||||
(rtree-set-right node (rtree-make-1 range (- length mid 1))))
|
||||
node))
|
||||
|
||||
(defun rtree-memq (tree number)
|
||||
"Return non-nil if NUMBER is present in TREE."
|
||||
(while (and tree
|
||||
(not (and (>= number (rtree-low tree))
|
||||
(<= number (rtree-high tree)))))
|
||||
(setq tree
|
||||
(if (< number (rtree-low tree))
|
||||
(rtree-left tree)
|
||||
(rtree-right tree))))
|
||||
tree)
|
||||
|
||||
(defun rtree-add (tree number)
|
||||
"Add NUMBER to TREE."
|
||||
(while tree
|
||||
(cond
|
||||
;; It's already present, so we don't have to do anything.
|
||||
((and (>= number (rtree-low tree))
|
||||
(<= number (rtree-high tree)))
|
||||
(setq tree nil))
|
||||
((< number (rtree-low tree))
|
||||
(cond
|
||||
;; Extend the low range.
|
||||
((= number (1- (rtree-low tree)))
|
||||
(rtree-set-low tree number)
|
||||
;; Check whether we need to merge this node with the child.
|
||||
(when (and (rtree-left tree)
|
||||
(= (rtree-high (rtree-left tree)) (1- number)))
|
||||
;; Extend the range to the low from the child.
|
||||
(rtree-set-low tree (rtree-low (rtree-left tree)))
|
||||
;; The child can't have a right child, so just transplant the
|
||||
;; child's left tree to our left tree.
|
||||
(rtree-set-left tree (rtree-left (rtree-left tree))))
|
||||
(setq tree nil))
|
||||
;; Descend further to the left.
|
||||
((rtree-left tree)
|
||||
(setq tree (rtree-left tree)))
|
||||
;; Add a new node.
|
||||
(t
|
||||
(let ((new-node (rtree-make-node)))
|
||||
(rtree-set-low new-node number)
|
||||
(rtree-set-high new-node number)
|
||||
(rtree-set-left tree new-node)
|
||||
(setq tree nil)))))
|
||||
(t
|
||||
(cond
|
||||
;; Extend the high range.
|
||||
((= number (1+ (rtree-high tree)))
|
||||
(rtree-set-high tree number)
|
||||
;; Check whether we need to merge this node with the child.
|
||||
(when (and (rtree-right tree)
|
||||
(= (rtree-low (rtree-right tree)) (1+ number)))
|
||||
;; Extend the range to the high from the child.
|
||||
(rtree-set-high tree (rtree-high (rtree-right tree)))
|
||||
;; The child can't have a left child, so just transplant the
|
||||
;; child's left right to our right tree.
|
||||
(rtree-set-right tree (rtree-right (rtree-right tree))))
|
||||
(setq tree nil))
|
||||
;; Descend further to the right.
|
||||
((rtree-right tree)
|
||||
(setq tree (rtree-right tree)))
|
||||
;; Add a new node.
|
||||
(t
|
||||
(let ((new-node (rtree-make-node)))
|
||||
(rtree-set-low new-node number)
|
||||
(rtree-set-high new-node number)
|
||||
(rtree-set-right tree new-node)
|
||||
(setq tree nil))))))))
|
||||
|
||||
(defun rtree-delq (tree number)
|
||||
"Remove NUMBER from TREE destructively. Returns the new tree."
|
||||
(let ((result tree)
|
||||
prev)
|
||||
(while tree
|
||||
(cond
|
||||
((< number (rtree-low tree))
|
||||
(setq prev tree
|
||||
tree (rtree-left tree)))
|
||||
((> number (rtree-high tree))
|
||||
(setq prev tree
|
||||
tree (rtree-right tree)))
|
||||
;; The number is in this node.
|
||||
(t
|
||||
(cond
|
||||
;; The only entry; delete the node.
|
||||
((= (rtree-low tree) (rtree-high tree))
|
||||
(cond
|
||||
;; Two children. Replace with successor value.
|
||||
((and (rtree-left tree) (rtree-right tree))
|
||||
(let ((parent tree)
|
||||
(successor (rtree-right tree)))
|
||||
(while (rtree-left successor)
|
||||
(setq parent successor
|
||||
successor (rtree-left successor)))
|
||||
;; We now have the leftmost child of our right child.
|
||||
(rtree-set-range tree (rtree-range successor))
|
||||
;; Transplant the child (if any) to the parent.
|
||||
(rtree-set-left parent (rtree-right successor))))
|
||||
(t
|
||||
(let ((rest (or (rtree-left tree)
|
||||
(rtree-right tree))))
|
||||
;; One or zero children. Remove the node.
|
||||
(cond
|
||||
((null prev)
|
||||
(setq result rest))
|
||||
((eq (rtree-left prev) tree)
|
||||
(rtree-set-left prev rest))
|
||||
(t
|
||||
(rtree-set-right prev rest)))))))
|
||||
;; The lowest in the range; just adjust.
|
||||
((= number (rtree-low tree))
|
||||
(rtree-set-low tree (1+ number)))
|
||||
;; The highest in the range; just adjust.
|
||||
((= number (rtree-high tree))
|
||||
(rtree-set-high tree (1- number)))
|
||||
;; We have to split this range.
|
||||
(t
|
||||
(let ((new-node (rtree-make-node)))
|
||||
(rtree-set-low new-node (rtree-low tree))
|
||||
(rtree-set-high new-node (1- number))
|
||||
(rtree-set-low tree (1+ number))
|
||||
(cond
|
||||
;; Two children; insert the new node as the predecessor
|
||||
;; node.
|
||||
((and (rtree-left tree) (rtree-right tree))
|
||||
(let ((predecessor (rtree-left tree)))
|
||||
(while (rtree-right predecessor)
|
||||
(setq predecessor (rtree-right predecessor)))
|
||||
(rtree-set-right predecessor new-node)))
|
||||
((rtree-left tree)
|
||||
(rtree-set-right new-node tree)
|
||||
(rtree-set-left new-node (rtree-left tree))
|
||||
(rtree-set-left tree nil)
|
||||
(cond
|
||||
((null prev)
|
||||
(setq result new-node))
|
||||
((eq (rtree-left prev) tree)
|
||||
(rtree-set-left prev new-node))
|
||||
(t
|
||||
(rtree-set-right prev new-node))))
|
||||
(t
|
||||
(rtree-set-left tree new-node))))))
|
||||
(setq tree nil))))
|
||||
result))
|
||||
|
||||
(defun rtree-extract (tree)
|
||||
"Convert TREE to range form."
|
||||
(let (stack result)
|
||||
(while (or stack
|
||||
tree)
|
||||
(if tree
|
||||
(progn
|
||||
(push tree stack)
|
||||
(setq tree (rtree-right tree)))
|
||||
(setq tree (pop stack))
|
||||
(push (if (= (rtree-low tree)
|
||||
(rtree-high tree))
|
||||
(rtree-low tree)
|
||||
(rtree-range tree))
|
||||
result)
|
||||
(setq tree (rtree-left tree))))
|
||||
result))
|
||||
|
||||
(defun rtree-length (tree)
|
||||
"Return the number of numbers stored in TREE."
|
||||
(if (null tree)
|
||||
0
|
||||
(+ (rtree-length (rtree-left tree))
|
||||
(1+ (- (rtree-high tree)
|
||||
(rtree-low tree)))
|
||||
(rtree-length (rtree-right tree)))))
|
||||
|
||||
(provide 'rtree)
|
||||
|
||||
;;; rtree.el ends here
|
||||
136
lisp/gnus/shr.el
136
lisp/gnus/shr.el
|
|
@ -32,8 +32,6 @@
|
|||
|
||||
(eval-when-compile (require 'cl))
|
||||
(require 'browse-url)
|
||||
(unless (aref (char-category-set (make-char 'japanese-jisx0208 33 35)) ?>)
|
||||
(load "kinsoku" nil t))
|
||||
|
||||
(defgroup shr nil
|
||||
"Simple HTML Renderer"
|
||||
|
|
@ -214,6 +212,26 @@ redirects somewhere else."
|
|||
((listp (cdr sub))
|
||||
(shr-descend sub)))))
|
||||
|
||||
(defmacro shr-char-breakable-p (char)
|
||||
"Return non-nil if a line can be broken before and after CHAR."
|
||||
`(aref fill-find-break-point-function-table ,char))
|
||||
(defmacro shr-char-nospace-p (char)
|
||||
"Return non-nil if no space is required before and after CHAR."
|
||||
`(aref fill-nospace-between-words-table ,char))
|
||||
|
||||
;; KINSOKU is a Japanese word meaning a rule that should not be violated.
|
||||
;; In Emacs, it is a term used for characters, e.g. punctuation marks,
|
||||
;; parentheses, and so on, that should not be placed in the beginning
|
||||
;; of a line or the end of a line.
|
||||
(defmacro shr-char-kinsoku-bol-p (char)
|
||||
"Return non-nil if a line ought not to begin with CHAR."
|
||||
`(aref (char-category-set ,char) ?>))
|
||||
(defmacro shr-char-kinsoku-eol-p (char)
|
||||
"Return non-nil if a line ought not to end with CHAR."
|
||||
`(aref (char-category-set ,char) ?<))
|
||||
(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
|
||||
(load "kinsoku" nil t))
|
||||
|
||||
(defun shr-insert (text)
|
||||
(when (and (eq shr-state 'image)
|
||||
(not (string-match "\\`[ \t\n]+\\'" text)))
|
||||
|
|
@ -242,12 +260,11 @@ redirects somewhere else."
|
|||
(let (prev)
|
||||
(when (and (eq (preceding-char) ? )
|
||||
(or (= (line-beginning-position) (1- (point)))
|
||||
(and (aref fill-find-break-point-function-table
|
||||
(and (shr-char-breakable-p
|
||||
(setq prev (char-after (- (point) 2))))
|
||||
(aref (char-category-set prev) ?>))
|
||||
(and (aref fill-nospace-between-words-table prev)
|
||||
(aref fill-nospace-between-words-table
|
||||
(aref elem 0)))))
|
||||
(shr-char-kinsoku-bol-p prev))
|
||||
(and (shr-char-nospace-p prev)
|
||||
(shr-char-nospace-p (aref elem 0)))))
|
||||
(delete-char -1)))
|
||||
(insert elem)
|
||||
(let (found)
|
||||
|
|
@ -273,67 +290,88 @@ redirects somewhere else."
|
|||
(defun shr-find-fill-point ()
|
||||
(when (> (move-to-column shr-width) shr-width)
|
||||
(backward-char 1))
|
||||
(let (failed)
|
||||
(while (not
|
||||
(or (setq failed (= (current-column) shr-indentation))
|
||||
(let ((bp (point))
|
||||
failed)
|
||||
(while (not (or (setq failed (= (current-column) shr-indentation))
|
||||
(eq (preceding-char) ? )
|
||||
(eq (following-char) ? )
|
||||
(aref fill-find-break-point-function-table (preceding-char))
|
||||
(aref (char-category-set (preceding-char)) ?>)))
|
||||
(shr-char-breakable-p (preceding-char))
|
||||
(shr-char-breakable-p (following-char))
|
||||
(and (eq (preceding-char) ?')
|
||||
(not (memq (char-after (- (point) 2))
|
||||
(list nil ?\n ? ))))
|
||||
;; There're some kinsoku CJK chars that aren't breakable.
|
||||
(and (shr-char-kinsoku-bol-p (preceding-char))
|
||||
(not (shr-char-kinsoku-bol-p (following-char))))
|
||||
(shr-char-kinsoku-eol-p (following-char))))
|
||||
(backward-char 1))
|
||||
(if (and (not (or failed (eolp)))
|
||||
(eq (preceding-char) ?'))
|
||||
(while (not (or (setq failed (eolp))
|
||||
(eq (following-char) ? )
|
||||
(shr-char-breakable-p (following-char))
|
||||
(shr-char-kinsoku-eol-p (following-char))))
|
||||
(forward-char 1)))
|
||||
(if failed
|
||||
;; There's no breakable point, so we give it up.
|
||||
(progn
|
||||
(end-of-line)
|
||||
(while (aref fill-find-break-point-function-table (preceding-char))
|
||||
(backward-char 1))
|
||||
nil)
|
||||
(let (found)
|
||||
(goto-char bp)
|
||||
(unless shr-kinsoku-shorten
|
||||
(while (and (setq found (re-search-forward
|
||||
"\\(\\c>\\)\\| \\|\\c<\\|\\c|"
|
||||
(line-end-position) 'move))
|
||||
(eq (preceding-char) ?')))
|
||||
(if (and found (not (match-beginning 1)))
|
||||
(goto-char (match-beginning 0)))))
|
||||
(or
|
||||
(eolp)
|
||||
(progn
|
||||
;; Don't put kinsoku-bol characters at the beginning of a line,
|
||||
;; or kinsoku-eol characters at the end of a line.
|
||||
(cond
|
||||
(shr-kinsoku-shorten
|
||||
(while (and
|
||||
(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
|
||||
(not (or (aref (char-category-set (preceding-char)) ?>)
|
||||
(aref (char-category-set (following-char)) ?<)))
|
||||
(or (aref (char-category-set (preceding-char)) ?<)
|
||||
(aref (char-category-set (following-char)) ?>)))
|
||||
(backward-char 1)))
|
||||
((aref (char-category-set (preceding-char)) ?<)
|
||||
(let ((count 3))
|
||||
(while (progn
|
||||
(backward-char 1)
|
||||
(and
|
||||
(> (setq count (1- count)) 0)
|
||||
(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
|
||||
(or (aref (char-category-set (preceding-char)) ?<)
|
||||
(aref (char-category-set (following-char)) ?>))))))
|
||||
(if (and (setq failed (= (current-column) shr-indentation))
|
||||
(re-search-forward "\\c|" (line-end-position) 'move))
|
||||
(while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
|
||||
(shr-char-kinsoku-eol-p (preceding-char)))
|
||||
(backward-char 1))
|
||||
(when (setq failed (= (current-column) shr-indentation))
|
||||
;; There's no breakable point that doesn't violate kinsoku,
|
||||
;; so we look for the second best position.
|
||||
(let (bp)
|
||||
(while (and (<= (current-column) shr-width)
|
||||
(while (and (progn
|
||||
(forward-char 1)
|
||||
(<= (current-column) shr-width))
|
||||
(progn
|
||||
(setq bp (point))
|
||||
(not (eolp)))
|
||||
(aref fill-find-break-point-function-table
|
||||
(following-char)))
|
||||
(forward-char 1))
|
||||
(goto-char (or bp (line-end-position))))))
|
||||
(shr-char-kinsoku-eol-p (following-char)))))
|
||||
(goto-char bp)))
|
||||
((shr-char-kinsoku-eol-p (preceding-char))
|
||||
(if (shr-char-kinsoku-eol-p (following-char))
|
||||
;; There are consecutive kinsoku-eol characters.
|
||||
(setq failed t)
|
||||
(let ((count 4))
|
||||
(while
|
||||
(progn
|
||||
(backward-char 1)
|
||||
(and (> (setq count (1- count)) 0)
|
||||
(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
|
||||
(or (shr-char-kinsoku-eol-p (preceding-char))
|
||||
(shr-char-kinsoku-bol-p (following-char)))))))
|
||||
(if (setq failed (= (current-column) shr-indentation))
|
||||
;; There's no breakable point that doesn't violate kinsoku,
|
||||
;; so we go to the second best position.
|
||||
(if (looking-at "\\(\\c<+\\)\\c<")
|
||||
(goto-char (match-end 1))
|
||||
(forward-char 1)))))
|
||||
(t
|
||||
(if (shr-char-kinsoku-bol-p (preceding-char))
|
||||
;; There are consecutive kinsoku-bol characters.
|
||||
(setq failed t)
|
||||
(let ((count 4))
|
||||
(while (and (>= (setq count (1- count)) 0)
|
||||
(aref (char-category-set (following-char)) ?>)
|
||||
(aref fill-find-break-point-function-table
|
||||
(following-char)))
|
||||
(forward-char 1)))))
|
||||
(shr-char-kinsoku-bol-p (following-char))
|
||||
(shr-char-breakable-p (following-char)))
|
||||
(forward-char 1))))))
|
||||
(when (eq (following-char) ? )
|
||||
(forward-char 1))
|
||||
(not failed))))))
|
||||
(forward-char 1))))
|
||||
(not failed)))
|
||||
|
||||
(defun shr-ensure-newline ()
|
||||
(unless (zerop (current-column))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue