# HG changeset patch # User Katsumi Yamaoka # Date 1291328491 0 # Node ID f97704487fb3aea24f7c3d60b8853f84959fd7c3 # Parent 8e746f39623779d57b19e6a438a9f7933df563f6 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. diff -r 8e746f396237 -r f97704487fb3 doc/misc/ChangeLog --- a/doc/misc/ChangeLog Thu Dec 02 20:34:31 2010 +0100 +++ b/doc/misc/ChangeLog Thu Dec 02 22:21:31 2010 +0000 @@ -1,3 +1,12 @@ +2010-12-02 Julien Danjou + + * gnus.texi (Archived Messages): Remove gnus-outgoing-message-group. + +2010-11-28 Lars Magne Ingebrigtsen + + * gnus.texi (Customizing the IMAP Connection): Note the new defaults. + (Direct Functions): Note the STARTTLS upgrade. + 2010-11-27 Glenn Morris James Clark diff -r 8e746f396237 -r f97704487fb3 doc/misc/gnus.texi --- a/doc/misc/gnus.texi Thu Dec 02 20:34:31 2010 +0100 +++ b/doc/misc/gnus.texi Thu Dec 02 22:21:31 2010 +0000 @@ -13342,21 +13342,6 @@ 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 @@ @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 @@ 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. diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/ChangeLog Thu Dec 02 22:21:31 2010 +0000 @@ -1,3 +1,228 @@ +2010-12-02 Andrew Cohen + + * 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 + + * 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 + + * 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 + + * rtree.el: New file. + +2010-12-01 Julien Danjou + + * 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 + + * nnmaildir.el (nnmaildir-request-set-mark): Add article to add-mark + funcall. + +2010-12-01 Katsumi Yamaoka + + * 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 . + (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 + + * proto-stream.el (open-protocol-stream): All starttls connections are + handled by the network handler. + +2010-11-30 Julien Danjou + + * 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 + + * 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 + + * 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 + + * shr.el (shr-find-fill-point): Don't break before apostrophes. + +2010-11-29 Binjo (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 + + * gnus-sum.el (gnus-summary-delete-article): If delete fails don't + change the registry. + +2010-11-29 Katsumi Yamaoka + + * 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 + + * nnir.el (nnir-ignored-newsgroups): New variable. + (nnir-get-active): Use it. + +2010-11-28 Lars Magne Ingebrigtsen + + * 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 + + * 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 + + * 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 + + * 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 (tiny change) * pop3.el (pop3-open-server): Read server greeting before starting TLS diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/color.el --- a/lisp/gnus/color.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/color.el Thu Dec 02 22:21:31 2010 +0000 @@ -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 @@ (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 @@ (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 @@ (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 @@ (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. diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/gnus-gravatar.el --- a/lisp/gnus/gnus-gravatar.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/gnus-gravatar.el Thu Dec 02 22:21:31 2010 +0000 @@ -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)))) - (gravatar-size gnus-gravatar-size) - name) + (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,12 +84,15 @@ (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) "\\|" - (regexp-quote mail-address)) - nil t) + (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)) (goto-char (1- (match-beginning 0))) ;; If we're on the " quoting the name, go backward @@ -103,8 +103,7 @@ ;; 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) diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/gnus-msg.el --- a/lisp/gnus/gnus-msg.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/gnus-msg.el Thu Dec 02 22:21:31 2010 +0000 @@ -55,7 +55,7 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/gnus-sum.el --- a/lisp/gnus/gnus-sum.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/gnus-sum.el Thu Dec 02 22:21:31 2010 +0000 @@ -1310,7 +1310,6 @@ (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 @@ (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 @@ (?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 @@ 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,210 +9741,203 @@ ;; 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 - ;; Move the article. - ((eq action 'move) - ;; Remove this article from future suppression. - (gnus-dup-unsuppress-article article) - (let* ((from-method (gnus-find-method-for-group - gnus-newsgroup-name)) - (to-method (or select-method - (gnus-find-method-for-group to-newsgroup))) - (move-is-internal (gnus-server-equal from-method to-method))) - (gnus-request-move-article - article ; Article to move - gnus-newsgroup-name ; From newsgroup - (nth 1 (gnus-find-method-for-group - gnus-newsgroup-name)) ; Server - (list 'gnus-request-accept-article - to-newsgroup (list 'quote select-method) - (not articles) t) ; Accept form - (not articles) ; Only save nov last time - (and move-is-internal - to-newsgroup ; Not respooling + (setq + art-group + (cond + ;; Move the article. + ((eq action 'move) + ;; Remove this article from future suppression. + (gnus-dup-unsuppress-article article) + (let* ((from-method (gnus-find-method-for-group + gnus-newsgroup-name)) + (to-method (or select-method + (gnus-find-method-for-group to-newsgroup))) + (move-is-internal (gnus-server-equal from-method to-method))) + (gnus-request-move-article + article ; Article to move + gnus-newsgroup-name ; From newsgroup + (nth 1 (gnus-find-method-for-group + gnus-newsgroup-name)) ; Server + (list 'gnus-request-accept-article + to-newsgroup (list 'quote select-method) + (not articles) t) ; Accept form + (not articles) ; Only save nov last time + (and move-is-internal + to-newsgroup ; Not respooling ; Is this move internal? - (gnus-group-real-name to-newsgroup))))) - ;; Copy the article. - ((eq action 'copy) + (gnus-group-real-name to-newsgroup))))) + ;; Copy the article. + ((eq action 'copy) + (with-current-buffer copy-buf + (when (gnus-request-article-this-buffer article + gnus-newsgroup-name) + (save-restriction + (nnheader-narrow-to-headers) + (dolist (hdr gnus-copy-article-ignored-headers) + (message-remove-header hdr t))) + (gnus-request-accept-article + to-newsgroup select-method (not articles) t)))) + ;; Crosspost the article. + ((eq action 'crosspost) + (let ((xref (message-tokenize-header + (mail-header-xref (gnus-summary-article-header + article)) + " "))) + (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) + ":" (number-to-string article))) + (unless xref + (setq xref (list (system-name)))) + (setq new-xref + (concat + (mapconcat 'identity + (delete "Xref:" (delete new-xref xref)) + " ") + " " new-xref)) (with-current-buffer copy-buf - (when (gnus-request-article-this-buffer article - gnus-newsgroup-name) - (save-restriction - (nnheader-narrow-to-headers) - (dolist (hdr gnus-copy-article-ignored-headers) - (message-remove-header hdr t))) - (gnus-request-accept-article - to-newsgroup select-method (not articles) t)))) - ;; Crosspost the article. - ((eq action 'crosspost) - (let ((xref (message-tokenize-header - (mail-header-xref (gnus-summary-article-header - article)) - " "))) - (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) - ":" (number-to-string article))) - (unless xref - (setq xref (list (system-name)))) - (setq new-xref - (concat - (mapconcat 'identity - (delete "Xref:" (delete new-xref xref)) - " ") - " " new-xref)) - (with-current-buffer copy-buf - ;; First put the article in the destination group. - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (when (consp (setq art-group - (gnus-request-accept-article - to-newsgroup select-method (not articles) - t))) - (setq new-xref (concat new-xref " " (car art-group) - ":" - (number-to-string (cdr art-group)))) - ;; Now we have the new Xrefs header, so we insert - ;; it and replace the new article. - (nnheader-replace-header "Xref" new-xref) - (gnus-request-replace-article - (cdr art-group) to-newsgroup (current-buffer) t) - art-group)))))) - (cond - ((not art-group) - (gnus-message 1 "Couldn't %s article %s: %s" - (cadr (assq action names)) article - (nnheader-get-report (car to-method)))) - ((eq art-group 'junk) - (when (eq action 'move) - (gnus-summary-mark-article article gnus-canceled-mark) - (gnus-message 4 "Deleted article %s" article) - ;; run the delete hook - (run-hook-with-args 'gnus-summary-article-delete-hook - action - (gnus-data-header - (assoc article (gnus-data-list nil))) - gnus-newsgroup-original-name nil - select-method))) - (t - (let* ((pto-group (gnus-group-prefixed-name - (car art-group) to-method)) - (info (gnus-get-info pto-group)) - (to-group (gnus-info-group info)) - to-marks) - ;; Update the group that has been moved to. - (when (and info - (memq action '(move copy))) - (unless (member to-group to-groups) - (push to-group to-groups)) - - (unless (memq article gnus-newsgroup-unreads) - (push 'read to-marks) - (gnus-info-set-read - info (gnus-add-to-range (gnus-info-read info) - (list (cdr art-group))))) - - ;; See whether the article is to be put in the cache. - (let* ((expirable (gnus-group-auto-expirable-p to-group)) - (marks (if expirable - gnus-article-mark-lists - (delete '(expirable . expire) - (copy-sequence - gnus-article-mark-lists)))) - (to-article (cdr art-group))) - - ;; Enter the article into the cache in the new group, - ;; if that is required. - (when gnus-use-cache - (gnus-cache-possibly-enter-article - to-group to-article - (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-unreads))) - - (when gnus-preserve-marks - ;; Copy any marks over to the new group. - (when (and (equal to-group gnus-newsgroup-name) - (not (memq article gnus-newsgroup-unreads))) - ;; Mark this article as read in this group. - (push (cons to-article gnus-read-mark) - gnus-newsgroup-reads) - ;; Increase the active status of this group. - (setcdr (gnus-active to-group) to-article) - (setcdr gnus-newsgroup-active to-article)) - - (while marks - (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) - (when (memq article (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))) - (push (cdar marks) to-marks) - ;; If the other group is the same as this group, - ;; then we have to add the mark to the list. - (when (equal to-group gnus-newsgroup-name) - (set (intern (format "gnus-newsgroup-%s" - (caar marks))) - (cons to-article - (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))))) - ;; Copy the marks to other group. - (gnus-add-marked-articles - to-group (cdar marks) (list to-article) info))) - (setq marks (cdr marks))) - - (when (and expirable - gnus-mark-copied-or-moved-articles-as-expirable - (not (memq 'expire to-marks))) - ;; Mark this article as expirable. - (push 'expire to-marks) - (when (equal to-group gnus-newsgroup-name) - (push to-article gnus-newsgroup-expirable)) - ;; Copy the expirable mark to other group. - (gnus-add-marked-articles - to-group 'expire (list to-article) info)) - - (when to-marks - (gnus-request-set-mark - to-group (list (list (list to-article) 'add to-marks))))) - - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string (gnus-get-info to-group)) - ")")))) - - ;; Update the Xref header in this article to point to - ;; the new crossposted article we have just created. - (when (eq action 'crosspost) - (with-current-buffer copy-buf - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (nnheader-replace-header "Xref" new-xref) - (gnus-request-replace-article - article gnus-newsgroup-name (current-buffer) 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 - to-newsgroup - select-method))) - - ;;;!!!Why is this necessary? - (set-buffer gnus-summary-buffer) - - (when (eq action 'move) - (save-excursion - (gnus-summary-goto-subject article) - (gnus-summary-mark-article article gnus-canceled-mark))))) - (push article articles-to-update-marks))) + ;; First put the article in the destination group. + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (when (consp (setq art-group + (gnus-request-accept-article + to-newsgroup select-method (not articles) + t))) + (setq new-xref (concat new-xref " " (car art-group) + ":" + (number-to-string (cdr art-group)))) + ;; Now we have the new Xrefs header, so we insert + ;; it and replace the new article. + (nnheader-replace-header "Xref" new-xref) + (gnus-request-replace-article + (cdr art-group) to-newsgroup (current-buffer) t) + art-group)))))) + (cond + ((not art-group) + (gnus-message 1 "Couldn't %s article %s: %s" + (cadr (assq action names)) article + (nnheader-get-report (car to-method)))) + ((eq art-group 'junk) + (when (eq action 'move) + (gnus-summary-mark-article article gnus-canceled-mark) + (gnus-message 4 "Deleted article %s" article) + ;; run the delete hook + (run-hook-with-args 'gnus-summary-article-delete-hook + action + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name nil + select-method))) + (t + (let* ((pto-group (gnus-group-prefixed-name + (car art-group) to-method)) + (info (gnus-get-info pto-group)) + (to-group (gnus-info-group info)) + to-marks) + ;; Update the group that has been moved to. + (when (and info + (memq action '(move copy))) + (unless (member to-group to-groups) + (push to-group to-groups)) + + (unless (memq article gnus-newsgroup-unreads) + (push 'read to-marks) + (gnus-info-set-read + info (gnus-add-to-range (gnus-info-read info) + (list (cdr art-group))))) + + ;; See whether the article is to be put in the cache. + (let* ((expirable (gnus-group-auto-expirable-p to-group)) + (marks (if expirable + gnus-article-mark-lists + (delete '(expirable . expire) + (copy-sequence + gnus-article-mark-lists)))) + (to-article (cdr art-group))) + + ;; Enter the article into the cache in the new group, + ;; if that is required. + (when gnus-use-cache + (gnus-cache-possibly-enter-article + to-group to-article + (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-unreads))) + + (when gnus-preserve-marks + ;; Copy any marks over to the new group. + (when (and (equal to-group gnus-newsgroup-name) + (not (memq article gnus-newsgroup-unreads))) + ;; Mark this article as read in this group. + (push (cons to-article gnus-read-mark) + gnus-newsgroup-reads) + ;; Increase the active status of this group. + (setcdr (gnus-active to-group) to-article) + (setcdr gnus-newsgroup-active to-article)) + + (while marks + (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (when (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + (push (cdar marks) to-marks) + ;; If the other group is the same as this group, + ;; then we have to add the mark to the list. + (when (equal to-group gnus-newsgroup-name) + (set (intern (format "gnus-newsgroup-%s" + (caar marks))) + (cons to-article + (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))))) + ;; Copy the marks to other group. + (gnus-add-marked-articles + to-group (cdar marks) (list to-article) info))) + (setq marks (cdr marks))) + + (when (and expirable + gnus-mark-copied-or-moved-articles-as-expirable + (not (memq 'expire to-marks))) + ;; Mark this article as expirable. + (push 'expire to-marks) + (when (equal to-group gnus-newsgroup-name) + (push to-article gnus-newsgroup-expirable)) + ;; Copy the expirable mark to other group. + (gnus-add-marked-articles + to-group 'expire (list to-article) info)) + + (when to-marks + (gnus-request-set-mark + to-group (list (list (list to-article) 'add to-marks))))) + + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (gnus-get-info to-group)) + ")")))) + + ;; Update the Xref header in this article to point to + ;; the new crossposted article we have just created. + (when (eq action 'crosspost) + (with-current-buffer copy-buf + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (nnheader-replace-header "Xref" new-xref) + (gnus-request-replace-article + article gnus-newsgroup-name (current-buffer) t))) + + ;; run the move/copy/crosspost/respool hook + (run-hook-with-args 'gnus-summary-article-move-hook + action + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name + to-newsgroup + select-method)) + + ;;;!!!Why is this necessary? + (set-buffer gnus-summary-buffer) + + (when (eq action 'move) + (save-excursion + (gnus-summary-goto-subject article) + (gnus-summary-mark-article article gnus-canceled-mark))))) + (push article articles-to-update-marks)) (save-excursion (apply 'gnus-summary-remove-process-mark articles-to-update-marks)) @@ -10213,13 +10216,13 @@ ;; 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)) - (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)) + (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))) (setq articles (cdr articles)))) (when not-deleted (gnus-message 4 "Couldn't delete articles %s" not-deleted))) diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/gnus-win.el --- a/lisp/gnus/gnus-win.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/gnus-win.el Thu Dec 02 22:21:31 2010 +0000 @@ -228,50 +228,6 @@ (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 @@ (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,56 +370,55 @@ (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)) - all-visible) + (cadr (assq setting gnus-buffer-configuration)) + setting)) + all-visible) (setq gnus-frame-split-p nil) (unless split - (error "No such setting in `gnus-buffer-configuration': %s" setting)) + (error "No such setting in `gnus-buffer-configuration': %s" setting)) (if (and (setq all-visible (gnus-all-windows-visible-p split)) - (not force)) - ;; All the windows mentioned are already visible, so we just - ;; put point in the assigned buffer, and do not touch the - ;; winconf. - (select-window all-visible) + (not force)) + ;; All the windows mentioned are already visible, so we just + ;; put point in the assigned buffer, and do not touch the + ;; winconf. + (select-window all-visible) - ;; Make sure "the other" buffer, nntp-server-buffer, is live. - (unless (gnus-buffer-live-p nntp-server-buffer) - (nnheader-init-server-buffer)) + ;; Make sure "the other" buffer, nntp-server-buffer, is live. + (unless (gnus-buffer-live-p nntp-server-buffer) + (nnheader-init-server-buffer)) - ;; Either remove all windows or just remove all Gnus windows. - (let ((frame (selected-frame))) - (unwind-protect - (if gnus-use-full-window - ;; We want to remove all other windows. - (if (not gnus-frame-split-p) - ;; This is not a `frame' split, so we ignore the - ;; other frames. - (delete-other-windows) - ;; This is a `frame' split, so we delete all windows - ;; on all frames. - (gnus-delete-windows-in-gnusey-frames)) - ;; Just remove some windows. - (gnus-remove-some-windows) - (if (featurep 'xemacs) - (switch-to-buffer nntp-server-buffer) - (set-buffer nntp-server-buffer))) - (select-frame frame))) + ;; Either remove all windows or just remove all Gnus windows. + (let ((frame (selected-frame))) + (unwind-protect + (if gnus-use-full-window + ;; We want to remove all other windows. + (if (not gnus-frame-split-p) + ;; This is not a `frame' split, so we ignore the + ;; other frames. + (delete-other-windows) + ;; This is a `frame' split, so we delete all windows + ;; on all frames. + (gnus-delete-windows-in-gnusey-frames)) + ;; Just remove some windows. + (gnus-remove-some-windows) + (if (featurep 'xemacs) + (switch-to-buffer nntp-server-buffer) + (set-buffer nntp-server-buffer))) + (select-frame frame))) - (let (gnus-window-frame-focus) - (if (featurep 'xemacs) - (switch-to-buffer nntp-server-buffer) - (set-buffer nntp-server-buffer)) - (gnus-configure-frame split) - (run-hooks 'gnus-configure-windows-hook) - (when gnus-window-frame-focus - (gnus-select-frame-set-input-focus - (window-frame gnus-window-frame-focus)))))))) + (let (gnus-window-frame-focus) + (if (featurep 'xemacs) + (switch-to-buffer nntp-server-buffer) + (set-buffer nntp-server-buffer)) + (gnus-configure-frame split) + (run-hooks 'gnus-configure-windows-hook) + (when gnus-window-frame-focus + (gnus-select-frame-set-input-focus + (window-frame gnus-window-frame-focus)))))))) (defun gnus-delete-windows-in-gnusey-frames () "Do a `delete-other-windows' in all frames that have Gnus windows." diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/gnus.el --- a/lisp/gnus/gnus.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/gnus.el Thu Dec 02 22:21:31 2010 +0000 @@ -1401,10 +1401,6 @@ 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 diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/message.el --- a/lisp/gnus/message.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/message.el Thu Dec 02 22:21:31 2010 +0000 @@ -160,8 +160,12 @@ :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 @@ :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 diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/mm-util.el --- a/lisp/gnus/mm-util.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/mm-util.el Thu Dec 02 22:21:31 2010 +0000 @@ -974,6 +974,7 @@ ;; 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) diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/nnimap.el --- a/lisp/gnus/nnimap.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/nnimap.el Thu Dec 02 22:21:31 2010 +0000 @@ -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 @@ (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,111 +302,79 @@ (* 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 (buffer) +(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) - (port nil) - (ports - (cond - ((or (eq nnimap-stream 'network) - (and (eq nnimap-stream 'starttls) - (fboundp 'open-gnutls-stream))) - (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)))) - (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))) + (with-current-buffer (nnimap-make-process-buffer buffer) + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (port nil) + (ports + (cond + ((or (eq nnimap-stream 'network) + (eq nnimap-stream 'starttls)) + (nnheader-message 7 "Opening connection to %s..." + nnimap-address) + '("143" "imap")) + ((eq nnimap-stream 'shell) + (nnheader-message 7 "Opening connection to %s via shell..." + nnimap-address) + '("imap")) + ((memq nnimap-stream '(ssl tls)) + (nnheader-message 7 "Opening connection to %s via tls..." + nnimap-address) + '("143" "993" "imap" "imaps")) + (t + (error "Unknown stream type: %s" nnimap-stream)))) + (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) + '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 @@ (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) @@ -1110,7 +1063,7 @@ uidvalidity modseq) (push - (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" + (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" (utf7-encode group t) uidvalidity modseq) 'qresync diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/nnir.el --- a/lisp/gnus/nnir.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/nnir.el Thu Dec 02 22:21:31 2010 +0000 @@ -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 @@ 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 @@ ;;; 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 @@ (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,77 +592,76 @@ 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) - (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)) - (nov - (goto-char (point-min)) - (setq novitem (nnheader-parse-nov))) - (headers - (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 - (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) + (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) + ;; 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 + (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)) + (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" + ;; (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)) - ;; Bug? - ;; Why must we bind nntp-server-buffer here? It won't - ;; work if `buf' is used, say. (Of course, the set-buffer - ;; line below must then be updated, too.) - (nntp-server-buffer (or to-buffer nntp-server-buffer))) + (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 + ;; line below must then be updated, too.) + (nntp-server-buffer (or to-buffer nntp-server-buffer))) (set-buffer nntp-server-buffer) (erase-buffer) (message "Requesting article %d from group %s" @@ -586,10 +671,8 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ ;; 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 @@ 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 @@ (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 @@ (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 @@ ;; 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 @@ (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,33 +1458,34 @@ (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) - (let* ((server (car x)) - (nnir-search-engine - (or (nnir-read-server-parm 'nnir-search-engine - server) - (cdr (assoc (car - (gnus-server-to-method server)) - nnir-method-default-engines)))) - search-func) - (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)) - nil))) - groups)))) + (mapcar + (lambda (x) + (let* ((server (car x)) + (nnir-search-engine + (or (nnir-read-server-parm 'nnir-search-engine + server) + (cdr (assoc (car + (gnus-server-to-method server)) + nnir-method-default-engines)))) + search-func) + (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 (cadr x)) + nil))) + groups)))) (defun nnir-read-server-parm (key server) "Returns the parameter value of key for the given server, where @@ -1416,50 +1495,11 @@ (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 @@ 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 @@ (let ((cur (current-buffer)) name) (goto-char (point-min)) - (unless (string= gnus-ignored-newsgroups "") - (delete-matching-lines gnus-ignored-newsgroups)) - (while (not (eobp)) - (ignore-errors - (push (mm-string-as-unibyte - (let ((p (point))) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring (+ p 1) (- (point) 1))) - (gnus-group-full-name name method))) - groups)) - (forward-line)))) + (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 + (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 (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))))) 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) diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/nnmaildir.el --- a/lisp/gnus/nnmaildir.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/nnmaildir.el Thu Dec 02 22:21:31 2010 +0000 @@ -1559,7 +1559,7 @@ (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))) diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/nntp.el --- a/lisp/gnus/nntp.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/nntp.el Thu Dec 02 22:21:31 2010 +0000 @@ -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 @@ (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 @@ `(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 @@ (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. diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/proto-stream.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/proto-stream.el Thu Dec 02 22:21:31 2010 +0000 @@ -0,0 +1,262 @@ +;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/rtree.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/rtree.el Thu Dec 02 22:21:31 2010 +0000 @@ -0,0 +1,279 @@ +;;; rtree.el --- functions for manipulating range trees +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 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 diff -r 8e746f396237 -r f97704487fb3 lisp/gnus/shr.el --- a/lisp/gnus/shr.el Thu Dec 02 20:34:31 2010 +0100 +++ b/lisp/gnus/shr.el Thu Dec 02 22:21:31 2010 +0000 @@ -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 @@ ((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 @@ (let (prev) (when (and (eq (preceding-char) ? ) (or (= (line-beginning-position) (1- (point))) - (and (aref fill-find-break-point-function-table - (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))))) + (and (shr-char-breakable-p + (setq prev (char-after (- (point) 2)))) + (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 @@ (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)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (aref fill-find-break-point-function-table (preceding-char)) - (aref (char-category-set (preceding-char)) ?>))) + (let ((bp (point)) + failed) + (while (not (or (setq failed (= (current-column) shr-indentation)) + (eq (preceding-char) ? ) + (eq (following-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)) + ;; 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 ? ))) + (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. + (while (and (progn + (forward-char 1) + (<= (current-column) shr-width)) + (progn + (setq bp (point)) + (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 look for the second best position. - (let (bp) - (while (and (<= (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)))))) - (t + ;; 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))))) - (when (eq (following-char) ? ) - (forward-char 1)) - (not failed)))))) + (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))) (defun shr-ensure-newline () (unless (zerop (current-column))