diff options
Diffstat (limited to 'lisp/gnus')
145 files changed, 18075 insertions, 16469 deletions
diff --git a/lisp/gnus/.dir-locals.el b/lisp/gnus/.dir-locals.el new file mode 100644 index 0000000000..fb968e13a3 --- /dev/null +++ b/lisp/gnus/.dir-locals.el @@ -0,0 +1,4 @@ +((emacs-lisp-mode . ((show-trailing-whitespace . t)))) +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index f8d0a1cb90..326d6dbf24 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,17 +1,4894 @@ -2010-11-19 Yuri Karaban <[email protected]> (tiny change) +2011-01-13 Chong Yidong <[email protected]> + + * message.el (message-tool-bar-gnome): Tweak tool-bar items. Add + :vert-only tags. + (message-mail): New arg RETURN-ACTION. + (message-return-action): New var. + (message-bury): Use it. + (message-mode): Make it buffer-local. + (message-send-and-exit): Always call message-bury. + + * gnus-msg.el (gnus-msg-mail): New arg RETURN-ACTION. Pass it to + message-mail. + +2011-01-11 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-convert-partial-article): Protect against + zero-length body parts. + + * mm-decode.el (mm-preferred-alternative-precedence): Discourage + showing empty parts. + + * gnus-int.el (gnus-request-accept-article): Don't try to update marks + and stuff if the backend didn't return the article number. This fixes + an Exchange-related nnimap bug. + + * gnus-sum.el (gnus-summary-next-article): Remove hack to reselect + group window, because it does the wrong thing when a separate frame + displays the group buffer. + + * proto-stream.el (open-protocol-stream): Protect against the low-level + transport functions returning nil. + +2011-01-07 Daiki Ueno <[email protected]> + + * mml2015.el (epg-sub-key-fingerprint): Autoload. + (mml2015-epg-find-usable-secret-key): New function. + (mml2015-epg-sign): Use mml2015-epg-find-usable-secret-key instead of + mml2015-epg-find-usable-key (Bug#7797). + (mml2015-epg-encrypt): Ditto. + +2011-01-03 Lars Magne Ingebrigtsen <[email protected]> + + * flow-fill.el (fill-flowed-encode): Do encoding citation-aware. + +2011-01-03 Glenn Morris <[email protected]> + + * sieve-manage.el (sieve-manage-open): Correctly set sieve-manage-port. + + * sieve.el (sieve-open-server): Give a more explicit error if + sieve-manage-open returns nil. (Bug#7720) + +2011-01-02 Karl Fogel <[email protected]> + + * gnus-msg.el (gnus-message-replyencrypt): Default to `t'. + +2011-01-02 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-login): Prefer AUTH=CRAM-MD5, if it's available. + This avoids sending passwords in plain text over non-encrypted + channels. + + * shr.el (shr-rescale-image): Display all GIF images as animated images. + + * nnimap.el (nnimap-login): Refactored out into own function, and + implement CRAM-MD5. + (nnimap-wait-for-line): Refactored out. + + * mm-view.el (mml-smime): Require. + +2010-12-20 David Engster <[email protected]> + + * mm-view.el (mm-view-pkcs7-decrypt): If mml-smime-use is set to 'epg, + use EPG to decrypt S/MIME messages instead of openssl. + +2011-01-02 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-request-group): Avoid double SELECT on `M-g'. + + * gnus-group.el (gnus-group-kill-group): Don't try to update the group + status is the group clearly is unreachable. + + * auth-source.el (auth-source-create): Add the optional second + parameter to `local-variable-p' to be compatible with XEmacs. + +2011-01-02 Wang Diancheng <[email protected]> (tiny change) + + * nnml.el (nnml-request-article): Allow requesting by Message-ID to + work when using a compressed nnml folder. + +2011-01-02 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-select-newsgroup): Don't propagate marks to + backends after sanitising on entry, because this never makes sense: + If the articles have gone missing, then the data no longer exists on + the backend, and if they haven't, then Gnus is wrong, and shouldn't + overwrite anything anyway. + + * shr.el (shr-insert-document): Bind shr-width dynamically to + window-width if it's nil. + +2010-12-30 Tassilo Horn <[email protected]> + + * shr.el (shr-width, shr-insert-document): Allow nil as shr-width value + with the meaning of using the full emacs window width for rendering. + +2010-12-27 Daiki Ueno <[email protected]> + + * mml2015.el (mml2015-epg-sign, mml2015-epg-encrypt): Take care the + case when sender is not given. + +2010-12-23 Julien Danjou <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-transform-address): Set + `mail-extr-ignore-realname-equals-mailbox-name' to nil when extracting + the addresses, otherwise we might misplaced the gravatar. + +2010-12-21 Daiki Ueno <[email protected]> + + * mml1991.el (pgg-sign-region, pgg-encrypt-region): + * gnus-art.el (pgg-snarf-keys-region): Autoload since PGG is now + obsolete in Emacs. + +2010-12-20 Julien Danjou <[email protected]> + + * gnus-util.el (gnus-rescale-image): Revert last change. + +2010-12-17 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-group.el (gnus-group-delete-articles): New command. + +2010-12-17 Andrew Cohen <[email protected]> + + * nnir.el (nnir-mode): Make sure 'gnus-registry-install is bound. + +2010-12-17 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-get-newsgroup-headers): Revert the last change + here, since it's up to the backends to do CRLF removal if their + protocol has it. + + * nnimap.el (nnimap-retrieve-headers): Remove CRLF from the headers. + +2010-12-17 Julien Danjou <[email protected]> + + * gnus-util.el (gnus-rescale-image): Allow to resize images even if + they are from file. Can also scale up. + +2010-12-17 Andrew Cohen <[email protected]> + + * gnus-sum.el (gnus-summary-refer-thread): Simplify code. Restore + gnus-use-agent. + (gnus-get-newsgroup-headers): Avoid unwanted spaces at eol. + + * nnir.el (nnir-get-active): Ignore nnir-ignored-newsgroups if null. + +2010-12-17 Julien Danjou <[email protected]> + + * gravatar.el (gravatar-retrieve-synchronously): New function. + (gravatar-get-data): Make more robust. + +2010-12-16 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-wait-for-response): Fix the end-point calculation + to really consider the last line. + +2010-12-16 Daiki Ueno <[email protected]> + + * auth-source.el (auth-source-gpg-encrypt-to): New variable to set the + list of recipient keys, or use symmetric encryption if not a list. + (auth-source-create): Use it to make `epa-file-encrypt-to' local for an + EPA override, replacing the call to `netrc-store-data'. + +2010-12-16 Dan Davison <[email protected]> (tiny change) + + * gnus-srvr.el: Avoid passing nil regexp argument to + delete-matching-lines. + +2010-12-16 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-schedule-image-fetching): Make sure the HTML + fetching stops when Gnus exits. + + * nnfolder.el (nnfolder-save-all-buffers): Refactor out into its own + function. + (nnfolder-request-expire-articles): Save all the buffers after doing + expiry. + + * nnmail.el (nnmail-expiry-target-group): Revert the "all articles are + the last article", since that led to serious performance regressions + when expiring nnml groups. + +2010-12-16 Andrew Cohen <[email protected]> + + * nnir.el: Improve customizations. + +2010-12-16 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-subscribe-newsgroup): Notify the backend. + + * gnus-group.el (gnus-group-kill-group): Notify the backend that the + group has been killed. + (gnus-group-yank-group): Ditto. + + * gnus-srvr.el (gnus-browse-unsubscribe-group): Ditto. + + * nnimap.el (nnimap-request-update-group-status): New function. + + * gnus-int.el (gnus-request-update-group-status): New interface + function. + + * gnus-sum.el (gnus-summary-push-marks-to-backend): Fix the logic for + copying read-ness to the backends. + + * nnimap.el (nnimap-quirk): New function. + (nnimap-retrieve-group-data-early): Use it. + (nnimap-quirks): New alist. + +2010-12-16 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert): Set shr-start after deleting trailing space; + don't delete it within indentation. + +2010-12-16 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-wait-for-response): Always look (at least) at the + previous line. + +2010-12-15 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-retrieve-group-data-early): Fix the syntax of the + QRESYNC command by deleting a superfluous space which broke Cyrus + servers. This change will break other servers that are buggy the other + way around. + +2010-12-14 Teodor Zlatanov <[email protected]> + + * spam.el: Reindent and fix long lines. + (spam-copy-or-move-routine): Exclude invalid move destinations. + +2010-12-14 Andrew Cohen <[email protected]> + + * nnir.el (nnir-mode): Don't install registry hooks if user hasn't + installed the registry. + +2010-12-13 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-gmane): Better check for gmane groups: error out if + groupname doesn't contain "gmane". + +2010-12-13 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-matches-options-n): Fix typo in last change. + (gnus-1): Don't create the nndrafts group twice. + (gnus-setup-news): There's no need to read the active file here, since + that's done again later on a per-backend basis. + (gnus-start-draft-setup): Make sure that the new group is started out + empty. + + * gnus-agent.el (gnus-agentize): Don't create the queue group + automatically on startup. It'll be created later, if needed. + + * gnus-start.el (gnus-auto-subscribed-groups): Add nnimap to the list + of automatically subscribed groups. + (gnus-auto-subscribed-categories): New variable. + (gnus-matches-options-n): Use it. + (gnus-default-subscribed-newsgroups): Remove unused variable. + (gnus-start-draft-setup): Message a bit less. + +2010-12-13 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-imap): Return article list in order of increasing + UID. + +2010-12-13 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-enter-digest-group): Mention + gnus-auto-select-on-ephemeral-exit. + + * proto-stream.el (proto-stream-open-network-only): Fix the calling + convention of the network-only option. + +2010-12-10 Lars Magne Ingebrigtsen <[email protected]> + + * proto-stream.el (proto-stream-open-network-only): New function to + have a way to specify non-STARTTLS upgrade connections. + +2010-12-10 Julien Danjou <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-transform-address): Fix error when + email address is nil. + + * message.el (message-bogus-recipient-p): Set address to "" if nil. + +2010-12-10 Andrew Cohen <[email protected]> + + * nnir.el (nnir-request-expire-articles): Ignore expiry except for + deletion. + (nnir-run-imap): Only need to parse list once. + +2010-12-09 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-script): Ignore <script>. + (shr-tag-label): Add <label> support. + +2010-12-09 Katsumi Yamaoka <[email protected]> + + * mm-util.el (mm-ucs-to-char): Use eval-and-compile. + + * shr.el (shr-image-displayer): Work for images lined side by side. + +2010-12-08 Robert Pluim <[email protected]> + + * gnus-demon.el (gnus-demon-init): Call run-with-timer with an integer + parameter, since XEmacs doesn't accept t as a parameter. + +2010-12-08 Andrew Cohen <[email protected]> + + * nnir.el (nnir-retrieve-headers): Use rassq when comparing article + ids. + (nnir-run-gmane): Simplify groupspec formatting. + (nnir-request-expire-articles): New function. + +2010-12-07 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-parse-flags): Tweak VANISHED regexp to avoid regexp + overflow, possibly. + + * shr.el (shr-tag-table-1): Use bg/gfcolor specs on tables. + (shr-render-td): Handle td style="" better. + (shr-tag-table): Use the color from the style sheet. + (shr-render-td): Make sure we copy over all the overlays, too. + +2010-12-07 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-gmane): Restore sub-optimal test for gmane server. + (nnir-request-article): Improve article retrieval. + +2010-12-07 Katsumi Yamaoka <[email protected]> + + * mm-util.el (mm-extra-numeric-entities): New variable. + + * mm-url.el (mm-url-decode-entities): + * mm-decode.el (mm-shr): Use it to decode extra numeric entities. + +2010-12-07 Stefan Monnier <[email protected]> + + * message.el: Use completion-at-point. + (message-completion-function): New fun, extracted from message-tab. + (message-mode): Use it for completion-at-point-functions. + (message-tab): Use it and completion-at-point. + +2010-12-07 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-find-fill-point): Don't break a line after a kinsoku-bol + character if a non-breakable character follows. + +2010-12-06 Lars Magne Ingebrigtsen <[email protected]> + + * proto-stream.el (proto-stream-open-tls): Return nil if we don't get + any stream. + + * shr.el (shr-tag-font): Colorize the region. + (shr-tag-body): Ditto. + (shr-tag-font): Actually let the styles be inherited instead of + overwriting them. + (shr-tag-font): Get the background color right. + (shr-tag-style): Ignore all <style> tags for the moment. + + * gnus-int.el (gnus-request-thread): Rework to take a header instead of + a Message-ID to avoid having nnimap depend on gnus-sum. + + * shr.el (shr-descend): Only colorize something if we have a node that + sets colors. + +2010-12-06 Julien Danjou <[email protected]> + + * shr.el (shr-render-td): Render td content with shr-descend, so style + will be applied to <td> too. + (shr-colorize-region): Colorize region even if we only have a background. + (shr-tag-body): Fix color and background color inheritance. + Do not recolorize after shr-generic. + (shr-tag-font): Let shr-generic colorize via inheritance. + +2010-12-06 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-find-fill-point): Don't regard apostrophe as kinsoku-bol. + +2010-12-06 Andrew Cohen <[email protected]> + + * nnir.el (nnir-request-move-article): Remove obsolete code. + +2010-12-05 Katsumi Yamaoka <[email protected]> + + * gnus-util.el (gnus-macroexpand-all): Use eval-and-compile. + +2010-12-05 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-respool-article): The completion function + expects a list instead of an alist. + + * nntp.el (nntp-snarf-error-message): nnheader-report takes a format + string as the parameter. + + * gnus.el (gnus-valid-select-methods): Allow nnimap to respool. + + * shr.el (shr-stylesheet): New dynamic variable for cascading the + styles. + (shr-colorize-region): New function. + (shr-insert-background-overlay): Remove. + (shr-render-td): Background setting should be taken care of on a higher + level. + (shr-tag-body): Use post-hoc colorizations. + (shr-tag-body): Set up a style sheet based on bgcolor/fgcolor. + (shr-put-color-1): Don't overwrite old colors. + (shr-colorize-region): When the background color isn't explicit, use + a fixed background. + + * gnus-util.el (gnus-output-to-mail): Require nnmail before using + nnmail variables. + +2010-12-05 Bjørn Mork <[email protected]> + + * nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles + unless necessary. + +2010-12-05 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-gmane): Use more careful test for gmane nntp + server. + +2010-12-04 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-put-image): Use widget instead of local maps + so that TAB works. + + * gnus-sum.el (gnus-summary-show-article): Reverse the meanings of `C-u + C-u g' and `C-u g' so that `C-u g' does what it traditionally did. + + * shr.el (shr-urlify): Show the URL before the title to avoid + misleading URLs. + +2010-12-04 Adam Sjøgren <[email protected]> + + * shr.el (shr-urlify): Display the title in <a> tags. + +2010-12-04 Andrew Cohen <[email protected]> + + * nnir.el (nnir-categorize): Replace mapcar with mapc. + +2010-12-03 Andrew Cohen <[email protected]> + + * nnir.el: Rearrange code to allow macros to be autoloaded by + gnus-sum.el. + (nnir-retrieve-headers-override-function): Make this variable + customizable. + (nnir-retrieve-headers): Remove obsolete subject-mangling code. + + * gnus-sum.el (nnir-article-group,nnir-article-rsv): Autoload macros + from nnir.el. + +2010-12-03 Julien Danjou <[email protected]> + + * gnus-demon.el (gnus-demon-init): Fix time computing when time is nil. + +2010-12-03 Katsumi Yamaoka <[email protected]> + + * gnus-util.el (gnus-macroexpand-all): Don't modify argument; + allow optional argument `environment'. + +2010-12-03 Glenn Morris <[email protected]> + + * mm-extern.el (message-goto-body): Update declaration. + +2010-12-03 Katsumi Yamaoka <[email protected]> + + * gnus-util.el (gnus-macroexpand-all): New function. + + * gnus-sum.el (gnus-summary-line-format-alist): Use gnus-macroexpand-all + instead of macroexpand-all that is unavailable in XEmacs. + +2010-12-02 Andrew Cohen <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> + + * rtree.el: New file. + +2010-12-01 Julien Danjou <[email protected]> + + * 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 <[email protected]> + + * nnmaildir.el (nnmaildir-request-set-mark): Add article to add-mark + funcall. + +2010-12-01 Katsumi Yamaoka <[email protected]> + + * 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 <[email protected]>. + (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 <[email protected]> + + * proto-stream.el (open-protocol-stream): All starttls connections are + handled by the network handler. + +2010-11-30 Julien Danjou <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> + + * shr.el (shr-find-fill-point): Don't break before apostrophes. + +2010-11-29 Binjo <[email protected]> (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 <[email protected]> + + * gnus-sum.el (gnus-summary-delete-article): If delete fails don't + change the registry. + +2010-11-29 Katsumi Yamaoka <[email protected]> + + * 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 <[email protected]> + + * nnir.el (nnir-ignored-newsgroups): New variable. + (nnir-get-active): Use it. + +2010-11-28 Lars Magne Ingebrigtsen <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> + + * 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 <[email protected]> (tiny change) * pop3.el (pop3-open-server): Read server greeting before starting TLS negotiation. -2010-10-12 Juanma Barranquero <[email protected]> +2010-11-26 Julien Danjou <[email protected]> + + * color.el: Rename various rgb functions to srgb. + +2010-11-26 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-get-groups): Allow non-quoted strings as mailbox + names. + +2010-11-26 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert): Revert last change. + (shr-find-fill-point): Never leave point being at bol; + relax the kinsoku limitation when rendering tables. + +2010-11-26 Lars Magne Ingebrigtsen <[email protected]> + + * nnmail.el (nnmail-expiry-target-group): Protect against degenerate + results from -accept-article. + + * shr-color.el: Require cl when compiling. + + * nnheader.el (nnheader-update-marks-actions): Fix typo in last + checkin. + + * gnus-art.el (gnus-url-mailto): Unfold URLs before using them. + + * nnimap.el (nnimap-request-set-mark): Add is "+", not "-". + + * gnus-sum.el (gnus-summary-push-marks-to-backend): Use 'set instead of + 'add and 'delete to set backend marks. + + * nnmaildir.el (nnmaildir-request-set-mark): Be explicit about 'set. + + * nnheader.el (nnheader-update-marks-actions): Refactor out. + + * nntp.el (nntp-request-set-mark): Use it. + + * nnfolder.el (nnfolder-request-set-mark): Ditto. + + * nnml.el (nnml-request-set-mark): Ditto. + + * nnimap.el (nnimap-last-response-string): Remove the unfolding -- it + introduces regressions in article selection. + (nnimap-find-uid-response): New function. + (nnimap-request-accept-article): Use the UID returned, if any. + (nnimap-request-move-article): Use the UID returned, if any. + (nnimap-get-groups): Reimplement to work with folded lines. + (nnimap-find-uid-response): The UID is the last element in the list. + (nnimap-request-set-mark): Extend syntax with 'set. + + * nnml.el (nnml-request-set-mark): Ditto. + + * nnfolder.el (nnfolder-request-set-mark): Ditto. + + * nntp.el (nntp-request-set-mark): Ditto. + +2010-11-25 Katsumi Yamaoka <[email protected]> + + * message.el (message-called-interactively-p): A temporary macro. + (message-goto-body): Use it temporarily. + +2010-11-25 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-unfold-quoted-lines): Refactor out. + (nnimap-last-response-string): Unfold quoted lines, if they exist. + (nnimap-last-response-string): Fix last unfolding fix. + +2010-11-25 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert): Fix the way to fold lines. + +2010-11-25 Julien Danjou <[email protected]> + + * shr-color.el (shr-color->hexadecimal): Use color-rgb->hex + + * color.el: Rename from color-lab.el + (color-rgb->hex): Add. + (color-complement): Add. + (color-complement-hex): Add. + + * gnus-sum.el (gnus-summary-widget-forward): Add, and bind to [tab]. + +2010-11-25 Lars Magne Ingebrigtsen <[email protected]> + + * shr-color.el (shr-color-visible): Don't bug out if the colour names + don't exist. + +2010-11-25 Katsumi Yamaoka <[email protected]> + + * mml.el (mml-preview): Make sure to bind gnus-displaying-mime to nil, + assuming that article displaying or another mml-preview may be + interrupted for an error or for the like. + + * shr.el (shr-get-background): Fix argument name. + +2010-11-24 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-cache.el (gnus-summary-insert-cached-articles): Use it. + + * gnus-sum.el (gnus-summary-include-articles): New function. + + * message.el (message-goto-body): called-interactively-p needs a + parameter, so use `any'. + + * nnimap.el (nnimap-request-move-article): It's no longer necessary to + clear marks before moving, since they're synced from the Gnus side + first. + + * gnus-sum.el (gnus-summary-push-marks-to-backend): New function. + (gnus-summary-move-article): Copy over all marks before moving, so that + IMAP doesn't think a new article has arrived. + +2010-11-24 Julien Danjou <[email protected]> + + * shr.el (shr-insert-background-overlay): Fix typo. + (shr-render-td): Copy the background before rendering. + + * shr-color.el (shr-color-visible): Fix docstring. + + * shr.el (shr-tag-table): Add bgcolor support. + (shr-render-td): Add bgcolor support. + (shr-get-background): Add. + (shr-insert-foreground-overlay): Use shr-get-background. + + * message.el (message-goto-body): Use called-interactively-p. + (message-in-body-p): message-goto-body returns point. + +2010-11-24 Lars Magne Ingebrigtsen <[email protected]> + + * mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes + Fixes something or other in Emacs 23, and is backwards compatible. + + * message.el (message-goto-body): Remove the <#secure special-casing, + which is too special. + + * shr.el (shr-parse-style): Drop !important from styles. + +2010-11-24 Daniel Schoepe <[email protected]> (tiny change) + + * gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes + this function to return incorrect results when calling it with an + explicit article argument different from + (gnus-summary-article-number). + +2010-11-24 Julien Danjou <[email protected]> + + * shr.el (shr-insert-color-overlay): Replace deprecated syntax. + (shr-tag-body): Add background support. + (shr-descend): Add background support. + (shr-tag-title): Add. + + * shr-color.el (shr-color-visible): Really return original background + if fixed. + +2010-11-24 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-color-check): Protect against non-existant colour names. + +2010-11-24 Julien Danjou <[email protected]> + + * color-lab.el: Require 'cl when compiling. + + * shr.el (shr-insert-color-overlay): Remove specific rgb() check. + + * shr-color.el (shr-color->hexadecimal): Only return the hexadecimal + matched part. + + * color-lab.el: Fix all expt calls to use float type. + +2010-11-24 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert-color-overlay): Pass rgb(rrr, ggg, bbb) type color + expression to shr-color-check as is. + + * shr-color.el (shr-color->hexadecimal): Ignore case of color names. + + * color-lab.el: Add coding cookie. + (float-pi): Use eval-and-compile. + +2010-11-23 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-insert-color-overlay): Split stuff like + "#444444 !important" to find the real colour. + (shr-tag-font): Resurrect shr-tag-font again, since it's needed to + parse <font color="red"> entries. + +2010-11-23 Andrew Cohen <[email protected]> + + * nnheader.el (nnheader-parse-head): Bug fix. Properly position + point when parsing headers. + + * nnspool.el (nnspool-insert-nov-head): Bug fix. Make sure point + is positioned properly when parsing headers. + +2010-11-23 Julien Danjou <[email protected]> + + * color-lab.el (boundp): Bind float-pi for Emacs < 23.3. + + * shr-color.el (shr-color->hexadecimal): Add support for color names. + + * shr.el (shr-parse-style): Replace \n with space in style parsing. + + * shr-color.el (shr-color-hsl-to-rgb-fractions): Use + shr-color-hue-to-rgb. + (shr-color->hexadecimal): Call shr-color-hsl-to-rgb-fractions. + +2010-11-23 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-color->hexadecimal): Autoload. + (shr-descend): Add color to all tags. + +2010-11-22 Julien Danjou <[email protected]> + + * shr.el (shr-tag-color-check): Convert colors to hexadecimal with + shr-color->hexadecimal. + + * shr-color.el (shr-color->hexadecimal): Add converting functions for + RGB() or HSL() color representation. + + * shr.el (shr-tag-font): Add. + (shr-tag-color-check): New function to get better colors. + (shr-tag-insert-color-overlay): Factorize code between tag-font and + tag-span. + + * shr-color.el: New file. + + * color-lab.el: New file. + + * gnus-art.el (gnus-url-mailto): Do not downcase args. + +2010-11-21 Andrew Cohen <[email protected]> + + * nnir.el: Fix typo in comments. + (nnir-run-imap): Simplify code. No need to reverse artlist. + (nnir-run-gmane): Use nnir-tmp-buffer for web results. + +2010-11-21 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-srvr.el (gnus-server-show-server): New command and keystroke. + + * nnimap.el (nnimap-get-capabilities): Refactor out. + (nnimap-open-connection): Re-request capabilities after STARTTLS. + +2010-11-21 Ralf Angeli <[email protected]> + + * mm-uu.el (mm-uu-type-alist): Prevent spurious empty line from + appearing when `mm-uu-hide-markers' is nil. + +2010-11-21 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-unselect-group): Make into its own function. + (nnimap-request-rename-group): Unselect group before renaming. + This had gotten lost somewhere. + (nnimap-request-accept-article): Keep track of examined groups, and + unselect the group before APPENDing to read-only groups. + (nnimap-request-move-article): Clear flags before moving so that they + can be re-set later. + +2010-11-20 Katsumi Yamaoka <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-transform-address): Decode name again. + (gnus-gravatar-insert): Put avatar always in the beginning of the field. + +2010-11-19 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-mime-display-single) + * gnus-html.el (gnus-html-wash-images, gnus-html-prefetch-images) + * mm-decode.el (mm-shr): Assume that gnus-inhibit-images may be a group + parameter. + +2010-11-18 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-table-horizontal-line): Rename from shr-table-line. + (shr-table-vertical-line): New variable. + (shr-insert-table): Use it. + +2010-11-18 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-html-wash-images): Don't display images if + gnus-inhibit-images is non-nil; register displayer for cid images. + (gnus-html-display-image): Work for cid image. + (gnus-html-insert-image): Allow arguments. + (gnus-html-put-image): Inhibit read-only. + (gnus-html-prefetch-images): Don't prefetch images if + gnus-inhibit-images is non-nil. + +2010-11-17 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-put-image): Break lines when inserting big pictures. + +2010-11-17 Daniel Dehennin <[email protected]> + + * mml2015.el (mml2015-epg-encrypt): Fix two cons with missing + sender, thanks Katsumi Yamaoka. + +2010-11-17 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-imap): Reverse the article list for each group + rather than the whole list. + +2010-11-17 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-image-displayer): Protect function against non-existent + image source. + + * gnus-art.el (gnus-inhibit-images): New user option. + (gnus-mime-display-single): Don't display image if it is non-nil. + + * mm-decode.el (mm-shr): Bind shr-inhibit-images to the value of + gnus-inhibit-images. + + * shr.el (shr-image-displayer): New function. + (shr-tag-img): Use it. + +2010-11-16 Daniel Dehennin <[email protected]> + + * mml2015.el (mml2015-epg-sign): Use From header. + +2010-11-15 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-wash-images): Register a displayer. + + * gnus-util.el (gnus-find-text-property-region): Return markers. + + * shr.el (shr-tag-img): Put a displayer in the text property. + + * gnus-util.el (gnus-find-text-property-region): New utility function. + + * gnus-html.el (gnus-html-display-image): Make the alt optional. + (gnus-html-show-images): Remove. + + * gnus-art.el (gnus-article-show-images): New, more general function. + + * gnus-html.el: Use image-url instead of gnus-image-url to unify the + image url text properties. + + * shr.el: Ditto. + + * gnus-agent.el (gnus-agentize): Only do the auto-agentizing if + gnus-agent-auto-agentize-methods is set. Which it isn't. + +2010-11-15 Katsumi Yamaoka <[email protected]> + + * gnus-sum.el (gnus-summary-move-article): Fix `while' loop to make it + work for two or more articles. + +2010-11-12 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (article-treat-non-ascii): Keep text properties not to + divide an image that's in an html article to two or more when washing + non-ASCII characters in alt text of it. + +2010-11-11 Katsumi Yamaoka <[email protected]> + + * mm-decode.el (mm-dissect-buffer): Pass sender's mail address to + smime-decrypt-region using function argument. + (mm-possibly-verify-or-decrypt, mm-dissect-multipart): Relay it. + + * mm-view.el (mm-view-pkcs7, mm-view-pkcs7-decrypt): Relay it. + + * smime.el (smime-decrypt-region): Catch it. + +2010-11-11 Stefan Monnier <[email protected]> + + * smime.el (smime-mode-map): Move initialization into declaration. + (gnus-run-mode-hooks): Don't autoload. + (smime-mode): Use define-derived-mode. + +2010-11-11 Glenn Morris <[email protected]> + + * smime.el (from): Restrict declaration to XEmacs. + + * nnir.el (gnus-group-topic-name): Autoload. + +2010-11-11 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert): Don't break long line if it is because of + kinsoku-bol characters in the line end. + +2010-11-11 Andrew Cohen <[email protected]> + + * nnir.el (nnir-request-move-article): Fix to provide original group + and subject. + (nnir-warp-to-article): Don't fail on articles whose headers haven't + been retrieved. + + * gnus-sum.el (gnus-summary-move-article): Use original group and + subject for virtual articles such as those in an nnir summary buffer. + +2010-11-11 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (article-treat-non-ascii): Make it work for XEmacs (at + least 21.5). + + * smime.el (from): Declare it again for XEmacs. + +2010-11-10 Lars Magne Ingebrigtsen <[email protected]> + + * message.el (message-resend): Don't disable encoding unless it's + already encoded. + + * nnimap.el (nnimap-update-info): Fix problem with `g' chopping of + low-numbered articles. + +2010-11-10 Katsumi Yamaoka <[email protected]> + + * rfc2047.el (rfc2047-syntax-table): Simplify. + + * gnus-art.el (article-treat-non-ascii): Use put-char-table instead of + set-char-table-range for XEmacs. + +2010-11-10 Glenn Morris <[email protected]> + + * smime.el (from): Remove unused declaration. + + * gnus-util.el (with-no-warnings): Remove compat stub, now unused. + (gnus-float-time): On Emacs, always an alias. + + * ecomplete.el (with-no-warnings): Remove compat stub, now unused. + (ecomplete-add-item): Use float-time on Emacs, else gnus-float-time. + +2010-11-10 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (org-entities): Declare it to silence the byte compiler. + +2010-11-09 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (browse-url-mailto): Autoload. + + * gnus-art.el (article-treat-non-ascii): New command and keystroke. + + * message.el (message-subject-trailing-was-ask-regexp): A ] in a [] + regexp doesn't need quoting. + +2010-11-09 Sven Joachim <[email protected]> + + * message.el (message-subject-trailing-was-ask-regexp) + (message-subject-trailing-was-regexp): Match was: in addition to was. + +2010-11-09 Glenn Morris <[email protected]> + + * nnbabyl.el (nnbabyl-request-move-article, nnbabyl-delete-mail) + (nnbabyl-check-mbox): Use point-at-bol. + +2010-11-08 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-browse-url): Call browse-url-mailto for mailto: links. + + * message.el (message-mailto): New function. + (message-mailto): Should accept other parameters. + (message-mailto): Remove since it duplicates browse-url-mailto + functionality. + +2010-11-07 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-get-unread-articles): Ignore totally non-existent + methods. + (gnus-read-active-file): Ditto. + + * gnus-group.el (gnus-group-read-ephemeral-group): Remove superfluous + ": " from the prompt. + (gnus-group-make-group): Ditto. + +2010-11-07 Glenn Morris <[email protected]> + + * gnus-bookmark.el (gnus-bookmark-bmenu-show-infos) + (gnus-bookmark-kill-line): Use point-at-eol. + +2010-11-07 Katsumi Yamaoka <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-transform-address): No need to skip + asterisks in From header. + +2010-11-06 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-ems.el (gnus-put-image): Use a blank text as the insertion + string to avoid making the From headers syntactically invalid. + + * message.el (message-send-mail): Don't insert courtesy messages if the + message already has List-Post and List-ID messages. + +2010-11-06 Glenn Morris <[email protected]> + + * gnus-art.el (gnus-treat-article): Give dynamic local variables + `condition', `type', `length' a prefix. + (gnus-treat-predicate): Update for above name changes. + +2010-11-06 Andrew Cohen <[email protected]> + + * nnir.el (gnus-summary-nnir-goto-thread): Remove function and + binding. Handled by `gnus-summary-refer-thread' instead. + (nnir-warp-to-article): New backend function. + + * nnimap.el (nnimap-request-thread): Force dependency updating. + + * gnus-sum.el (gnus-fetch-headers): Allow more arguments. + (gnus-summary-refer-thread): Rework to improve thread-referral. + + * gnus-int.el (gnus-warp-to-article): New function. + + * gnus-sum.el (gnus-summary-article-map): Bind it. + +2010-11-04 Andrew Cohen <[email protected]> + + * nnir.el (gnus-summary-nnir-goto-thread): Limit work done by + gnus-summary-refer-thread. + + * gnus-sum.el (gnus-build-all-threads): Force updating of dependency + headers. + (gnus-summary-limit-include-thread): Prevent articles in thread from + being cut in gnus-cut-threads. + (gnus-summary-refer-thread): Limit retrieved headers to those in + thread. + +2010-11-04 Lars Magne Ingebrigtsen <[email protected]> + + * message.el (message-send-mail): Use the value of + message-courtesy-message from the message buffer. + + * gnus-html.el (gnus-html-browse-url): Implement mailto: URLs. + + * shr.el (shr-browse-url): Implement mailto: URLs. + + * gnus-sum.el (gnus-summary-show-article): Take `t' as the arg to mean + "raw". + + * nnimap.el (nnimap-find-article-by-message-id): Don't EXAMINE a group + if it's already selected. + + * mm-decode.el (mm-save-part): Put the entire path in the `M-n' slot. + +2010-11-04 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-tag-img): Use string-width and truncate-string-to-width + to measure the length and truncate alt text. + +2010-11-03 Glenn Morris <[email protected]> + + * nndiary.el (nndiary-generate-nov-databases-1) + (nndiary-generate-active-info): Rename dynamic variable `files' to + something less generic. + +2010-11-03 Andrew Cohen <[email protected]> + + * nnir.el (nnir-request-move-article): Call the underlying backend to + move articles from nnir. + +2010-11-02 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-cite.el (gnus-article-natural-long-line-p): Remove. + +2010-11-02 Julien Danjou <[email protected]> + + * nnir.el: Remove wais support. + +2010-11-02 Glenn Morris <[email protected]> + + * gnus-html.el: Reorder requirements to quieten compiler. + +2010-11-02 Katsumi Yamaoka <[email protected]> + + * gnus-cite.el (gnus-article-fill-cited-article): Make fill work + properly for XEmacs as well. + (gnus-article-fill-cited-article, gnus-article-foldable-buffer) + (gnus-article-natural-long-line-p): Use window-width rather than + frame-width. + +2010-11-01 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-gmane): Inhibit demon. Return nil if no messages. + (nnir-read-parms): Don't modify query. + (nnir-run-query): Add ability to search topic on current line. + (nnir-get-active): Clean up. + +2010-11-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-cite.el (gnus-article-foldable-buffer): Protect against + degenerate articles. + + * gnus-sum.el (gnus-print-buffer): Rewrite to use with-temp-buffer. + (gnus-print-buffer): Just print the buffer as is, without any copying + to a buffer and then re-highlighting. + + * nnimap.el (nnimap-request-group): Store the new updated info. + (nnimap-request-group): Select the group when we don't know whether it + exists or not. + + * gnus-start.el (gnus-ask-server-for-new-groups): Return the new + groups. + + * gnus-group.el (gnus-group-find-new-groups): Display all the new + groups. + + * gnus-start.el (gnus-find-new-newsgroups): Return the list of new + groups. + + * gnus-cite.el (gnus-article-fill-cited-article): Minimize the + long-lines case by only filling the long lines. + + * nnimap.el (nnimap-parse-line): Don't bug out oddly formed replies + (bug #7311). + +2010-11-01 Katsumi Yamaoka <[email protected]> + + * shr.el: No need to declare `declare-function' since shr.el is for + only Emacsen that provide `libxml-parse-html-region'. + +2010-11-01 Glenn Morris <[email protected]> + + * mm-util.el (gnus-completing-read): Autoload. + (mm-read-coding-system): Simplify Emacs definition. + + * nnmail.el (gnus-activate-group): + * nnimap.el (gnutls-negotiate): + * nntp.el (netrc-parse): Fix declarations. + +2010-11-01 Katsumi Yamaoka <[email protected]> + + * gnus-util.el (gnus-string-match-p): New function, that is an alias to + string-match-p in Emacs >=23. + + * gnus-msg.el (gnus-configure-posting-styles) + * nnir.el (nnir-run-gmane): Use gnus-string-match-p. + +2010-11-01 Glenn Morris <[email protected]> + + * nnir.el (declare-function): Add compat stub. + (mm-url-insert, mm-url-encode-www-form-urlencoded): Declare. + (nnir-run-gmane): Require 'mm-url. + + * mm-util.el (mm-string-to-multibyte): Simplify. + + * shr.el (declare-function): Add compat stub. + (url-cache-create-filename): Declare. + (mm-disable-multibyte, widget-convert-button): Autoload. + + * smime.el (ldap-search): Declare. + (smime-cert-by-ldap-1): Require ldap on Emacs. + + * nnimap.el: Require nnmail, and gnus-sum when compiling. + (nnimap-keepalive): Use gnus-float-time. + + * mail-source.el (nnheader-message, gnus-float-time): Autoload. + (mail-source-delete-crash-box): Use gnus-float-time. + + * gnus-dired.el (gnus-completing-read): Autoload. + + * mm-view.el (gnus-rescale-image): Autoload. + + * mm-decode.el (gnus-completing-read, gnus-blocked-images): Autoload. + + * gnus.el (gnus-sloppily-equal-method-parameters): Move defn before use. + + * sieve-manage.el: Require 'cl when compiling. + + * gnus-util.el (iswitchb-read-buffer): Declare rather than autoload. + (gnus-iswitchb-completing-read): Require iswitchb. + (gnus-select-frame-set-input-focus): Silence compiler. + +2010-10-31 Lars Magne Ingebrigtsen <[email protected]> + + * message.el (message-subject-trailing-was-query): Change default to t, + since I think that's what most people want. + + * nnimap.el (nnimap-request-accept-article): Erase buffer before + appending for easier debugging. + (nnimap-wait-for-connection): Take a regexp. + (nnimap-request-accept-article): Wait for the continuation line before + sending anything unless we're streaming. + + * gnus-art.el (gnus-treat-article): Only inhibit body washing, and + leave the header washing to take place. + +2010-10-31 Daniel Dehennin <[email protected]> + + * gnus-msg.el (gnus-configure-posting-styles): Permit the use of + regular expression match and replace in posting styles. + +2010-10-31 Andrew Cohen <[email protected]> + + * nnir.el (gnus-group-make-nnir-group,nnir-run-query): Allow searching + an entire server. + (nnir-get-active): New function. + (nnir-run-imap): Use it. + (nnir-run-gmane): Who knew, gmane search returns an article score! + + * gnus-srvr.el (gnus-server-mode-map): Add binding "G" to search the + server on the current line with nnir. + +2010-10-31 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-cite.el (gnus-article-foldable-buffer): Refactor out. + (gnus-article-foldable-buffer): Don't fold regions that have a ragged + left edge. + (gnus-article-foldable-buffer): Skip past the prefix when determining + raggedness. + + * gnus-sum.el (gnus-summary-show-article): Add `C-u C-u g' for showing + the raw article, and change `C-u g' to show the article without doing + treatments. + + * gnus-art.el (gnus-mime-display-alternative): Actually pass the type + on to `gnus-treat-article'. + (gnus-inhibit-article-treatments): New variable. + + * gnus.el: Autoload gnus-article-fill-cited-long-lines. + + * gnus-art.el (gnus-treatment-function-alist): Have + gnus-treat-fill-long-lines point to gnus-article-fill-cited-long-lines. + (gnus-treat-fill-long-lines): Change default to fill all text/plain + sections. + + * gnus-cite.el (gnus-article-fill-cited-article): Remove unused `force' + parameter. + (gnus-article-fill-cited-long-lines): New function. + (gnus-article-fill-cited-article): Allow filling only long sections. + + * shr.el (shr-find-fill-point): Don't break lines between punctuation + and non-punctuation (like after the apostrophe in "'We"). + + * gnus-sum.el (gnus-summary-select-article): Make sure + gnus-original-article-buffer is alive. + + * nndoc.el (nndoc-dissect-buffer): Reverse the order of the articles to + reflect the order they're in in the digest. + + * gnus.el (gnus-group-startup-message): Move point to the start of the + buffer. + + * nnimap.el (nnimap-capability): New function. + (nnimap-open-connection): Only send AUTHENTICATE PLAIN if LOGINDISABLED + is set. + +2010-10-31 David Engster <[email protected]> + + * nnmairix.el (nnmairix-get-valid-servers): Return list of strings to + conform with changes to gnus-completing-read. + +2010-10-30 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-img): Output "*" instead of "[img]". + +2010-10-30 Andrew Cohen <[email protected]> + + * nnir.el: Move defvar, defcustom around to keep file organized + and keep byte-compiler quiet. + (nnir-read-parms): Accept search-engine as arg. + (nnir-run-query): Pass search-engine as arg. + (nnir-search-engine): Remove. + +2010-10-30 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-generic): The text nodes should be text, not :text. + + * nnir.el (nnir-search-engine): Ressurect variable, since it's used + later in the file. + +2010-10-30 Andrew Cohen <[email protected]> + + * nnir.el: General clean up. Allow searching with multiple engines. + Allow separate extra-parameters for each engine. + Batch queries when possible. + (nnir-imap-default-search-key,nnir-method-default-engines): + Add customize interface. + (nnir-run-gmane): New engine. + (nnir-engines): Use it. Qualify all prompts with engine name. + (nnir-search-engine): Remove global variable. + (nnir-run-hyrex): Restore for now. + (nnir-extra-parms,nnir-search-history): New variables. + (gnus-group-make-nnir-group): Use them. + (nnir-group-server): Remove in favor of gnus-group-server. + (nnir-request-group): Avoid searching twice. + (nnir-sort-groups-by-server): New function. + +2010-10-30 Julien Danjou <[email protected]> + + * gnus-group.el: Remove gnus-group-fetch-control. + + * gnus-start.el (gnus-find-new-newsgroups): + Remove gnus-check-first-time-used. + + * gnus.el: Remove gnus-backup-default-subscribed-newsgroups. + +2010-10-30 Knut Anders Hatlen <[email protected]> (tiny change) + + * nnimap.el (nnimap-update-info): Allow 'ticked and other flags to be + set on groups that don't have \* permanentflags. + +2010-10-30 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-span): Drop colorisation of regions since we don't + control the background color. + (shr-tag-img): Ignore very small web bug type images. + (shr-put-image): Add help-echo alt texts to the images. + (shr-tag-video): Show the video poster image. + +2010-10-29 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-table-depth): New variable. + (shr-tag-table-1): Only insert the images after the top-level table. + + * nnimap.el (nnimap-split-incoming-mail): Fix typo. + + * gnus-util.el (gnus-list-memq-of-list): New function. + + * nnimap.el (nnimap-split-incoming-mail): Note that the INBOX has been + selected. + (nnimap-unsplittable-articles): New slot. + (nnimap-new-articles): Use it. + +2010-10-29 Stephen Berman <[email protected]> (tiny change) + + * gnus-group.el (gnus-group-get-new-news-this-group): Don't have point + move to the previous line on `M-g'. + +2010-10-29 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-msg.el (gnus-inews-do-gcc): Don't have the backends do the slow + *-request-group, which seems unnecessary. + + * nnimap.el (nnimap-quote-specials): Function copied over from + imap.el. + (nnimap-open-connection): Use AUTHENTICATE PLAIN on servers that say + they support that. Suggested by Tom Regner. + +2010-10-29 Julien Danjou <[email protected]> + + * gnus-sum.el (gnus-summary-delete-marked-as-read): Remove obsolete + defalias. + (gnus-summary-delete-marked-with): Remove obsolete defalias. + + * gnus.el: Remove `gnus-nntp-service' variable. + (gnus-secondary-servers): Make obsolete. + (gnus-nntp-server): Make obsolete. + + * gnus-start.el (gnus-1): Remove x-splash calls. + + * gnus-ems.el (gnus-x-splash): Remove. + + * gnus.el (gnus-group-startup-message): Simplify/update code. + + * gnus-group.el (gnus-group-make-tool-bar): Check for display graphic + capability before doing anything. + (gnus-group-insert-group-line): Remove useless + gnus-group-remove-excess-properties. + +2010-10-29 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-article-goto-part): Work for article narrowed by ^L. + +2010-10-28 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-rescan-group): Try to restore the window + config after reselecting. + +2010-10-28 Julien Danjou <[email protected]> + + * shr.el (shr-put-image): Use point even if only inserting text. + (shr-put-image): Save excursion when inserting alt text on non-graphic + display, so the behaviour is the same when we are on a graphic display. + + * nnir.el (nnir-run-swish-e): Remove hyrex support. + +2010-10-28 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-article-jump-to-part): Error on no part; fix prompt. + (gnus-mime-copy-part): Check coding system, not charset. + (gnus-mime-view-part-externally): Never remove part. + (gnus-mime-view-part-internally): Don't remove part here. + (gnus-article-part-wrapper): Make sure MIME tag is visible. + (gnus-article-goto-part): Go to displayed or preferred subpart if it is + multipart/alternative. + + * mm-decode.el (mm-display-part): Take optional arg `force'. + +2010-10-26 Julien Danjou <[email protected]> + + * gnus-group.el (gnus-group-default-list-level): Add this function to + compute the default list level. + (gnus-group-default-list-level): Add possibility to use a function. + +2010-10-27 Katsumi Yamaoka <[email protected]> + + * mm-decode.el (mm-shr): Add undisplayer to MIME handle. + + * gnus-group.el (gnus-group-completing-read) + (gnus-read-ephemeral-bug-group): Replace replace-regexp-in-string with + gnus-replace-in-string. + +2010-10-26 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-tag-div): Add. + +2010-10-25 Julien Danjou <[email protected]> + + * gnus-util.el: Remove `gnus-with-local-quit'. + + * gnus-demon.el (gnus-demon-init): Use run-with-idle-timer function. + +2010-10-25 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-select-article): Fix type error in checking + the original article buffer. + +2010-10-24 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-request-head): New function. + (nnimap-request-move-article): Try to be slighly faster by not + requesting the entire message when moving. + (nnimap-transform-headers): Don't bug out on bodiless articles. + (nnimap-send-command): Have no outstanding messages if the IMAP server + doesn't support streaming. + (nnimap-transform-headers): Fold {quoted} strings more sloppily. + +2010-10-24 Julien Danjou <[email protected]> + + * message.el (message-default-headers): Fix type. + +2010-10-24 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-prefetch-images): Decode entities before + prefetching images. + + * gnus-sum.el (gnus-group-make-articles-read): Propagate marks to the + backend for unknown groups. This is mainly useful for nnimap groups. + + * gnus-agent.el (gnus-agent-fetch-group): Don't download stuff if the + group isn't covered by the agent. + +2010-10-22 Andrew Cohen <[email protected]> + + * nnir.el (nnir-method-default-engines): New variable. + (nnir-run-query): Use it. + (nnir-group-mode-hook): Remove key binding and move to gnus-group.el. + (gnus-summary-nnir-goto-thread): Change group if needed. + + * gnus-group.el (gnus-group-group-map): Add key binding for + gnus-group-make-nnir-group. + +2010-10-24 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-object): Add. + + * gnus-sum.el (gnus-summary-select-article): Make sure we have the + original article buffer live. + (gnus-summary-select-article-buffer): + Mention gnus-widen-article-buffer. + +2010-10-23 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-strong): Add. + +2010-10-22 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-group.el (gnus-group-completing-read): Remove all newlines from + group names. They mess up the group buffer badly. + + * shr.el (shr-tag-img): Don't bug out on images that don't have a SRC. + + * gnus-group.el (gnus-group-mark-group): Use gnus-group-position-point + instead of the summary one. + +2010-10-22 Katsumi Yamaoka <[email protected]> + + * mml.el (mml-preview): Work properly when editing article. + + * gnus-start.el (gnus-read-active-file-1): Don't add method to + gnus-have-read-active-file if it's already been in. + +2010-10-22 Tom Tromey <[email protected]> + + * gnus-group.el (gnus-group-unsubscribe-group): Fix args passed to + gnus-group-completing-read. + +2010-10-21 Lars Magne Ingebrigtsen <[email protected]> + + * message.el (message-mode-map): Don't bind M-; to comment region, to + allow the global comment-dwim to work. + +2010-10-21 Julien Danjou <[email protected]> + + * message.el (message-setup-1): Allow message-default-headers to be a + function. + +2010-10-21 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-tag-table): Simplify. + +2010-10-21 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-prefetch-images): Only prefetch http images + to avoid trying to snarf invalid stuff. + + * gnus-sum.el (gnus-summary-edit-article-done): Bind free variable. + + * gnus.el (gnus-message-archive-group): Quote value. + (gnus-message-archive-group): Mark as changed. + + * shr.el (shr-add-font): Don't put the font properties on the newline + or the indentation. + + * message.el (message-fix-before-sending): Change options when sending + non-printable characters. + + * gnus.el (gnus-message-archive-method): Change the default to + monthly outgoing groups. + + * gnus-sum.el (gnus-summary-edit-article-done): Try to replace articles + that have gotten new numbers. + + * nnimap.el (nnimap-request-replace-article): New function. + +2010-10-21 Katsumi Yamaoka <[email protected]> + + * nnrss.el (nnrss-wash-html-in-text-plain-parts): Remove. + (nnrss-request-article): Don't use special html washing code. + +2010-10-20 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-tag-table): Remove useless nconc. + +2010-10-20 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-art.el (article-wash-html): Simplify and remove the charset + stuff. Use the normal html rendering code instead of the special html + washing code. + + * mm-view.el (mm-text-html-renderer-alist): Add the `shr' and + `gnus-w3m' symbols. + (mm-text-html-washer-alist): Remove. + + * mm-decode.el (mm-inline-text-html-renderer): Remove. + (mm-inline-media-tests): Remove use. + (mm-text-html-renderer): Change default to the `shr' symbol. + + * mm-view.el (mm-inline-text-html): Remove use. + + * gnus-art.el (gnus-blocked-images): New function. Allow the + `gnus-blocked-images' to be a function. + (gnus-article-wash-function): Remove. + +2010-10-20 Julien Danjou <[email protected]> + + * spam.el (spam-list-of-processors): Mark as obsolete. + + * nnimap.el (nnimap-request-article): Fix BODYSTRUCTURE retrieval. + (nnimap-insert-partial-structure): Fix boundary detection. + +2010-10-20 Andreas Seltenreich <[email protected]> + + * gnus-draft.el (gnus-draft-check-draft-articles): Don't unnecessarily + run file-truename on remote files. This can be expensive and even + prevent one from editing drafts if some unrelated buffer has a stale + connection. + +2010-10-20 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-find-fill-point): Shorten line if the preceding char is + kinsoku-eol regardless of shr-kinsoku-shorten. + (shr-tag-table-1): Rename from shr-tag-table; make it a subroutine. + (shr-tag-table): Support caption, thead, and tfoot. + +2010-10-19 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-find-fill-point): Don't leave blanks at the start of some + lines. + (shr-save-contents): New command and keystroke. + + * nndoc.el (nndoc-type-alist): Add git support. + (nndoc-git-type-p): New function. + (nndoc-transform-git-article): Ditto. + (nndoc-transform-git-headers): Ditto. + (nndoc-transform-git-headers): Generate Subject headers. + + * shr.el (shr-parse-style): New function. + (shr-tag-span): Ditto. + + * nnmairix.el (nnmairix-summary-mode-hook): Move nnmairix's `$' command + to `G G' to avoid collisions. + +2010-10-19 Katsumi Yamaoka <[email protected]> + + * shr.el: Load kinsoku if necessary. + (shr-kinsoku-shorten): New internal variable. + (shr-find-fill-point): Make kinsoku shorten text line if + shr-kinsoku-shorten is bound to non-nil. + (shr-tag-table): Bild shr-kinsoku-shorten to t; refer to + shr-indentation too when testing if table is wider than frame width. + (shr-insert-table): Use `string-width' instead of `length' to measure + text width. + (shr-insert-table-ruler): Make sure indentation is done at bol. + +2010-10-19 Stefan Monnier <[email protected]> + + * nnimap.el (nnimap-request-move-article, nnimap-parse-line) + (nnimap-process-expiry-targets): Use unibyte for buffers that hold + undecoded network data. + +2010-10-18 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-agent.el (gnus-agent-toggle-plugged): Use the right minor mode + name in the mode line spec so that the mode line menu works + (bug #2431). + + * message.el (message-get-reply-headers): If we're fed `to-address', + then always use that. + + * gnus-art.el (gnus-article-make-menu-bar): The article/group menus + aren't so wide as to need to switch off the edit menu. + + * gnus-delay.el (gnus-delay-article): Remove superfluous `group' + binding. Suggested by Leo <[email protected]> (bug #6613). + + * nnimap.el (nnimap-request-group): Don't SELECT the group twice on + `M-g'. + (nnimap-update-info): Update flags/read marks even if \* isn't part of + the permanent marks. + +2010-10-18 Andrew Cohen <[email protected]> + + * gnus-registry.el (gnus-registry-split-fancy-with-parent): + Splitting according to references/in-reply-to obeys the ignore-groups + variable, while splitting by sender and subject do not. + +2010-10-18 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-art.el (gnus-article-dumbquotes-map): Make into a char/string + alist, so that we can look for non-Unicode chars. + (article-translate-strings): Allow both character and string maps. + +2010-10-18 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert): Don't insert space behind a wide character + categorized as kinsoku-bol, or between characters both categorized as + nospace. + +2010-10-16 Andrew Cohen <[email protected]> + + * gnus-sum.el (gnus-summary-refer-thread): Bug fix. Add the thread + headers to gnus-newsgroup-headers. + +2010-10-16 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-img): Don't align images -- since we're not + rescaling, this often leads to ugly displays. + +2010-10-15 Andrew Cohen <[email protected]> + + * gnus-sum.el (gnus-summary-refer-thread): Unconditionally ignore + duplicates. + +2010-10-15 Kan-Ru Chen <[email protected]> (tiny change) + + * gnus-diary.el (gnus-diary-check-message): Fix gnus-completing-read + call. + +2010-10-15 Lars Magne Ingebrigtsen <[email protected]> + + * gnus.el: Autoload gnus-html-show-images. + + * nnimap.el: Use nnheader-message throughout. + + * shr.el (shr-tag-img): Ignore images with no data. + +2010-10-15 Julien Danjou <[email protected]> + + * mml.el (mml-generate-mime-1): Add `mml-enable-flowed' variable to add + a possibility to disable format=flow encoding when using hard newlines. + +2010-10-15 Katsumi Yamaoka <[email protected]> + + * shr.el (shr-insert): Remove space inserted before or after a + breakable character or at the beginning or the end of a line. + (shr-find-fill-point): Do kinsoku; find the second best point or give + it up if there's no breakable point. + +2010-10-14 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-open-connection): Message when opening connection + for debugging purposes. + + * gnus-art.el (gnus-article-setup-buffer): Set article mode truncation + on every setup buffer call to allow this to change from article to + article. + + * shr.el (shr-tag-table): Experimental feature: Truncate lines in + buffers where we have a wide table. + +2010-10-14 Andrew Cohen <[email protected]> + + * gnus-sum.el (gnus-summary-refer-thread): Implement a version that + uses *-request-thread. + +2010-10-14 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-open-connection): Remove %s from openssl + incantation, which is no longer valid. + +2010-10-14 Julien Danjou <[email protected]> + + * shr.el: Fix defcustom type (char -> character). + +2010-10-14 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-open-connection): tls-program should be a list of + programs. + +2010-10-14 Julien Danjou <[email protected]> + + * shr.el (shr-tag-a): Use url-link as widget type. + + * gnus-group.el (gnus-group-insert-group-line): Fix group argument to + `gnus-group-get-icon'. + +2010-10-13 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-close-server): Forget the nnimap data on close. + This should make server editing work better. + + * shr.el (shr-find-fill-point): Don't inloop on indented text. + + * nnimap.el (nnimap-open-connection): Fix open-tls-stream call. + (nnimap-parse-flags): Fix regexp. + + * shr.el (shr-find-fill-point): Use a filling algorithm that should + probably work for CJVK text, too. + + * nnimap.el (nnimap-extend-tls-programs): Remove. + (nnimap-open-connection): Bind STARTTLS to openssl explicitly. + +2010-10-13 Julien Danjou <[email protected]> + + * nnimap.el (nnimap-parse-flags): Be more strict when looking for FETCH + responses. + +2010-10-13 Lars Magne Ingebrigtsen <[email protected]> + + * mm-decode.el (mm-shr): Allow use from non-Gnus users. + + * gnus-spec.el (gnus-parse-simple-format): princ doesn't really insert + anything in Emacs. + + * shr.el (shr-current-column): Remove buggy and unnecessary function. + +2010-10-13 Julien Danjou <[email protected]> + + * shr.el (shr-width): Make shr-width a defcustom with default to + fill-column. + (shr-tag-img): Use shr-width rather than fill-column. + +2010-10-13 Katsumi Yamaoka <[email protected]> + + * gnus-dired.el (gnus-dired-attach): Silence XEmacs 21.5 when compiling. + + * gnus-gravatar.el (gnus-gravatar-transform-address): Adjust avatars' + position when (X-)Faces exist. + (gnus-treat-from-gravatar, gnus-treat-mail-gravatar): Force displaying + avatars when called interactively. + +2010-10-12 Katsumi Yamaoka <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-too-ugly): Don't test if + gnus-article-x-face-too-ugly is bound. + +2010-10-12 Lars Magne Ingebrigtsen <[email protected]> + + * rfc2231.el (rfc2231-parse-string): Ignore repeated parts. + + * nnimap.el (nnimap-request-rename-group): Unselect by selecting a + mailbox that doesn't exist. + +2010-10-12 Julien Danjou <[email protected]> + + * shr.el (shr-tag-img): Encode URL properly when retrieving. + (shr-get-image-data): Encode URL properly when fetching from cache. + (shr-tag-img): Use aligned-to spaces to align correctly images. + + * gnus-gravatar.el (gnus-gravatar-insert): Check if buffer is alive + before inserting the Gravatar. + + * shr.el (shr-tag-img): Add align attribute support for <img>. + +2010-10-12 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-gravatar.el (gnus-art): Require. + + * gnus-sum.el (gnus-summary-mark-as-unread-forward) + (gnus-summary-mark-as-unread-backward, gnus-summary-mark-as-unread): + Remove long obsoleted functions. + +2010-10-11 Katsumi Yamaoka <[email protected]> + + * nnimap.el (gnutls-negotiate): Silence the byte compiler. + + * gnus-art.el, gnus-cache.el, gnus-fun.el, gnus-group.el: + * gnus-picon.el, gnus-spec.el, gnus-sum.el, gnus-util.el, gnus.el: + * mail-source.el, message.el, mm-bodies.el, mm-decode.el, mm-extern.el: + * mm-util.el, mm-view.el, mml-smime.el, mml.el, mml1991.el, mml2015.el: + * nnfolder.el, nnheader.el, nnmail.el, nnmaildir.el, nnrss.el, nntp.el: + * rfc1843.el, sieve-manage.el, smime.el, spam.el: + Fix comment for declare-function. + +2010-10-11 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-request-rename-group): Select group read-only + before renaming it. + + * shr.el (shr-insert): Fix up the white space only regexp. + + * nnimap.el (nnimap-transform-split-mail): Not all articles have + bodies. Protect against this. Reported by Michael Welsh Duggan. + + * shr.el (shr-current-column): New function. + (shr-find-fill-point): New function. + +2010-10-11 Michael Welsh Duggan <[email protected]> (tiny change) + + * sieve-manage.el (sieve-manage-open): Allow port names as well as port + numbers. + +2010-10-11 Julien Danjou <[email protected]> + + * shr.el (shr-hr-line): Add. + (shr-tag-hr): Use shr-hr-line to specify which character to use to + display hr lines. + (shr-max-columns): Do not change state to nil if we just inserting + spaces. + +2010-10-11 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-topic.el (gnus-topic-read-group): If after the last group, + select the last group. + +2010-10-11 Teodor Zlatanov <[email protected]> + + * gnus-int.el (gnus-run-hook-with-args): Autoload from gnus-util.el. + +2010-10-10 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-update-qresync-info): \Flagged messages are read + for Gnus. + (nnimap-retrieve-group-data-early): utf7-encode the group parameters. + (nnimap-update-qresync-info): Mark \Seen articles as read. + + * gnus-sum.el (gnus-summary-set-local-parameters): Ignore the `active' + non-variable, too. + + * nnimap.el (nnimap-open-connection): Use gnutls STARTTLS, if + available. + (nnimap-update-info): Rely more on the current active than the param + active to avoid marking articles as read too much. + + * auth-source.el (auth-source-create): Use (user-login-name) for the + user name default. + + * nnimap.el (nnimap-update-info): If the server doesn't return any + useful info, just use the previous info. + (nnimap-update-info): Prefer old info over start-article. + (nnimap-update-qresync-info): Finish implementing QRESYNC. + +2010-10-10 Andrew Cohen <[email protected]> + + * nnir.el (autoload): Clean up autoloads. + (nnir-imap-default-search-key): Rename from nnir-imap-search-field. + Use key rather than value. + (nnir-imap-search-other): New variable. + (nnir-read-parm): Use it. + (nnir-imap-expr-to-imap): Use %S rather than imap-quote-specials. + (gnus-summary-nnir-goto-thread): Modify to work with imap. + +2010-10-10 Stefan Monnier <[email protected]> + + * nnimap.el (nnimap-wait-for-response): If the user hits `C-g', kill + the process, too. + +2010-10-09 Lars Magne Ingebrigtsen <[email protected]> + + * spam.el (gnus-summary-mode-map): Bind to "$". + Suggested by Russ Allbery. + + * shr.el: Rework the way things are indented by <li> slightly. + + * gnus.el (gnus-group-set-parameter): Fix typo. + + * nnimap.el: Start implementing QRESYNC support. + +2010-10-09 Julien Danjou <[email protected]> + + * nnir.el (nnir-engines): Fix too many arguments. + +2010-10-09 Lars Magne Ingebrigtsen <[email protected]> + + * nnmail.el (nnmail-expiry-target-group): Say that every expiry target + group is the "last", so that the backends like nnfolder actually save + their folders. + + * nnimap.el (nnimap-open-connection): If we have gnutls loaded, then + try to use that for the tls stream. + (nnimap-retrieve-group-data-early): Rework the marks code to heed + UIDVALIDITY and find out which groups are read-only and not. + (nnimap-get-flags): Use the same marks parsing code as the rest of + nnimap. + +2010-10-09 Julien Danjou <[email protected]> + + * nnir.el (nnir-read-parm): Fix call to gnus-completing-read. + + * gnus-gravatar.el (gnus-gravatar-transform-address): Error errors when + retrieving gravatars. + + * shr.el (shr-table-corner): Add. + (shr-table-line): Add. + (shr-insert-table-ruler): Use the above defcustoms to insert tables. + +2010-10-08 Julien Danjou <[email protected]> + + * mm-decode.el (mm-text-html-renderer): Add mm-shr in choice list. + +2010-10-08 Teodor Zlatanov <[email protected]> + + * gnus-util.el (gnus-alist-pull): Rename `gnus-pull'. + + * gnus-sum.el (gnus-mark-article-as-unread) + (gnus-summary-mark-article-as-unread, gnus-summary-remove-bookmark) + (gnus-summary-set-bookmark): Use it. + + * gnus-msg.el (gnus-setup-message): Use it. + + * gnus-demon.el (gnus-demon-remove-handler): Use it. + + * gnus.el (gnus-group-remove-parameter): Use it. + + * gnus-group.el (gnus-group-make-web-group): Use it. + + * gnus-demon.el (gnus-demon-remove-handler): Use it. + + * nnregistry.el: Update docs to mention manual. + + * gnus-registry.el: Update docs to mention nnregistry.el. + (gnus-registry-initialize): Don't install nnregistry refer method + automatically. + (gnus-registry-install-nnregistry): Remove it. + +2010-10-08 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-insert): Don't insert double spaces. + +2010-10-08 Katsumi Yamaoka <[email protected]> + + * gnus-gravatar.el (gnus-treat-from-gravatar) + (gnus-treat-mail-gravatar): Bind gnus-gravatar-too-ugly to nil when + called interactively. + + * gnus-art.el (gnus-mime-view-part-externally) + (gnus-mime-view-part-internally): Make predicate function passed to + gnus-mime-view-part-as-type assume argument is a mime type, not a list + of a mime type. + + * shr.el (shr-table-widths): Don't use cl function `reduce'. + +2010-10-07 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (require): Require cl when compiling. + (shr-tag-hr): New function. + + * nnimap.el (nnimap-update-info): Remove double setting of high. + (nnimap-update-info): Don't ignore groups that have no UIDNEXT. + This makes nnimap work properly on Courier again. + + * gnus.el (gnus-carpal): The carpal mode has been removed, but define + the variable for backwards compatability. + + * mm-decode.el (mm-save-part): If given a non-directory result, expand + the file name before using to avoid setting mm-default-directory to + nil. + + * gnus-start.el (gnus-get-unread-articles): Require gnus-agent before + bidning gnus-agent variables. + + * shr.el (shr-render-td): Use a cache for the table rendering function + to avoid getting an exponential rendering behaviour in nested tables. + (shr-insert): Rework the line-breaking algorithm. + (shr-insert): Don't leave trailing spaces. + (shr-insert-table): Also insert empty TDs. + (shr-tag-blockquote): Ensure paragraphs after </ul>. + +2010-10-07 Stefan Monnier <[email protected]> + + * gnus-sum.el (gnus-number): Rename from `number'. + (gnus-article-marked-p, gnus-summary-limit-to-display-predicate) + (gnus-summary-limit-children): Update uses correspondingly. + +2010-10-07 Katsumi Yamaoka <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-too-ugly): New user option. + (gnus-gravatar-transform-address): Don't show avatars of people of + which mail addresses match gnus-gravatar-too-ugly. + +2010-10-07 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-table-widths): Expand TD elements to fill available + space. + +2010-10-07 Julien Danjou <[email protected]> + + * nnimap.el (nnimap-request-rename-group): Add this method. + +2010-10-07 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-html-schedule-image-fetching): Remove function + name from XEmacs' function-arglist. + + * gnus-gravatar.el (gnus-gravatar-insert): Don't add properties to + gravatar under XEmacs. + +2010-10-07 Teodor Zlatanov <[email protected]> + + * auth-source.el: Update docs with TODO items. + + * gnus-sync.el: Update docs to explain state and plans. + + * gnus-int.el (gnus-after-set-mark-hook, gnus-before-update-mark-hook): + Hooks for mark updates. + (gnus-request-set-mark, gnus-request-update-mark): Use them. + + * gnus-util.el (gnus-run-hooks-with-args): Convenience function to run + hooks with arguments, which is needed for mark update hooks. + +2010-10-06 Julien Danjou <[email protected]> + + * gnus.el (gnus-expand-group-parameter): Only return and act on what + was matched. + + * sieve-manage.el: Update example in `Commentary'. + + * sieve.el (sieve-open-server): Use sieve-manage-authenticate. + + * sieve-manage.el (sieve-manage-open): Use sieve-manage-default-port, + not 2000. + (sieve-manage-authenticate): Re-add function. + +2010-10-06 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-insert): Get 'space transition right. + (shr-render-td): Only delete space at the end of the TD. + + * nnimap.el (nnimap-open-connection): Prepare to support + open-gnutls-stream. + + * shr.el: Rearrange function order to be more logical. + +2010-10-06 Julien Danjou <[email protected]> + + * nnrss.el (nnrss-check-group): Remove 404 URL in comment. + (nnrss-discover-feed): Remove 404 URL in docstring. + + * nnir.el: Fix Swish-E URL. + Fix Namazu URL. + + * message.el (message-change-subject): Remove 404 URL in a comment. + +2010-10-06 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-mime-view-part-as-type): Make it work when being + called interactively. + + * gnus-util.el (gnus-remove-if): Allow hash table. + (gnus-remove-if-not): New function. + + * gnus-art.el (gnus-mime-view-part-as-type) + * gnus-score.el (gnus-summary-score-effect) + * gnus-sum.el (gnus-read-move-group-name): + Replace remove-if-not with gnus-remove-if-not. + + * gnus-group.el (gnus-group-completing-read): + Regard collection as a hash table if it is not a list. + +2010-10-05 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-render-td): Allow blank/missing <TD>s. + + * shr.el: Document the table-rendering algorithm. + + * gnus-html.el (gnus-html-schedule-image-fetching): Protect against + invalid URLs. + + * shr.el (shr-tag-img): Shorten ALT texts and allow them to be + line-broken. + (shr-tag-img): Ignore image fetching errors. + (shr-overlays-in-region): Compute overlay positions correctly. + + * mm-decode.el (mm-shr): Require shr. + + * gnus-art.el (gnus-blocked-images): Move variable here. + + * shr.el (shr-insert-table): Bind free variable. + + * mm-decode.el (mm-shr): Bind shr-content-function. + + * shr.el (shr-content-function): New variable. + + * gnus-sum.el (gnus-article-sort-by-most-recent-date): New function, + added for symmetry. + + * nnir.el (nnir-retrieve-headers): Don't bug out on invalid data. + + * gnus-group.el (gnus-group-make-group): Doc fix. + + * nnimap.el (nnimap-request-newgroups): Return success. + + * shr.el (shr-find-elements): New function. + (shr-tag-table): Put all the images after the table. + (shr-tag-table): Really inhibit images inside the table. + (shr-collect-overlays): Copy over overlays from the TD elements to the + main document. + + * mm-decode.el (mm-shr): Bind shr-blocked-images to + gnus-blocked-images. + +2010-10-05 Julien Danjou <[email protected]> + + * sieve-manage.el (sieve-sasl-auth): Use auth-source to authenticate. + + * gnus-html.el (gnus-html-wash-images): Rescale image from cid too. + (gnus-html-maximum-image-size): Add this function. + (gnus-html-put-image): Use gnus-html-maximum-image-size. + + * sieve-manage.el (sieve-manage-capability): Do not bug out when the + server-value of the capability is nil. + +2010-10-05 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-em): Add <EM> tag. + +2010-10-05 Florian Ragwitz <[email protected]> (tiny change) + + * sieve-manage.el (sieve-manage-default-stream): Make default stream + customizable. + + * gnus-html.el (gnus-html-wash-tags): Decode URL entities to avoid + handing broken links to browse-url. + +2010-10-05 Julien Danjou <[email protected]> + + * gnus-util.el (gnus-emacs-completing-read) + (gnus-iswitchb-completing-read): Use autoload rather than require. + +2010-10-05 Katsumi Yamaoka <[email protected]> + + * gnus-util.el (gnus-completing-read-function): Exclude + gnus-icompleting-read and gnus-ido-completing-read from candidates for + XEmacs since iswitchb.el is very old and ido.el is unavailable in + XEmacs. + + * gnus-registry.el (gnus-registry-install-nnregistry): Rewrite so as + not to use `delete-dups' that is unavailable in XEmacs 21.4. + + * gnus-html.el: Don't require help-fns under XEmacs. + (gnus-html-schedule-image-fetching): Work for XEmacs. + + * mm-decode.el (mm-shr): Decode contents by charset. + +2010-10-04 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-open-connection): Give an error if nnimap-stream is + unknown. + + * shr.el (shr-tag-blockquote): Ensure paragraph after quote, too. + (shr-get-image-data): Ensure against the cache file missing. + + * nnimap.el (nnimap-finish-retrieve-group-infos): Message while waiting + for data. + + * spam-report.el (spam-report-url-ping-plain): Don't query about + killing the process. + + * shr.el (shr-render-td): Protect against too-wide text. + +2010-10-04 Julien Danjou <[email protected]> + + * mml-smime.el (mml-smime-openssl-encrypt-query): Fix choices. + (mml-smime-openssl-sign-query): Fix gnus-completing-read call. + + * gravatar.el (gravatar-retrieved): Kill buffer when gravatar has been + retrieved. + +2010-10-04 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (browse-url): Require. + (shr-ensure-paragraph): Don't insert a new newline after empty-ish + lines. + (shr-show-alt-text, shr-browse-image): New commands. + (shr-browse-url, shr-copy-url): New commands. + + * gnus-sum.el (gnus-widen-article-window): New variable. + (gnus-summary-select-article-buffer): Use it. + + * message.el (message-idna-to-ascii-rhs-1): Don't bug out on addresses + without @ signs. + +2010-10-04 Michael Welsh Duggan <[email protected]> (tiny change) + + * nnir.el (nnir-run-imap): Remove spurious space in search string. + +2010-10-04 Julien Danjou <[email protected]> + + * gnus-util.el (gnus-emacs-completing-read): Mapcar collection to list, + for XEmacs. + +2010-10-04 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-salt.el: Remove all gnus-carpal stuff -- it's not useful. + + * nnimap.el (nnimap-open-connection): Allow tls as a synonym for ssl. + (nnimap-close-server): Implement. + + * shr.el (shr-ensure-paragraph): Fix the non-empty line case. + (shr-insert): Tweak line breaking. + (shr-insert): Handle <pre> better. + (shr-tag-li): Get <li> indentation right. + (shr-tag-li): Get <li> indentation even righter. + (shr-tag-blockquote): Ensure paragraph start. + (shr-make-table): Tweak table generation. + (shr-make-table): Fix typo. + + * shr.el: Implement table rendering. + +2010-10-04 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-put-image): Fix resize image code. + +2010-10-04 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-insert): Use string anchors instead of line anchors. + +2010-10-03 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el: Add headings. + (shr-ensure-paragraph): Actually work. + (shr-tag-li): Make <ul> prettier. + (shr-insert): Get white space at the beginning/end of elements right. + (shr-tag-p): Collapse subsequent <p>s. + (shr-ensure-paragraph): Don't insert double line feeds after blank + lines. + (shr-insert): \t is also space. + (shr-tag-s): Fix "s" tag name function. + (shr-tag-s): Fix face prop name. + +2010-10-03 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-put-image): Use gnus-rescale-image. + + * mm-view.el (gnus-window-inside-pixel-edges): Add autoload for + gnus-window-inside-pixel-edges. + + * gnus-ems.el (gnus-window-inside-pixel-edges): Move from gnus-html to + gnus-ems. + + * mm-view.el (mm-inline-image-emacs): Support image resizing. + + * gnus-util.el (gnus-rescale-image): Add generic gnus-rescale-image + function. + + * mm-decode.el (mm-inline-large-images): Enhance defcustom and add + resize choice. + +2010-10-03 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-tag-p): Don't insert newlines on empty tags at the + beginning of the buffer. + + * gnus-sum.el (gnus-summary-select-article-buffer): Really select the + article buffer again. + + * shr.el (shr-tag-p): Don't insert newlines at the start of the buffer. + + * mm-decode.el (mm-shr): Narrow before inserting, so that shr can know + when it's at the start of the buffer. + + * shr.el (shr-tag-blockquote): Convert name. + (shr-rescale-image): Use the right image-size variant. + + * gnus-sum.el (gnus-summary-select-article-buffer): If the article + buffer isn't shown, then select the current article first instead of + bugging out. + (gnus-summary-select-article-buffer): Show both the article and summary + buffers again. + + * shr.el (shr-fontize-cont): Protect against regions with no text. + Rename tag functions to shr-tag-* for enhanced security. + (shr-tag-ul, shr-tag-ol, shr-tag-li, shr-tag-br): New functions. + +2010-10-03 Chong Yidong <[email protected]> + + * shr.el (shr-insert): + * pop3.el (pop3-movemail): + * gnus-html.el (gnus-html-wash-tags): Don't use plusp, as cl may not be + loaded. + +2010-10-03 Glenn Morris <[email protected]> + + * nnmairix.el (nnmairix-replace-illegal-chars): Drop Emacs 20 code. + + * smime.el (smime-cert-by-ldap-1): Drop Emacs 21 code. + + * gnus-art.el (gnus-next-page-map): Drop Emacs 20 compat cruft. + + * gmm-utils.el (gmm-write-region): Drop Emacs 20 compat cruft. + + * gnus-util.el (gnus-make-local-hook): Simplify. + +2010-10-02 Julien Danjou <[email protected]> + + * gnus-util.el (gnus-iswitchb-completing-read): New function. + (gnus-ido-completing-read): New function. + (gnus-emacs-completing-read): New function. + (gnus-completing-read): Use gnus-completing-read-function. + Add gnus-completing-read-function. + +2010-10-02 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el (shr-insert-document): Autoload. + (shr-img): Be silent. + (shr-insert): Add a newline after every picture before text. + (shr-add-font): Use overlays for combining faces. + (shr-insert): Pass upwards the text start point. + + * mm-decode.el (mm-text-html-renderer): Default to shr.el rendering, if + possible. + (mm-shr): New function. + +2010-10-02 Julien Danjou <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-insert): Adjust character where we + should go backward. + +2010-10-02 Juanma Barranquero <[email protected]> + + * shr.el (shr): Fix typo in provide call. + +2010-10-02 Lars Magne Ingebrigtsen <[email protected]> + + * shr.el: New file. + + * gnus-html.el (gnus-html-schedule-image-fetching): Be silent. + + * gnus-topic.el (gnus-topic-move-group): Fix the syntax of the + completing read. + +2010-10-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-check-bogus-newsgroups): Say how many groups + we're being queried about. Suggested by Dan Jacobson. + + * nndoc.el (nndoc-type-alist): Do babyl before mime-parts. + Suggested by Jason Eisner. + + * gnus-async.el (gnus-async-delete-prefetched-entry): Remove from hash + table, too. Suggested by Stefan Wiens. + (gnus-async-prefetched-article-entry): Use intern-soft to avoid growing + the table unnecessary. Suggested by Stefan Wiens. + + * gnus-sum.el (gnus-summary-clear-local-variables): This is probably no + longer needed, and probably doesn't work either, as pointed out by + Stefan Wiens. + (gnus-summary-exit): Remove call to the clearing function. + (gnus-summary-exit-no-update): Ditto. + + * gnus-art.el (gnus-summary-save-in-file): Use with-current-buffer + instead of gnus-eval-in-buffer-window to avoid popping up frames. + Reported by Stefan Monnier. + (gnus-summary-save-in-rmail): Ditto. + + * gnus-sum.el (gnus-summary-select-article-buffer): Show only the + article buffer, instead of both the article buffer and the summary + buffer. Sort of suggested by Dan Jacobson. + + * gnus-win.el (gnus-buffer-configuration): Add an only-article spec. + + * nnmbox.el (nnmbox-read-mbox): Mark buffer for deletion on Gnus exit. + Suggested by Dan Jacobson. + + * mm-encode.el (mm-content-transfer-encoding-defaults): Try to make the + documentation clearer. + + * message.el (message-shorten-references): Comment on the number "21". + Suggested by Stefan Monnier. + + * gnus-sum.el (gnus-summary-scroll-up): Add more documentation. + Suggested by Dan Jacobson. + + * gnus.el (gnus-large-newsgroup): + Mention gnus-large-ephemeral-newsgroup. Suggested by Dan Jacobson. + + * gnus-msg.el (gnus-summary-resend-message): When resending, don't + externalize attachments. Bug reported by Steve Wen. + + * gnus.el (gnus-continuum-version): Make inactive, since it doesn't + really message anything to the user. + + * nnmail.el (nnmail-article-group): Allow using the fancy split method + directly. + + * nnimap.el (nnimap-request-group): Low higher than high to signal no + messages in empty groups. + +2010-10-01 Ted Zlatanov <[email protected]> + + * nnimap.el (nnimap-request-group): Don't bug out when there's an empty + non-UIDNEXT group. + +2010-10-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-group.el (gnus-group-completing-read): Return the symbol name, + not the value from the collection. + + * nnimap.el (nnimap-update-info): Ignore groups that have no UIDNEXT + values. This sometimes happens on some groups that have no info. + (nnimap-request-newgroups): New function. + +2010-10-01 Teodor Zlatanov <[email protected]> + + * gnus-registry.el (gnus-registry-install-nnregistry): Move the feature + check into `gnus-registry-initialize'. + (gnus-registry-initialize): Ditto. + Fix and extend header docs. + +2010-10-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-prefetch-images): Adjust regexp to avoid + regexp backtrace overflows. + + * nnimap.el (nnimap-extend-tls-programs): Only extend those programs + for starttls that tls.el implements; i.e. openssl. + +2010-10-01 Katsumi Yamaoka <[email protected]> + + * gravatar.el: Don't load image.el that XEmacs doesn't provide. + (gravatar-create-image): New function that's an alias to + gnus-xmas-create-image, gnus-create-image, or create-image. + (gravatar-data->image): Use it. + +2010-09-30 Teodor Zlatanov <[email protected]> + + * gnus-registry.el (gnus-registry-install-nnregistry): New function to + install the nnregistry refer method. + (gnus-registry-install-hooks): Use it. + (gnus-registry-unfollowed-groups): Add nnmairix to the default + unfollowed groups. + +2010-09-30 Jose A. Ortega Ruiz <[email protected]> (tiny change) + + * gnus-sum.el (gnus-summary-show-thread): Skip past invisible text when + expanding threads. + +2010-09-30 Lars Magne Ingebrigtsen <[email protected]> + + * nnir.el: Use the server names without suffixes (bug #7009). + + * nnimap.el (nnimap-open-connection): Reinstate the auto-upgrade from + unencrypted to STARTTLS, if possible. + +2010-09-30 Teemu Likonen <[email protected]> (tiny change) + + * message.el (message-ignored-supersedes-headers): Strip Injection-* + headers before superseding. + +2010-09-30 Lars Magne Ingebrigtsen <[email protected]> + + * nnrss.el (nnrss-use-local): Add documentation. + + * nnimap.el (nnimap-extend-tls-programs): New function. + (nnimap-open-connection): Use tls.el exclusively, and not starttls.el. + (nnimap-wait-for-connection): Accept the greeting from the stupid + output from openssl s_client -starttls, too. + + * nnimap.el (nnimap-find-article-by-message-id): Really return the + article number. + (nnimap-split-fancy): New variable. + (nnimap-split-incoming-mail): Use it. + + * nntp.el (nntp-server-list-active-group): Document. + + * nnimap.el (nnimap-find-article-by-message-id): Use EXAMINE instead of + SELECT to get the message-id. + + * mail-source.el (mail-sources): Remove webmail support. + (defvar): Ditto. + (mail-source-fetcher-alist): Ditto. + (mail-source-fetch-webmail): Remove. + + * webmail.el: Remove -- doesn't seem relevant any more. + + * gnus.el: Fix up make-obsolete-variable declarations throughout. + + * nnimap.el (nnimap-request-accept-article): Get the Message-ID without + the \r. + +2010-09-30 Julien Danjou <[email protected]> + + * gnus-agent.el (gnus-agent-add-group): Fix call to + gnus-completing-read. + +2010-09-29 Lars Magne Ingebrigtsen <[email protected]> + + * nndoc.el (nndoc-retrieve-groups): New function. + + * nnimap.el (nnimap-split-incoming-mail): If nnimap-split-methods is + `default', use nnmail-split-methods. + (nnimap-request-article): Downcase the NILs so that they are nil. + + * gnus-sum.el (gnus-valid-move-group-p): Make sure that `group' is a + symbol. + + * nnimap.el (nnimap-open-connection): Revert the auto-network->starttls + code, since if the user has requested network, that's what they ought + to get. + (nnimap-request-set-mark): Erase the buffer before issuing commands. + (nnimap-split-rule): Mark as obsolete. + + * pop3.el (pop3-send-streaming-command, pop3-stream-length): + New variable. + + * nnimap.el (nnimap-insert-partial-structure): Get the type from the + correct slot, too. + +2010-09-29 Julien Danjou <[email protected]> + + * gnus.el (gnus-local-domain): Declare variable obsolete. + + * gnus-util.el (gnus-icompleting-read): Require iswitchb. + Fix history computing. + (gnus-ido-completing-read): Require ido. + +2010-09-29 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-registry.el: Don't prompt on load, which makes it impossible to + build Gnus. + + * nnimap.el (nnimap-insert-partial-structure): Be way more permissive + when interpreting the structures. + (nnimap-request-accept-article): Add \r\n to the lines to make this + work with Cyrus. + + * nndraft.el (nndraft-request-expire-articles): Use the group name + instead if "nndraft". Fix found by Nils Ackermann. + +2010-09-29 Ludovic Courtes <[email protected]> + + * nnregistry.el: Add. + +2010-09-29 Stefan Monnier <[email protected]> + + * nnmail.el (group, group-art-list, group-art): + Remove unneeded directives. + +2010-09-29 Katsumi Yamaoka <[email protected]> + + * mm-util.el (mm-codepage-iso-8859-list, mm-charset-eval-alist) + (mm-mime-charset) + * rfc2047.el (rfc2047-syntax-table) + * utf7.el (utf7-utf-16-coding-system): Comment fix. + + * nnrss.el (nnrss-read-server-data, nnrss-read-group-data): Use `load' + rather than `insert-file-contents' and `eval-region'. + +2010-09-29 Julien Danjou <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-properties): Add this properties in + replacement of `gnus-gravatar-relief' to mimic + `gnus-faces-properties-alist'. + Add :version property. + +2010-09-28 Katsumi Yamaoka <[email protected]> + + * mail-source.el (mail-source-report-new-mail) + * message.el (message-default-mail-headers) + * mm-decode.el (mm-valid-image-format-p): Comment fix. + + * mml2015.el (mml2015-use): Don't bind recursive-load-depth-limit. + +2010-09-28 Julien Danjou <[email protected]> + + * gnus-gravatar.el (gnus-gravatar-insert): Fix search in case + mail-address contains the same string as real-name. + + * gnus-ems.el (gnus-put-image): Revert Lars, change and insert + non-blank in header, otherwise it'll get stripped. + + * gnus-gravatar.el (gnus-gravatar-insert): Search backward for + real-name, and then for mail address rather than doing : or , search. + +2010-09-27 Julien Danjou <[email protected]> + + * gnus-util.el (gnus-completing-read): Use gnus-use-ido to apply the + right completing-read function. + (gnus-use-ido): New variable + (gnus-completing-read-with-default): Remove. + * gnus-agent.el (gnus-agent-read-group): Remove prompt computing. + (gnus-agent-add-group): + * gnus-srvr.el (gnus-server-add-server, gnus-server-goto-server): + * mm-view.el (mm-view-pkcs7-decrypt): + * mm-util.el (mm-codepage-setup): + * smime.el (smime-sign-buffer, smime-decrypt-buffer): + * mml-smime.el (mml-smime-openssl-sign-query): + * mml.el (mml-minibuffer-read-type, mml-minibuffer-read-disposition) + (mml-insert-multipart): + * gnus-msg.el (gnus-summary-yank-message): + * gnus-int.el (gnus-start-news-server): + * mm-decode.el (mm-interactively-view-part): + * gnus-dired.el (gnus-dired-attach): + * gnus.el (gnus-read-method): + * gnus-bookmark.el (gnus-bookmark-jump): + * gnus-art.el (gnus-mime-view-part-as-type) + (gnus-mime-action-on-part, gnus-article-encrypt-body): + * gnus-topic.el (gnus-topic-jump-to-topic, gnus-topic-move-matching) + (gnus-topic-copy-matching, gnus-topic-sort-topics, gnus-topic-move): + * nnmairix.el (nnmairix-create-server-and-default-group) + (nnmairix-update-groups, nnmairix-get-server) + (nnmairix-backend-to-server, nnmairix-goto-original-article) + (nnmairix-get-group-from-file-path): + * nnrss.el (nnrss-find-rss-via-syndic8): + * gnus-group.el (gnus-group-completing-read, gnus-group-make-web-group) + (gnus-group-make-useful-group, gnus-group-add-to-virtual) + (gnus-group-browse-foreign-server): + * gnus-sum.el (gnus-summary-goto-article, gnus-summary-limit-to-extra) + (gnus-summary-execute-command, gnus-summary-respool-article) + (gnus-read-move-group-name): + * gnus-score.el (gnus-summary-increase-score) + (gnus-summary-score-effect): + * gnus-registry.el (gnus-registry-read-mark): Use gnus-completing-read. + +2010-09-28 Katsumi Yamaoka <[email protected]> + + * nnimap.el (auth-source-forget-user-or-password) + (auth-source-user-or-password): Autoload. + + * message.el (message-from-style, message-interactive) + (message-signature): Remove comment. + (message-cite-prefix-regexp): Default to mail-citation-prefix-regexp + always. + (message-sendmail-envelope-from): Comment fix. + (message-yank-prefix): Default to mail-yank-prefix always. + (message-indentation-spaces): + Default to mail-indentation-spaces always. + (message-signature-file): Default to mail-signature-file always. + +2010-09-27 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-read-group-1): Set gnus-newsgroup-highest. + (gnus-summary-insert-new-articles): Use gnus-newsgroup-highest to get + new articles. + + * nnimap.el (nnimap-request-article): Don't partial-fetch single-part + parts. + (nnimap-request-article): Work with the t setting, too. + + * gnus-sum.el (gnus-summary-exit): Kill the article buffer later, so + that you don't get flashes of other buffers. + (gnus-summary-show-complete-article): Intern before setting. + +2010-09-27 David Engster <[email protected]> + + * nnmairix.el (nnmairix-replace-group-and-numbers): Deal with NOV as + well as HEADERS. + (nnmairix-retrieve-headers): Provide new argument for the above. + +2010-09-27 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-move-article): Don't alter + gnus-newsgroup-active. This makes `/ N' work after copying to the same + group. + + * nnimap.el (nnimap-update-info): Don't destructively alter active. + + * message.el (message-cite-prefix-regexp): Revert my last edit. + + * gnus-sum.el (gnus-summary-show-complete-article): Bind the server + variable instead of the Gnus variable. + + * nnimap.el (nnimap-find-wanted-parts-1): Use it. + + * gnus-art.el (gnus-fetch-partial-articles): Move back to nnimap again. + + * nnimap.el (nnimap-request-accept-article): Remove the "." at the end, + since some servers don't like it. + (nnimap-open-connection): Forget credentials if the server says the + password was wrong. + (nnimap-parse-line): Protect against invalid data. + + * gnus-sum.el (gnus-summary-move-article): Add comment. + (gnus-summary-insert-new-articles): Copy the old-high watermark so that + nothing alters it while scanning for new messages. + + * nnimap.el (nnimap-request-accept-article): Send a "." at the end, + which may or may not help. + (nnimap-open-connection): If we're doing a stream connection, and then + discover we're on a STARTTLS-capable server, then open a STARTTLS + connection instead. + +2010-09-27 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (utf7): Require. + + * message.el (message-cite-prefix-regexp): Remove "}" from citation + prefix. + +2010-09-27 Juanma Barranquero <[email protected]> * nnmail.el (nnmail-fancy-expiry-targets): Fix typo in docstring. -2010-09-21 Glenn Morris <[email protected]> +2010-09-27 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-request-accept-article): Message the error on + error. + +2010-09-27 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-mime-delete-part): Fix Lisp type of byte(s). + +2010-09-26 Lars Magne Ingebrigtsen <[email protected]> + + * nndoc.el (nndoc-request-list): Return success always. + + * gnus-agent.el (gnus-agent-retrieve-headers): Don't propagate + `fetch-old' -- we only want to fetch the articles we've requested. + The rest are in the agent, probably. + (gnus-agent-read-servers-validate): Change the level for the "Ignoring + disappeared server" to something low. It's not important. + + * nnimap.el (nnimap-get-whole-article): Remove the data that may have + arrived before the FETCH data. + + * nnmh.el (nnmh-request-expire-articles): Don't try to fetch the expiry + target here, because we don't know the Gnus name of the group. + + * nndraft.el (nndraft-request-expire-articles): Fetch the expiry target + for the correct group. + + * gnus-ems.el (gnus-create-image): Ignore all image-creation errors. + + * gnus.el (gnus): Give a final warning after startup. + + * gnus-util.el (gnus-action-message-log): New variable. + (gnus-message): Use it. + (gnus-final-warning): New function. + + * nnimap.el (nnimap-open-connection): Record the greeting. + (nnimap): Add greeting. + +2010-09-26 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-show-images): Fix gnus-html-display-image + arguments. + (gnus-html-wash-images): Fix spec computing to include start/end. + + * gnus-art.el (gnus-article-treat-body-boundary): Fix length computing. + +2010-09-26 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-request-expire-articles): Compress ranges before + deletion. + (nnimap-retrieve-headers): Don't select the group, because that's + already done by nnimap-possibly-change-group. + + * gnus-picon.el (gnus-picon-inhibit-top-level-domains): New variable. + (gnus-picon-transform-address): Use it. + + * mail-source.el (mail-source-value): Revert previous patch. + + * nnimap.el (nnimap-credentials): Allow inhibiting the password query + on failure. + (nnimap-open-connection): Look up both virtual and physical server name + credentials. + + * gnus-win.el: Revert previous patch, since it made Gnus backtrace. + +2009-02-08 Dave Love <[email protected]> + + * gnus-win.el (gnus-window-to-buffer-helper) + (gnus-all-windows-visible-p): Function needn't be a symbol. + + * mail-source.el (mail-source-value): Function needn't be a symbol. + +2010-09-26 Lars Magne Ingebrigtsen <[email protected]> + + * message.el (message-cite-prefix-regexp): Remove } from the cite + prefix. + + * gnus-art.el (gnus-treatment-function-alist): Do picons before + highlight again, so that the highlight is correct. + + * gnus-picon.el (gnus-picon): Remove again. + (gnus-picon-create-glyph): Set the background XPM colour explicitly. + + * gnus-art.el (gnus-treatment-function-alist): Insert picons after + doing the header highlightling, so that the background colour of the + picon is correct. + + * gnus-picon.el (gnus-picon-xbm): Remove obsolete face. + (gnus-picon): Ditto. + (gnus-picon): Reinstate. The background colour for picons is white. + (gnus-picon-insert-glyph): Make the background white. + + * nnml.el (nnml-open-nov): Don't return dead buffers. + + * auth-source.el (auth-source-create): Query the user for whether to + store the credentials. + + * auth-source.el (auth-source-user-or-password): Use the existing auth + sources, if any, for creation. + + * gnus.el (gnus-group-fast-parameter): Return the last matching + parameter instead of the first matching parameter. + +2010-09-26 Julien Danjou <[email protected]> + + * gnus-sum.el (gnus-auto-center-group): Transform into a defcustom. + +2010-09-26 Lars Magne Ingebrigtsen <[email protected]> + + * mml2015.el (mml2015-use): Remove gpg support. + + * mml1991.el (mml1991-function-alist): Remove gpg function. + (mml1991-gpg-sign): Remove. + +2010-09-26 Andreas Seltenreich <[email protected]> + + * gnus-srvr.el (gnus-browse-subscribe-newsgroup-method): New variable. + (gnus-browse-unsubscribe-current-group): Document it. + (gnus-browse-unsubscribe-group): Use it. + +2010-09-26 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-group.el (gnus-read-ephemeral-bug-group): Add the bug email + address to the To list for easier response. + + * gnus.el (gnus-play-startup-jingle): Remove. + (gnus-splash): Don't play jingle. + (gnus): Silence gnus-load message. + + * gnus-art.el (gnus-treat-play-sounds): Remove. + + * gnus.el (gnus-play-jingle): Remove audio support. + + * gnus-cus.el (gnus-score-customize): Remove audio reference. + + * earcon.el: Remove -- no users. + + * gnus-audio.el: Remove -- no users of this package. + + * gnus-sum.el (gnus-summary-limit-children): Remove nocem support. + + * gnus-start.el (gnus-setup-news): Remove nocem support. + + * gnus-group.el (gnus-group-get-new-news): Remove nocem call. + + * gnus.el (gnus-use-nocem): Remove. + + * gnus-demon.el (gnus-demon-add-nocem, gnus-demon-scan-nocem): + Remove. + + * gnus-nocem.el (gnus-nocem-issuers): Remove file. Apparently nobody + uses NoCeM any more. + + * gnus-art.el (gnus-ctan-url): Seems not very useful -- removed. + (gnus-button-ctan-handler): Ditto. + (gnus-button-handle-ctan-bogus-regexp): Ditto. + (gnus-button-ctan-directory-regexp): Ditto. + (gnus-button-handle-ctan): Ditto. + (gnus-button-tex-level): Ditto. + (gnus-button-alist): Remove CTAN stuff. + +2010-09-25 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-wait-for-response): Reverse logic in the + nnimap-streaming test. + + * gnus-start.el (gnus-get-unread-articles): Don't try to open failed + servers twice. + + * nnimap.el (nnimap-open-connection): Add more error reporting when + nnimap fails early. + + * nnheader.el (nnheader-get-report-string): New function. + (nnheader-get-report): Use it. + + * gnus-int.el (gnus-check-server): Say what the error was when opening + failed. + + * nnimap.el (nnimap-wait-for-response): Search further when we're not + using streaming. + +2010-09-25 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-rescale-image): Use our defalias + gnus-window-inside-pixel-edges. + +2010-09-25 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-srvr.el (gnus-server-copy-server): Add documentation. + + * mm-decode.el (mm-save-part): Allow saving to other directories the + normal Emacs way. + + * nndoc.el (nndoc-type-alist): Move mime-parts after mbox. + Suggested by Jay Berkenbilt. + + * gnus-art.el (gnus-mime-delete-part): Fix plural for "byte" when + there isn't a single byte. + + * gnus-int.el (gnus-open-server): Don't query whether to go offline -- + just do it. It doesn't really seem to matter what the user responds + here, I think, so it's just a confusing question. + + * nnimap.el (nnimap-retrieve-group-data-early): Fix typo in the + non-streaming case. + + * gnus-art.el (gnus-flush-original-article-buffer): Separate out. + (gnus-article-encrypt-body): Use it. + + * gnus-sum.el (gnus-summary-show-complete-article): New command and + keystroke. + + * nnimap.el (nnimap-find-wanted-parts-1): + Use gnus-fetch-partial-articles. + + * gnus-art.el (gnus-fetch-partial-articles): New variable. + + * nnimap.el (nnimap-insert-partial-structure): New function. + (nnimap-get-partial-article): New function. + (nnimap-request-article): Use it. + (nnimap-wait-for-response): Return whether the wait was successful. + (nnimap-finish-retrieve-group-infos): Don't do anything if the + retrieval wasn't successful. + (nnimap-retrieve-group-data-early): Allow throttling servers. + (nnimap-streaming): New variable. + (nnimap-fetch-partial-articles): Remove. + + * mm-decode.el (mm-with-part): Protect against killed buffers. + + * nndraft.el (nndraft-retrieve-headers): Insert Lines and Chars headers + for prettier summary display. + +2010-09-25 Andrew Cohen <[email protected]> (tiny change) + + * nnir.el (nnir-run-imap): Allow sending IMAP search patterns directly. + +2010-09-25 Lars Magne Ingebrigtsen <[email protected]> + + * gnus.el (gnus-local-domain): Put gnus-local-domain back again, since + apparently third-party libraries depend on it. + + * nnimap.el (nnimap-open-connection): Wait for the response to STARTTLS + before starting negotiation. + + * gnus-art.el (gnus-treat-from-gravatar): Change default to nil for + privacy reasons. + (gnus-treat-mail-gravatar): Ditto. + + * gnus-ems.el (gnus-put-image): Don't put any non-blank text into the + buffer when inserting images. Inserting text into the headers, for + instance, can make them invalid. + +2010-09-25 Julien Danjou <[email protected]> + + * rfc1843.el: Remove useless rfc1843-old-gnus-decode-header-function + variables. + + * nnheader.el: Remove useless variables news-reply-yank-from and + news-reply-yank-message-id. + + * mml2015.el: Remove useless mc-default-scheme and mc-schemes + variables. + + * mml1991.el: Remove useless mml1991-verbose. + + * gnus.el: Remove useless variable gnus-use-generic-from. + Remove obsolete variable gnus-topic-indentation. + + * gnus-uu.el: Remove useless gnus-uu-shar-file-name. + + * gnus-sum.el: Remove useless gnus-newsgroup-none-id. + + * gnus-picon.el: Remove useless gnus-picon-setup-p variable. + + * gnus-group.el: Remove useless gnus-group-icon-cache. + Remove useless gnus-ephemeral-group-server. + + * gnus-bookmark.el: Remove useless gnus-bookmark-after-jump-hook. + + * mml2015.el: Remove useless mml2015-verbose. + + * mml-smime.el: Remove useless mml-smime-verbose. + + * gnus.el: Remove useless gnus-local-domain. + + * gnus-gravatar.el (gnus-gravatar-transform-address): + Use gnus-gravatar-size. + + * gnus-art.el: Remove useless gnus-treat-translate. + +2010-09-24 Julien Danjou <[email protected]> + + * gnus-sum.el: Add support for Gravatars. + + * gnus-art.el: Add support for Gravatars. + + * gnus-gravatar.el: Add this file. + + * gravatar.el: Add this file. + +2010-09-24 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-summary-fetch-faq): Remove. + + * gnus-group.el (gnus-group-fetch-faq): Remove. + + * gnus.el (gnus-group-faq-directory): Remove. + + * gnus-group.el (gnus-group-fetch-charter): Remove. + + * gnus.el (gnus-group-charter-alist): Remove. + + * gnus-group.el (gnus-group-archive-directory): Remove. + (gnus-group-recent-archive-directory): Ditto. + (gnus-group-make-archive-group): Remove. + + * nnimap.el (nnimap-update-info): Protect against nil uidnexts. + + * gnus-cache.el (gnus-cache-braid-heads): When braiding heads, don't + use the same article number for all the cached articles. + + * nnimap.el (nnimap-command): Register the last command time so + that we can use it for idling NOOPs. + (nnimap-open-connection): Start the keeplive timer. + (nnimap-make-process-buffer): Store all the process buffers. + (nnimap-keepalive): New function. + + * starttls.el (starttls-open-stream): Add autoload cookie. + +2010-09-24 Michael Welsh Duggan <[email protected]> (tiny change) + + * nnimap.el (nnimap-split-incoming-mail): Fix paren typo in the 'junk + handling. + +2010-09-24 Lars Magne Ingebrigtsen <[email protected]> + + * nnrss.el (nnrss-retrieve-groups): Change to the group before checking + its data structures. + + * gnus.el (gnus-sloppily-equal-method-parameters): Use copy-sequence + instead of the cl.el copy-list. + (gnus-sloppily-equal-method-parameters): Use equal instead of the cl + equalp. + +2010-09-24 Katsumi Yamaoka <[email protected]> + + * gmm-utils.el (gmm-tool-bar-from-list): Always use tool-bar-local-item + and tool-bar-local-item-from-menu. + + * gnus-agent.el (gnus-agent-make-mode-line-string): Always use + mode-line-highlight face for Emacs. + + * gnus-art.el (toplevel): Don't bind recursive-load-depth-limit while + loading gnus-sum.elc; fix comment for canlock-verify. + (gnus-article-jump-to-part): Use read-number. + (gnus-insert-mime-button, gnus-insert-mime-security-button): + Remove Emacs pre-21 compatible code for help-echo. + (gnus-article-next-page-1): No need to adjust the number of lines. + (gnus-article-describe-bindings): Always use help-buffer. + + * gnus-audio.el (gnus-audio-inline-sound) + * gnus-cus.el (gnus-custom-mode) + * gnus-group.el (gnus-group-update-tool-bar): Comment fix. + + * gnus-sum.el (gnus-remove-overlays): Doc fix. + + * gnus-util.el (gnus-select-frame-set-input-focus): Remove Emacs 21 + compatible code. + +2010-09-24 Glenn Morris <[email protected]> * message.el (message-output): Use gnus-output-to-rmail if a buffer is visiting the fcc file in rmail-mode. +2010-09-24 Katsumi Yamaoka <[email protected]> + + * nnir.el: Silence the byte compiler. + + * gnus-html.el (gnus-html-encode-url-chars): New function, that's an + alias to browse-url-url-encode-chars if any. + (gnus-html-encode-url): Use it. + +2010-09-23 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-use-backend-marks): New variable. + (gnus-get-unread-articles-in-group): Use it. + + * gnus-sum.el (gnus-summary-local-variables): Prepare for list/range + makeover. + +2010-09-23 Andrew Cohen <[email protected]> + + * nnimap.el (nnimap-retrieve-headers): Return 'headers. + +2010-09-23 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-fixup-nnimap-unread-after-getting-new-news): + Remove. + (gnus-setup-news-hook): + Remove gnus-fixup-nnimap-unread-after-getting-new-news. + + * gnus-int.el (gnus-request-update-info): Protect against backends not + having the function. + + * nnimap.el (nnimap-stream): Mention starttls. + (nnimap-open-connection): Add starttls support. + +2010-09-23 Andrew Cohen <[email protected]> + + * nnir.el (nnir-run-imap): Fix up nnir to work with the new nnimap. + +2010-09-23 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-transform-headers): Don't bug out on invalid + BODYSTRUCTUREs. + (nnimap-transform-headers): Unfold quoted {42} headers. + + * gnus-start.el (gnus-get-unread-articles): Allow backends to update + the info. + (gnus-get-unread-articles): Only call updatep on backends that support + it. + + * nnweb.el (nnweb-request-update-info): NOOP. + + * nnmaildir.el (nnmaildir-request-marks): Rename from -update-info. + + * nnfolder.el (nnfolder-request-marks): Rename from -update-info, + since it only deals with marks. + + * gnus-int.el (gnus-request-marks): Rename gnus-request-update-info to + gnus-request-marks, and make a new gnus-request-update-info. + + * nnimap.el (nnimap-update-info): When UIDNEXT is present, use that for + the active instead of the high number, which is usually too low. + +2010-09-23 Teodor Zlatanov <[email protected]> + + * encrypt.el: Remove. + +2010-09-23 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-update-info): Sync non-standard flags from the + server in symbolic form. + + * gnus-html.el (gnus-max-image-proportion): Increase proportion to 0.9. + +2010-09-22 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-parse-flags): Parse the data in any order. + (nnimap-update-info): Fix up code slightly. + + * gnus-int.el (gnus-open-server): Add tracing for performance + debugging. + + * gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start. + (gnus-group-insert-group-line): Pass the real group name so that it + gets the right data. + + * gnus-start.el (gnus-get-unread-articles): Don't have + `gnus-get-unread-articles-in-group' update info, since that can be + really slow and doesn't seem to be needed? + +2010-09-22 Julien Danjou <[email protected]> + + * gnus-group.el (gnus-group-insert-group-line): + Call gnus-group-highlight-line. + (gnus-group-update-hook): Remove gnus-group-highlight-line from the + default hook list. + (gnus-group-update-eval-form): Add new function. + (gnus-group-highlight-line): Use gnus-group-update-eval-form. + (gnus-group-get-icon): Use gnus-group-update-eval-form. + +2010-09-22 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is + immediate, then expire all articles. + (nnimap-update-info): Fix off-by-one errors. + (nnimap-flags-to-marks): Would return no marks lists for group with no + flags. Instead return the other data. + +2010-09-22 Julien Danjou <[email protected]> + + * gnus-group.el (gnus-group-get-icon): Rename gnus-group-add-icon that + Only return an icon. + (gnus-group-insert-group-line): Compute icon to return. + + * gnus-html.el (gnus-html-image-automatic-caching): Add custom var. + (gnus-html-image-fetched): Only cache if + gnus-html-image-automatic-caching is set. + (gnus-html-image-fetched): Check for errors. + +2010-09-22 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-read-active-for-groups): Only run -request-scan + once per method on `g'. This ensures that backends like nnfolder don't + open all their folders. + + * nnimap.el (nnimap-split-incoming-mail): Delete 'junk. + (nnimap-request-list): Nix out group in the correct buffer. + (nnimap-parse-flags): Implement by using `read' instead of + hand-parsing. + (nnimap-flags-to-marks): Pass on permanent-flags. + (nnimap-make-process-buffer): Record the server name. + (nnimap-parse-flags): Fix typo. + (nnimap-request-scan): Run split on the server in general, not just a + single group. + + * nnmail.el (nnmail-split-incoming): Take an optional junk-func + parameter, and propagate this downwards. + + * nnimap.el (nnimap-request-list): Set the current nnimap group to nil, + since EXAMINE changes it on the server. + + * gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since + this command might take a while. + +2010-09-22 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-put-image): Stop using markers. They are + harmful if you have 2 images side-by-side, they can't be properly + update on text deletion. Using text-property is safer here. + (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of + data. + +2010-09-22 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-expunge-inbox): Remove. + (nnimap-mark-and-expunge-incoming): Use nnimap-expunge instead. + (nnimap-expunge): Flip default to t. + + * gnus.el (gnus-method-to-server): Don't push things to the cache + unless it's unique. + (gnus-server-to-method): Ditto. + +2010-09-22 Teodor Zlatanov <[email protected]> + + * nnimap.el (nnimap-delete-article): Tell user if expunge won't happen. + +2010-09-22 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to + get the start of data. + (gnus-html-encode-url): Add this function to encode special chars in + URL. + (gnus-html-wash-images): Use gnus-html-encode-url to encode URL. + (gnus-html-prefetch-images): Use gnus-html-encode-url to encode URL. + + * gnus-group.el (gnus-group-update-hook): Call gnus-group-add-icon by + default. + (gnus-group-add-icon): Move to gnus-group.el, and rewrite so it works. + + * gnus-html.el (gnus-html-wash-images): Use xml-substitute-special on + images alt-text. + (gnus-html-put-image): Put alt-text as help-echo. + +2010-09-22 Katsumi Yamaoka <[email protected]> + + * mailcap.el (mailcap-parse-mailcap, mailcap-parse-mimetypes) + * mm-util.el (mm-decompress-buffer) + * nnir.el (nnir-run-find-grep) + * pop3.el (pop3-list): Use 3rd arg of split-string. + +2010-09-21 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks + outside the active range. Suggested by Dan Christensen. + + * gnus-start.el (gnus-get-unread-articles): Get the extended method + slightly later to avoid double-getting it. + + * nnml.el (nnml-generate-nov-file): Fix variable name clobbering from + previous patch. + + * gnus-sum.el (gnus-adjust-marked-articles): Fix another typo. + +2010-09-21 Adam Sjøgren <[email protected]> + + * gnus-sum.el (gnus-adjust-marked-articles): Fix typo. + +2010-09-21 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-int.el (gnus-open-server): Give a better error message in the + "go offline" case. + + * gnus-sum.el (gnus-adjust-marked-articles): Hack to avoid adjusting + marks for nnimap, which is seldom the right thing to do. + + * gnus.el (gnus-sloppily-equal-method-parameters): Refactor out. + (gnus-same-method-different-name): New function. + + * nnimap.el (parse-time): Require. + + * gnus-start.el (gnus-get-unread-articles): Fix the prefixed select + method in the presence of many similar methods. + + * nnmail.el (nnmail-expired-article-p): Fix typo: time-subtract. + + * nnimap.el (nnimap-find-expired-articles): Don't refer to + nnml-inhibit-expiry. + + * gnus-sum.el (gnus-summary-move-article): Use gnus-server-equal to + find out whether methods are equal. + + * nnimap.el (nnimap-find-expired-articles): New function. + (nnimap-process-expiry-targets): New function. + (nnimap-request-move-article): Request the article before looking at + what the Message-ID is. Fix found by Andrew Cohen. + (nnimap-mark-and-expunge-incoming): Wait for the last sequence. + + * nnmail.el (nnmail-expired-article-p): Allow returning the cutoff time + for oldness in addition to being a predicate. + + * nnimap.el (nnimap-request-group): When we have zero articles, return + the right data to Gnus. + (nnimap-request-expire-articles): Only delete articles immediately if + the target is 'delete. + + * gnus-sum.el (gnus-summary-move-article): When respooling to the same + method, this would bug out. + + * gnus-group.el (gnus-group-expunge-group): Rename from + gnus-group-nnimap-expunge, and implemented as a normal interface + function. + + * gnus-int.el (gnus-request-expunge-group): New function. + + * nnimap.el (nnimap-request-create-group): Implement. + (nnimap-request-expunge-group): New function. + +2010-09-21 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-image-cache-ttl): Add new variable. + (gnus-html-cache-expired): Add new function. + (gnus-html-wash-images): Use `gnus-html-cache-expired' to check + wethever we should display image for fetch it. + Compute alt-text earlier to pass it to the fetching function too. + (gnus-html-schedule-image-fetching): Change function argument to only + get one image at a time, not a list. + (gnus-html-image-fetched): Use `url-store-in-cache' to store image in + cache. + (gnus-html-get-image-data): New function to retrieve image data from + cache. + (gnus-html-put-image): Change buffer argument to use image data rather + than file, and place image above region rather than inserting a new + one. Do not take alt-text as argument, since it's useless now: we place + the image above alt-text. + (gnus-html-prune-cache): Remove. + (gnus-html-show-images): Start to fetch image when we find one, do not + push into a temporary list. + (gnus-html-prefetch-images): Only fetch image if they have expired. + (gnus-html-browse-image): Fix, use 'gnus-image-url. + (gnus-html-image-map): Add "v" to browse-url on undisplayed image. + +2010-09-20 Katsumi Yamaoka <[email protected]> + + * rfc2047.el (rfc2047-encode-parameter): Doc fix. + +2010-09-20 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-group.el (gnus-group-line-format-alist): Have the ?U (unseen) + spec inser "*" if the group isn't active instead of 0. + + * nnimap.el (nnimap-request-group): Don't select the imap buffer before + opening the server. + (nnimap-request-delete-group): Implement group deletion. + (nnimap-transform-headers): Return the size of the entire message in + the Bytes header, not just the size of the first part. + (nnimap-request-move-article): When moving an article from nnimap, + request the article first so the accepting form has an article to + accept. Reported by Dan Christensen. + (nnimap-command): Make sure that the error message doesn't error out. + +2010-09-20 David Edmondson <[email protected]> (tiny change) + + * nnimap.el (nnimap-request-set-mark): Don't wait for a response when + we haven't requested anything. + +2010-09-20 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-fetch-inbox): Use "[]" as the parameter instead of + "". Fix found by Andrew Cohen. + + * mail-parse.el (mail-header-encode-parameter): Use -encode-parameter + instead of -encode-string. + +2010-09-20 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-html-image-fetched): Pass arg to kill-buffer. + + * gnus-sum.el (gnus-summary-update-mark): Replace subst-char-in-string + by mm-subst-char-in-string. + +2010-09-19 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-wait-for-connection): Avoid a race condition while + waiting for the connection string. + + * gnus-html.el (gnus-html-image-fetched): Protect against the data not + arriving. + + * gnus-start.el (gnus-ignored-newsgroups): Remove [] from the list of + bogus characters. This allows selecting certain Gmail groups. + + * nnimap.el (nnimap-find-wanted-parts-1): New function. + (nnimap-fetch-partial-articles): New variable. + (nnimap-open-connection): When looking for credentials, also use the + nnimap-server-port. + (nnimap-request-article): Return the group/article number, so that Gnus + `^' works as expected. + (nnimap-find-wanted-parts-1): Return the MIME parts as IMAP wants them. + + * gnus.el (gnus-similar-server-opened): Refactor a bit and add + comments. + (gnus-methods-sloppily-equal): New function. + (gnus): When using the development version of Gnus, load the gnus-load + file. + + * gnus-start.el (gnus-get-unread-articles): Make sure that we call + `gnus-open-server' on each method before trying to scan them etc. + This ensures that all the backend parameters are set correctly. + + * nnimap.el (nnimap-authenticator): New variable. + (nnimap-open-connection): Allow anonymous login. + (nnimap-transform-headers): The chars header is called Chars not Bytes. + (nnimap-wait-for-response): Don't infloop if the IMAP connection drops. + + * gnus-art.el (gnus-article-describe-briefly): Fix up typo in last + patch, found by Knut Anders Hatlen. + +2010-09-19 Andreas Schwab <[email protected]> + + * gnus-agent.el (gnus-agent-batch-confirmation) + (gnus-agent-expire-group, gnus-agent-expire): Pass proper format string + to gnus-message. + * gnus-art.el (gnus-article-describe-briefly): Likewise. + * gnus-group.el (gnus-group-list-groups, gnus-group-describe-group) + (gnus-group-edit-global-kill, gnus-group-describe-briefly): Likewise. + * gnus-int.el (gnus-open-server): Likewise. + * gnus-score.el (gnus-score-edit-current-scores, gnus-score-edit-file) + (gnus-score-check-syntax): Likewise. + * gnus-srvr.el (gnus-browse-describe-briefly): Likewise. + * gnus-start.el (gnus-read-active-file-1, gnus-read-active-file-1): + Likewise. + * gnus-sum.el (gnus-summary-describe-briefly): Likewise. + +2010-09-19 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-prefetch-images): Fix up the url-retrieve + calling conventions so that prefetch doesn't bug out. + +2010-09-19 Julien Danjou <[email protected]> + + * gnus-sum.el (gnus-summary-update-mark): Use `subst-char-in-string' + rather than `subst-char-in-region' in order to be able to replace ASCII + char by UTF-8 ones. + + * gnus-html.el (gnus-html-prefetch-images): Use `url-retrieve' rather + than curl. + (gnus-html-image-fetched): Fix `gnus-html-put-image' call not setting + the right URL and ALT text on images. + (gnus-html-wash-tags): Fix tag case. + Add support for `s' and `ins' tags. Use gnus-emphasis-* faces. + (gnus-article-html): Add -o display_ins_del=2 option. + (gnus-html-wash-tags): Add better support for <ul> tags symbols. + +2010-09-19 Lars Magne Ingebrigtsen <[email protected]> + + * nnheader.el (nnheader-insert-nov): Protect against junk appearing in + the extra mail headers, which sometimes seem to happen for unknown + reasons. + + * mail-parse.el (mail-header-encode-parameter): Define as + rfc2045-encode-string instead of as rfc2231-encode-string, since some + (or most, perhaps?) mail readers don't understand the latter, but do + understand the former. + + * gnus-agent.el (gnus-agent-auto-agentize-methods): Switch the default + to nil, so that no methods are automatically agentized. I think this + is probably what most users want. + + * gnus-html.el (gnus-html-schedule-image-fetching): Ignore all errors + from url-retrieve, for instance about invalid URLs. + + * nnimap.el (nnimap-finish-retrieve-group-infos): Protect against + groups that have no articles. + (nnimap-request-article): Check that we really got an article when we + requested one. + + * gnus-agent.el (gnus-agent-load-alist): Nix out the alist if the file + doesn't exist. + + * nnimap.el (nnimap-finish-retrieve-group-infos): Return data in the + nntp buffer so the agent can save it. + (nnimap-open-shell-stream): Bind `process-connection-type' to nil, so + that CRLF doesn't get translated to \n. + (nnimap-open-connection): Don't make 'shell commands only send \n. + +2010-09-19 Stefan Monnier <[email protected]> + + * nnml.el (nnml-files): Add prefix to dynamic var `files'. + (nnml-generate-nov-databases-directory, nnml-generate-active-info): + Update var name. + (nnml-generate-nov-file): Use dolist. + (nnml-directory-articles, nnml-current-group-article-to-file-alist): + Use with-current-buffer. + +2010-09-18 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-schedule-image-fetching): Fetch all images in + parallel. + +2010-09-18 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-update-info): When doing partial marks update, get + the range update right. + (nnimap-request-group): Don't make `M-g' bug out on group with no + marks. + (nnoo): Require, so that other packages can require nnimap. + (nnimap-wait-for-response): Be a bit more lax in finding the end of the + command we're looking for. This helps when the server sends more + responses after we've gotten everything we expected. + (nnimap): Add a `newlinep' field to keep track of end-of-line + conventions. + Don't send CRLF to things that don't want it. + (nnimap-request-accept-article): Ditto. + +2010-09-18 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-schedule-image-fetching): Use `url' rather + than curl to retrieve images. + +2010-09-18 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-update-info): Extend the info so that we can set + the marks. + (nnimap-open-connection): Fix typo -- should be 'shell, not 'stream. + (nnimap-wait-for-connection): New function. + (nnimap-open-connection): If we have PREAUTH, don't query for login + credentials. + (nnimap-update-info): Fix off-by-one error when concatenating ranges + when doing a partial update. + +2010-09-18 Julien Danjou <[email protected]> + + * gnus-html.el (gnus-html-wash-tags): Add support for i, b and u HTML + tags. + +2010-09-18 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-credentials): New function. + (nnimap-open-connection): Use the new function to look for credentials + also on the numeric equivalents of "imap" and "imaps". + + * gnus-start.el (gnus-activate-group): Send the info to + gnus-request-group. + + * nnimap.el (nnimap-request-group): Have the "check" version of the + function parse flags and update the info, so that a `M-g' get a total + resync of all flags from the group. + + * gnus-int.el (gnus-request-group): Take an optional `info' parameter + to allow backends to alter the info on group selection. Also alter all + the backend -request-group functions to take the parameter. + + * nnimap.el (nnimap-store-info): New function. + (nnimap-update-info): Store the info for later usage. + (nnimap-request-group): Use the stored info for the dont-check case, so + that we don't retrieve all marks when we enter a group. + + * nnimap.el: Use deffoo instead of defun for interface functions. + + * gnus-start.el (gnus-get-unread-articles): Allow the backends to + update the group info. This makes the nndraft groups, for instance, go + back to their old behaviour. + + * gnus-sum.el (gnus-select-newsgroup): Indent. + + * nnimap.el (nnimap-possibly-change-group): Return nil if we can't log + in. + (nnimap-finish-retrieve-group-infos): Make sure we're not waiting for + nothing. + + * gnus-start.el (gnus-get-unread-articles): Don't try to scan groups + from methods that are denied. + + * gnus-int.el (gnus-method-denied-p): New function. + + * nnimap.el (nnimap-open-connection): Use auth-sources to query and + store the password instead of netrc. + (nnimap-open-connection): Don't error out when we can't make a + connections. + + * auth-source.el (auth-source-create): In the password prompt, say what + we're querying for. Also prompt for user name if that hasn't been + given. + + * nnimap.el (nnimap-with-process-buffer): Remove. + +2010-09-17 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-read-active-for-groups): Don't use the "finish" + method when we're reading from the agent. + + * nnagent.el (nnagent-retrieve-group-data-early): New dummy method. + + * auth-source.el (auth-sources): Add ~/.authinfo to the default, since + that's probably most useful for users. + + * gnus-int.el (gnus-check-server): Save result so that it doesn't say + "failed" all the time. + + * gnus.el: Throughout all files, replace (save-excursion (set-buffer + ...)) with (with-current-buffer ... ). + + * nntp.el (nntp-open-server): Return whether the open was successful or + not. + + * gnus-sum.el (gnus-summary-first-subject): Have `unseen-or-unread' + select an unread unseen article first. + + * nnimap.el (nnimap-open-connection): If the user doesn't have a + /etc/services, supply some sensible port defaults. + +2010-09-17 Julien Danjou <[email protected]> + + * mm-decode.el (mm-text-html-renderer): Document gnus-article-html. + +2010-09-17 Knut Anders Hatlen <[email protected]> (tiny change) + + * nnimap.el (nnimap-get-groups): Don't bug out if the LIST command + doesn't have any parameters. + +2010-09-17 Lars Magne Ingebrigtsen <[email protected]> + + * nnimap.el (nnimap-open-connection): Upcase all capabilities, and use + only upcased checks. + + * nnmail.el (nnmail-article-group): Fix typo in "bogus" section. + + * nnimap.el (nnimap-open-shell-stream): New function. + (nnimap-open-connection): Use it. + (nnimap-transform-headers): Get the number of lines in each message. + (nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the + number of lines. + (nnimap-request-list): Not all servers return UIDNEXT. Work past this + problem. + + * utf7.el (utf7-encode): Autoload. + + * nnmail.el (nnmail-inhibit-default-split-group): New internal variable + to allow the mail splitting to not return a default group. This is + useful for nnimap, which will leave unmatched mail in the inbox. + + * nnimap.el: Rewritten. + + * gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for + nnimap usage. + + * gnus-sum.el (gnus-summary-move-article): Pass the move-to group name + if the move is internal, so that nnimap can do fast internal moves. + + * gnus-start.el (gnus-get-unread-articles): Support early retrieval of + data. + (gnus-read-active-for-groups): Support finishing the early retrieval of + data. + + * gnus-range.el (gnus-range-nconcat): New function. + + * gnus-int.el (gnus-finish-retrieve-group-infos) + (gnus-retrieve-group-data-early): New functions. + +2010-09-17 Stefan Monnier <[email protected]> + + * nnrss.el (nnrss-retrieve-headers, nnrss-request-list-newsgroups) + (nnrss-retrieve-groups): + * pop3.el (pop3-open-server, pop3-read-response, pop3-list, pop3-retr) + (pop3-quit): Use with-current-buffer. + +2010-09-17 Katsumi Yamaoka <[email protected]> + + * pop3.el (pop3-wait-for-messages): Use pop3-accept-process-output + instead of nnheader-accept-process-output. + + * gnus-html.el (gnus-html-schedule-image-fetching) + (gnus-html-prefetch-images): Replace process-kill-without-query by + gnus-set-process-query-on-exit-flag. + +2010-09-16 Romain Francoise <[email protected]> + + * gnus-html.el: Require gnus-art for `gnus-with-article-buffer'. + +2010-09-14 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-registry.el (gnus-registry-install-shortcuts): The second + parameter to unintern is mandatory-ish in Emacs 24. + + * gnus-html.el (gnus-html-schedule-image-fetching) + (gnus-html-prefetch-images): Check for curl before using it. + + * mm-decode.el (mm-text-html-renderer): Don't have gnus-article-html + depend on curl, which isn't essential. + + * imap.el: Revert back to version + cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes + seem problematic. + +2010-09-14 Juanma Barranquero <[email protected]> + + * gnus-registry.el (gnus-registry-install-shortcuts): + Explicitly pass `obarray' to `unintern' to avoid a warning. + +2010-09-14 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-read-active-for-groups): Revert the previous + change. + + * nnrss.el (nnrss-request-list): Remove this function and related + functions, including the moreover stuff. + +2010-09-14 Lars Magne Ingebrigtsen <[email protected]> + + * nnrss.el (nnrss-retrieve-groups): New function. + +2010-09-14 Juanma Barranquero <[email protected]> + + * .dir-locals.el: Add no-byte-compile cookie. + +2010-09-14 Katsumi Yamaoka <[email protected]> + + * gnus-start.el (gnus-read-active-for-groups): Run gnus-activate-group + for back end that doesn't support request-scan. + +2010-09-10 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-read-active-file-1): If gnus-agent isn't set, + then do request scans from the backends. + + * gnus-sum.el (gnus-summary-update-hook): Change default to nil, to + avoid running a hook per line, since this takes a lot of time, + profiling shows. + (gnus-summary-prepare-threads): Call `gnus-summary-highlight-line' + directly if gnus-visual-p is true. + +2010-09-10 Katsumi Yamaoka <[email protected]> + + * gnus-start.el (gnus-read-active-for-groups): Check only subscribed + groups; replace mapcar with dolist which is a bit faster; pass groups + info to gnus-read-active-file-1. + (gnus-read-active-file-1): Scan only specified groups if the new + optional arg `infos' is given. + +2010-09-09 Lars Magne Ingebrigtsen <[email protected]> + + * mail-source.el (mail-source-fetch-pop): Use pop3-movemail again. + + * pop3.el (pop3-movemail): Remove. + (pop3-streaming-movemail): Rename to pop3-movemail. + + * gnus-html.el (gnus-html-wash-tags): Refactor out the image bit, and + don't restrict end-tag searches to the end of the line. + +2010-09-09 Katsumi Yamaoka <[email protected]> + + * gnus-start.el (gnus-get-unread-articles): Set the number of unread + articles of every unchecked group to t, which means unknown since the + server has never been opened. + +2010-09-08 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-show-alt-text): New command. + (gnus-html-browse-image): Ditto. + (gnus-html-wash-tags): Add the data to allow showing the ALT text and + to browse the image directly. + (gnus-html-wash-tags): Search for images first, so that <a><img> works + better. + + * gnus-async.el (gnus-async-article-callback): + Call `gnus-html-prefetch-images' unconditionally. + + * gnus-html.el (gnus-html-schedule-image-fetching): Decode entities + before feeding URLs to curl. + +2010-09-07 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-html-wash-tags, gnus-html-put-image): Mark cid and + internal images as deletable by `W D D'. + + * gnus-async.el (gnus-html-prefetch-images): Autoload it when compiling. + (gnus-async-article-callback): Fix typo. + +2010-09-06 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-wash-tags): Limit end-tag matching to the + current line to work around bugs in the output from w3m. + + * gnus-async.el (gnus-async-article-callback): Always prefetch images + for groups that want that. + + * nntp.el (nntp-wait-for-string): Supply a timeout for + accept-process-output to ensure progress. + + * gnus-start.el (gnus-get-unread-articles): If being given an explicit + level to get unread articles from, then use that for foreign groups, + too. + + * gnus-html.el (gnus-html-wash-tags): Remove <a name...> tags, which + confuses the rest of the function. + + * gnus-start.el (gnus-read-active-for-groups): Do a `gnus-request-scan' + for the methods that support -retrieve-groups, too. + + * nnml.el (nnml-save-nov): Remove some debugging-related messages. + +2010-09-06 Katsumi Yamaoka <[email protected]> + + * pop3.el: Require cl when compiling. + (pop3-number-of-responses): Search for "+OK", not "+OK ". + +2010-09-05 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-get-unread-articles): Don't bother with groups + that aren't going to be activated. + (gnus-get-unread-articles): Fix up the last commit. + + * gnus-html.el (gnus-article-html): Allow calling without specifying + the handle. In that case, dissect the buffer first. + + * gnus-sum.el (gnus-set-mode-line): Don't pad the mode line string. + + * nnimap.el (nnimap-open-connection): Revert the change that would look + into authinfo for imaps instead of imap. + + * gnus-start.el (gnus-activate-group): Take an optional parameter to + say that you don't want to call gnus-request-group with don-check, but + do check the reponse. This is for virtual groups only. + (gnus-get-unread-articles): Count the archive groups as secondary, so + that they're activated the same way as before. + + * nnimap.el (nnimap-request-list): Servers may return \NoSelect + case-insensitively. + (nnimap-debug): Remove. + + * mail-source.el (mail-source-fetch): Don't message if we're fetching + mail from a file, and the file doesn't exist. + + * pop3.el (pop3-streaming-movemail): Return t for success. + + * nnimap.el (nnimap-open-connection): Look for the "imaps" entry in the + .authinfo if we're using ssl connection. + + * nnvirtual.el (nnvirtual-create-mapping): Use the active info we + already have if we're in a main Gnus `g' run. + + * gnus-start.el (gnus-method-rank): Get info for virtual groups last. + +2010-09-05 Katsumi Yamaoka <[email protected]> + + * gnus-start.el (gnus-method-rank): Replace equalp with equal. + + * nnmh.el (nnmh-request-list-1): Bind `file'. + + * pop3.el (pop3-set-process-query-on-exit-flag): New function that's an + alias to set-process-query-on-exit-flag or process-kill-without-query. + (pop3-open-server): Use it. + +2010-09-04 Lars Magne Ingebrigtsen <[email protected]> + + * mail-source.el (mail-source-delete-crash-box): Always move the crash + box to the Incoming file. Fixes mistake in previous checkin. + + * pop3.el (pop3-send-streaming-command): Off-by-one error on the + request loop (for debugging purposes) removed. + + * nnml.el (nnml-save-nov): Message around nnml-save-nov so that the + culprit is more visible. + (nnml-save-incremental-nov, nnml-open-incremental-nov) + (nnml-add-incremental-nov): New functions to do "incremental" nov + updates, where we just append to the end of the existing nov files + without reading/writing them in full. + + * mail-source.el (mail-source-delete-crash-box): Really only check the + incoming files once in a while. + + * pop3.el (pop3-streaming-movemail): Always close the pop3 connection. + + * mail-source.el (mail-source-delete-crash-box): Only check the + incoming files for deletion once per day to save a lot of file + accesses. + + * pop3.el (pop3-logon): Fix up unbound variable typo. + + * mail-source.el (pop3-streaming-movemail): Autoload. + + * pop3.el (pop3-streaming-movemail): + Respect pop3-leave-mail-on-server. + + * mail-source.el (mail-source-fetch-pop): Use streaming pop3 + retrieval. + + * pop3.el (pop3-process-filter): Remove unused function. + (pop3-streaming-movemail, pop3-send-streaming-command) + (pop3-wait-for-messages, pop3-write-to-file) + (pop3-number-of-responses): New functions for streaming pop3 + retrieval. + + * gnus-start.el (gnus-get-unread-articles): Protect against groups that + come from no known methods. + (gnus-make-hashtable-from-newsrc-alist): Remove duplicates from .newsrc + list. + + * pop3.el (pop3-display-message-size-flag): Remove -- everybody wants + message sizes. + (pop3-movemail): Use erase-buffer instead of looping and deleting + regions, which seems rather odd. + + * gnus-agent.el (gnus-agent-load-local): Only read the agent.lib/local + file once per `g' run. + + * nnmh.el (nnmh-request-list-1): Output active lines also for empty + directories. This makes the draft queue directory work. + + * gnus-start.el (gnus-get-unread-articles): Rewrite the way we request + data from the backends, so that we only request the list of groups from + each method once. This should speed things up considerably. + + * nnvirtual.el (nnvirtual-request-list): Remove function so that we can + detect that it's not implemented. + + * nnmh.el (nnmh-request-list-1): Fix up the recursion behavior so that + we actually do recurse down into the tree, but don't stat all leaf + nodes. + + * gnus-html.el (gnus-html-show-images): If there are no images to show, + then say so instead of bugging out. + + * gnus-agent.el (gnus-agent-load-alist): Check whether the agentview + files exist before trying to read them. + + * gnus-html.el (gnus-html-wash-tags): Remove even more white space + around <pre_int>. + + * gnus-art.el (gnus-article-copy-string): Say what data we copied. + + * nnmh.el (nnmh-request-list-1): Optimize for speed. + +2010-09-03 Lars Magne Ingebrigtsen <[email protected]> + + * mm-util.el (mm-image-load-path): Just return the image directories, + not all directories in the path in addition to the image directories. + (mm-image-load-path): Maintain a cache of the image directories so that + the `g' command in Gnus doesn't have to stat dozens of directories each + time. + + * gnus-html.el (gnus-html-put-image): Allow images to be removed. + (gnus-html-wash-tags): Add a new `i' command to insert images. + (gnus-html-insert-image): New command and keystroke. + (gnus-html-redisplay-with-images): New command and keystroke. + (gnus-html-show-images): Rename command. + (gnus-html-wash-tags): Remove more white space before <pre_int> image + spacers. + (gnus-html-wash-tags): Decode entities at the end, so that entities + inside the tags don't mess up the rest of the "parsing". + + * gnus-agent.el (gnus-agent-auto-agentize-methods): Change the default + so that nnimap methods aren't agentized by default. There's apparently + many problems related to agent/imap behaviour. + + * gnus-art.el (gnus-article-copy-string): New command and key binding. + + * gnus-html.el: Doc fix. + +2010-09-03 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-html-put-image): Use gnus-graphic-display-p, + glyph-width and glyph-height instead of display-graphic-p and + image-size; make avoidance of displaying small images work for XEmacs. + + * gnus-util.el (gnus-graphic-display-p): Use device-on-window-system-p + for XEmacs. + + * gnus-ems.el (gnus-set-process-plist, gnus-process-plist): Change name + of symbol that holds plist data. + (gnus-process-plist): Remove plist of process after getting it. + +2010-09-02 Lars Magne Ingebrigtsen <[email protected]> + + * message.el (message-generate-hashcash): Change default to + 'opportunistic if hashcash is installed. + + * gnus-html.el (gnus-html-rescale-image): Fix up typo in rescaling. + (gnus-html-put-image): Only call image-size once, since it's somewhat + time-consuming on remote X servers. + +2010-09-02 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-article-html): Make work buffer multibyte for + decoded contents. + (gnus-html-put-image, gnus-html-rescale-image): Pass `file' argument. + +2010-09-02 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-group.el (gnus-group-line-format): Remove %O (moderated) from + group line format, since it isn't very interesting. + + * gnus-agent.el (gnus-agent-short-article), + (gnus-agent-long-article): Increase values for these two variables, + since most people are likely to have more network connection and + storage than before. + + * gnus.el (gnus-refer-article-method): Change default to 'current. + When referring an article, the common behaviour is to refer it from the + current select method, not the native select method. The chances of + the native select method having the message in question is rather slim + these days. + + * gnus-sum.el (gnus-auto-select-subject): Change default to + `unseen-or-unread'. I think it's likely that most people want to + select an unseen article over a previously seen, but unread one. + + * gnus.el (gnus-mode-non-string-length): Change default to 30. nil + means that in the article buffer none of the minor mode elements will + be shown, usually, and this is not desirable in most cases. + + * gnus-sum.el (gnus-summary-goto-unread): Change default to nil, so + that commands like `d' (and the like) go to the next line in the + buffer, instead of the next unread article. I think this is the + behaviour that is most natural for most users. + (gnus-single-article-buffer): Change default to nil, so that people can + have as many article buffers open as they have summary buffer. I think + this is the most natural way for the groups to behave. + + * message.el (message-generate-new-buffers): Change default to + `unsent', so that all new message buffers start their names with the + string "*unsent", and it's easier to find the buffers if you move from + them. + +2010-09-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-wash-tags): Don't show images that are really + small. They're probably tracking images. + (gnus-html-wash-tags): Remove all <pre_int> place holders. + (gnus-html-rescale-image): Yet another try at getting the image sizing + right. + + * nntp.el (nntp-request-set-mark): Refuse to do marks if + nntp-marks-file-name is nil. + +2010-09-01 Teodor Zlatanov <[email protected]> + + * gnus-html.el (gnus-html-wash-tags) + (gnus-html-schedule-image-fetching, gnus-html-image-url-blocked-p): + Better logging. + +2010-09-01 Lars Magne Ingebrigtsen <[email protected]> + + * nndoc.el (nndoc-type-alist): Add a new type for Google digests. + + * gnus-html.el (gnus-html-wash-tags): Check the value of + gnus-blocked-images in the summary buffer. + +2010-09-01 Teodor Zlatanov <[email protected]> + + * gnus-html.el (gnus-html-image-url-blocked-p): Doc fix. + +2010-09-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-wash-tags): "A" is also used for links, just + like "a", it seems like. + (gnus-html-image-url-blocked-p): Take a parameter for blocked-images + since it needs to be picked from the correct buffer. + + * nnwfm.el: Remove. + + * nnlistserv.el: Remove. + +2010-09-01 Teodor Zlatanov <[email protected]> + + * gnus-html.el (gnus-html-image-url-blocked-p): New function. + (gnus-html-prefetch-images, gnus-html-wash-tags): Use it. + +2010-09-01 Lars Magne Ingebrigtsen <[email protected]> + + * nnkiboze.el: Remove. + + * nndb.el: Remove. + + * gnus-html.el (gnus-html-put-image): Use the deleted text as the image + alt text. + (gnus-html-rescale-image): Try to get the rescaling logic right for + images that are just wide and not tall. + + * gnus.el (gnus-string-or): Fix the syntax to not use eval or + overshadow variable bindings. + +2010-09-01 Teodor Zlatanov <[email protected]> + + * gnus-html.el (gnus-html-wash-tags) + (gnus-html-schedule-image-fetching, gnus-html-prefetch-images): + Add extra logging. + +2010-09-01 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el (gnus-html-wash-tags): Delete the IMG_ALT region. + (gnus-max-image-proportion): New variable. + (gnus-html-rescale-image): New function. + (gnus-html-put-image): Rescale images. + +2010-09-01 Stefan Monnier <[email protected]> + + Fix up some byte-compiler warnings. + * gnus.el (gnus-group-find-parameter, gnus-kill-save-kill-buffer): + * gnus-cite.el (gnus-article-highlight-citation, gnus-dissect-cited-text) + (gnus-article-fill-cited-article, gnus-article-hide-citation) + (gnus-article-hide-citation-in-followups, gnus-cite-toggle): + * gnus-group.el (gnus-group-set-mode-line, gnus-group-quit) + (gnus-group-set-info, gnus-add-mark): Use with-current-buffer. + (gnus-group-update-group): Use save-excursion and with-current-buffer. + +2010-09-01 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-article-html): Decode contents by charset. + +2010-09-01 Katsumi Yamaoka <[email protected]> + + * gnus-html.el (gnus-html-cache-directory, gnus-html-cache-size) + (gnus-html-frame-width, gnus-blocked-images) + * message.el (message-prune-recipient-rules): Add custom version. + * gnus-sum.el (gnus-auto-expirable-marks): Bump custom version. + + * gnus-ems.el (gnus-process-get, gnus-process-put): New compatibility + functions. + + * gnus-html.el (gnus-html-curl-sentinel): Replace process-get with + gnus-process-get. + +2010-08-31 Julien Danjou <[email protected]> (tiny change) + + * nnimap.el (nnimap-request-newgroups): Use nnimap-request-list-method + instead of lsub directly. + +2010-08-31 Lars Magne Ingebrigtsen <[email protected]> + + * nnwarchive.el: Remove. + + * gnus-soup.el: Remove. + + * nnsoup.el: Remove. + + * nnultimate.el: Remove. + + * gnus-html.el (gnus-blocked-images): New variable. + + * message.el (message-prune-recipients): New function. + (message-prune-recipient-rules): New variable. + + * gnus-cite.el (gnus-article-natural-long-line-p): New function to + guess whether a long line is natural text or not. + + * gnus-html.el (gnus-html-schedule-image-fetching): + Use gnus-process-plist and friends for compatibility. + +2010-08-31 Stefan Monnier <[email protected]> + + * gnus-html.el: Require packages that define macros used in this file. + (gnus-article-mouse-face): Declare to silence byte-compiler. + (gnus-html-curl-sentinel): Use with-current-buffer, inhibit-read-only, and + process-get. + (gnus-html-put-image): Use plist-get to avoid getf. + (gnus-html-prefetch-images): Use with-current-buffer. + +2010-08-31 Katsumi Yamaoka <[email protected]> + + * gnus-ems.el: Provide compatibility functions for + gnus-set-process-plist. + + * gnus-sum.el (gnus-summary-stop-at-end-of-message) + * gnus.el (gnus-valid-select-methods) + * message.el (message-send-mail-partially-limit) + * mm-decode.el (mm-text-html-renderer) + * mml.el (mml-insert-mime-headers-always) + * smiley.el (smiley-regexp-alist): Bump custom version. + +2010-08-31 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-html.el: require mm-url. + (gnus-html-wash-tags): Clarify the code a bit by renaming the variable + with the url to `url'. + (gnus-html-wash-tags): Support cid: URLs/images. + +2010-08-30 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-sum.el: As per discussion 3 years, 8 weeks, 3 days, 9 hours, 57 + minutes, 56 seconds ago on the ding list, remove the `w' and `i' + bindings, as they aren't useful at all. `w' is moved to `W w'. + + * gnus-move.el: Remove file, since it doesn't really work. + + * gnus-html.el (gnus-article-html): Tell w3m that the input is + UTF-8. This seems to fix problems with some German web feeds. + + * gnus.el (gnus-group-startup-message): Put the xpm version of the logo + at the top so that the proper colours are applied. + + * gnus-art.el (gnus-article-view-part): Doc fix. + + * gnus-html.el (gnus-html-put-image): Use gnus-create-image to be + XEmacs-compatible. + (gnus-html-put-image): Don't do images on non-graphic displays. + + * nnslashdot.el: Remove this unused backend. + + * gnus-undo.el (gnus-undo-register-1): Limit the undo actions to 100 + actions. + (gnus-undo-register-1): Revert last change. + + * gnus-group.el (gnus-group-completing-read): Protect against not + having completion-styles bound. + + * mml.el (mml-insert-mime-headers-always): Change the default to t, to + make broken recipients happier. + + * gnus-html.el (gnus-html-put-image): Use gnus-put-image. + + * gnus-ems.el (gnus-put-image): Have gnus-put-image take an optional + point parameter. + + * gnus-group.el (gnus-group-completing-read): Add 'substring to + completion-styles for group selection. + +2009-02-04 Andreas Schwab <[email protected]> + + * gnus-score.el (gnus-score-string): Fix regex for matching extra + headers and regexp-quote the match if necessary. + +2009-03-24 Miles Bader <[email protected]> + + * smiley.el (smiley-regexp-alist): Don't delete the semicolon before + the blinking smiley. + +2009-03-24 Simon Josefsson <[email protected]> + + * smiley.el (smiley-regexp-alist): Disallow ;;) from being treated as a + blink smiley. + +2010-08-29 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-start.el (gnus-dribble-read-file): Ensure that the directory + where the dribbel file lives exists. + + * message.el (message-send-mail-partially-limit): Change the default to + nil, since most people don't want this. + + * mm-url.el (mm-url-decode-entities): Also decode entities like + ㈒. + +2009-07-16 Kevin Ryde <[email protected]> (tiny change) + + * gnus-sum.el (gnus-summary-idna-message): + * nnrss.el (nnrss-normalize-date, nnrss-discover-feed): + Hyperlink urls in docstrings with URL `...'. + +2010-08-29 Adam Sjøgren <[email protected]> + + * gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image + functions. + +2010-08-29 Lars Magne Ingebrigtsen <[email protected]> + + * gnus-art.el (gnus-article-add-button): Take an optional parameter to + say what the mouseover text should be. + + * gnus-html.el (gnus-html-prefetch-images): Use the summary-local + version of the mm-w3m-safe-url-regexp variable to only download images + in the groups where we want that to happen. + + * gnus-sum.el (gnus-summary-stop-at-end-of-message): New variable. + + * gnus-art.el (gnus-article-beginning-of-window): Make into defun for + easier debugging. + (gnus-article-beginning-of-window): Add kludge to allow spacing past + big pictures in the article buffer. + + * mm-decode.el (mm-text-html-renderer): Default the html renderer to + gnus-article-html. + (mm-text-html-renderer): gnus-article-html needs curl in addition to + w3m. + + * gnus-html.el: Start a new super-simple HTML renderer based on w3m. + +2010-08-28 Lars Magne Ingebrigtsen <[email protected]> + + * gnus.el (gnus-valid-select-methods): Remove reference to nngoogle, + which doesn't exist. + + * message.el (message-inhibit-ecomplete): New variable to allow some + function to inhibit ecomplete address storage. + (message-resend): Disable ecomplete message storage when resending + messages. + + * nntp.el (nntp-async-kluge): Remove the Emacs 20.3-related kluge. + +2010-08-27 Katsumi Yamaoka <[email protected]> + + * gnus-sum.el (gnus-summary-move-article, gnus-summary-delete-article): + Save excursion while copying, moving, and deleting articles in order to + prevent the cursor from jumping to unforeseen place. + +2010-08-17 Glenn Morris <[email protected]> + + * gnus-sync.el: Require gnus components whose functions are used. + + * gnus-art.el (bookmark-make-record-function): + * gnus-sum.el (bookmark-yank-point, bookmark-current-bookmark): + Declare for compiler. + + * mm-url.el (mml-compute-boundary): Autoload. + +2010-08-15 Katsumi Yamaoka <[email protected]> + + * gnus-start.el (gnus-start-draft-setup): Move doc string forward. + +2010-08-14 Teodor Zlatanov <[email protected]> + + Typo fix "hoo4a" -> "hook". + + * gnus-sync.el (gnus-sync-install-hooks): Typo fix. + +2010-08-14 Glenn Morris <[email protected]> + + * gnus-sync.el (gnus-sync): Fix defgroup version. + +2010-08-13 Teodor Zlatanov <[email protected]> + + Doc fixes and keep unknown groups (ammended for nunion bug fix). + + * gnus-sync.el: Fix docs. + (gnus-sync-save): Keep unknown groups in `gnus-sync-newsrc-loader'. + (gnus-sync-read): Don't wipe `gnus-sync-newsrc-loader' after reading. + +2010-08-12 Teodor Zlatanov <[email protected]> + + Optimizations for gnus-sync.el. + + * gnus-sync.el: Add docs about gnus-sync-backend + possibilities. + (gnus-sync-save): Remove unnecessary message. + (gnus-sync-read): Optimize and show what groups were skipped. + +2010-08-12 Teodor Zlatanov <[email protected]> + + Minor bug fixes for gnus-sync.el. + + * gnus-sync.el (gnus-sync-unload-hook, gnus-sync-install-hooks): + Don't read the sync on get-new-news. + + * gnus-sync.el (gnus-sync-save): Define `variable' so the compiler is + quiet. + + * gnus-sync.el (gnus-sync-read): Use `gnus-sync-newsrc-offsets' + (fix typo). + +2010-07-30 Lawrence Mitchell <[email protected]> + + Make saving and restoring of hidden threads work with overlays. + Patch applied by Ted Zlatanov. + + * gnus-sum.el (gnus-hidden-threads-configuration) + (gnus-restore-hidden-threads-configuration): Update to deal with text + properties, rather than searching for a magic character. + +2010-08-12 Teodor Zlatanov <[email protected]> + + New gnus-sync.el library for synchronization of marks. + + * gnus-sync.el: New library for synchronization of marks. + + * gnus-util.el (gnus-grep-in-list): Move from gnus-registry.el and + renamed from `gnus-registry-grep-in-list'. + + * gnus-registry.el (gnus-registry-follow-group-p): + Use `gnus-grep-in-list'. + + * gnus-start.el (gnus-start-draft-setup): Make it interactive. + +2010-08-06 Katsumi Yamaoka <[email protected]> + + * rfc2047.el (rfc2047-encode): Use utf-8 as a last resort if + determining charset of text fails. + +2010-08-01 Katsumi Yamaoka <[email protected]> + + * nnmail.el (nnmail-get-new-mail-1): Revert. + + * nnml.el (nnml-active-number): Make sure names of newly created groups + in nnml-group-alist are encoded. + +2010-07-30 Katsumi Yamaoka <[email protected]> + + * nnmail.el (nnmail-get-new-mail-1): Encode group names possibly + containing non-ASCII characters in active file for nnml back end. + +2010-07-24 David Engster <[email protected]> + + * mml-smime.el (mml-smime-epg-verify): Also accept the older + x-pkcs7-signature MIME type as signature (RFC 2311, C.1). + +2010-07-21 Daiki Ueno <[email protected]> + + * mml.el (mml-parse-1): Collect "certfile" attributes in "<#secure>" + tag (Bug#6654). + +2010-07-20 Katsumi Yamaoka <[email protected]> + + * gnus-sum.el (gnus-summary-bookmark-make-record): Bookmark position in + the article buffer, not the summary buffer. + +2010-07-15 Katsumi Yamaoka <[email protected]> + + * gnus-sum.el (gnus-summary-bookmark-make-record): Make it work for + Emacs 23 as well. + +2010-07-13 Thierry Volpiatto <[email protected]> + + Allow C-w when setting a bookmark in a Gnus Article buffer (Bug#5975). + Patch applied by Karl Fogel. + + * gnus-sum.el (gnus-summary-bookmark-make-record): + Set `bookmark-yank-point' and `bookmark-current-buffer' to allow C-w. + +2010-07-13 Thierry Volpiatto <[email protected]> + + Allow bookmarks to be set from Gnus Article buffers (Bug #5975). + Patch applied (with minor tweaks) by Karl Fogel. Note this leaves + C-w still not working correctly from Article buffers; Thierry's + patch to fix that will be applied after this. + + * gnus-art.el (bookmark-make-record-function): New local variable. + + * gnus-sum.el (gnus-summary-bookmark-make-record): Allow setting from + article buffer. + (gnus-summary-bookmark-jump): Maybe jump to article buffer. + +2010-07-13 Karl Fogel <[email protected]> + + * gnus-sum.el (bookmark-make-record-default): Adjust declaration, based + on changes in bookmark.el. + +2010-06-22 Mark A. Hershberger <[email protected]> + + * mm-url.el (mm-url-encode-multipart-form-data): New function to handle + the *other* type of HTML form submission. + +2010-06-15 Michael Albinus <[email protected]> + + * auth-source.el (auth-source-pick): If choice does not contain a + questioned keyword, set the check to t. + +2010-06-12 Romain Francoise <[email protected]> + + * gnus-util.el (gnus-date-get-time): Move up before first use. + +2010-06-10 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-mime-buttonized-part-id): New internal variable. + (gnus-article-edit-part): Bind it to make last part that is substituted + or deleted visible. + (gnus-mime-display-single): Buttonize part of which id equals to + gnus-mime-buttonized-part-id. + +2010-06-10 Dan Christensen <[email protected]> + + * gnus-util.el (gnus-user-date): Use gnus-date-get-time. + (gnus-dd-mmm): Use gnus-date-get-time. + * gnus-sum.el (gnus-thread-latest-date): Use gnus-date-get-time and + simplify logic. + (gnus-summary-limit-to-age): Use gnus-date-get-time. + (gnus-sort-threads): Emit message if gnus-sort-threads-loop used. + +2010-06-08 Michael Albinus <[email protected]> + + * auth-source.el (top): Autoload `secrets-list-collections', + `secrets-create-item', `secrets-delete-item'. + (auth-sources): Fix tag string. + (auth-get-source, auth-source-retrieve, auth-source-create) + (auth-source-delete): New defuns. + (auth-source-pick): Rewrite in order to avoid 2 passes. + (auth-source-forget-user-or-password): New parameter USERNAME. + (auth-source-user-or-password): New parameters CREATE-MISSING and + DELETE-EXISTING. Retrieve password interactively, if needed. + +2010-06-07 Teemu Likonen <[email protected]> (tiny change) + + * gnus-agent.el (gnus-agent-expire-unagentized-dirs): Don't ask about + deleting unused directories when gnus-expert-user is t. + +2010-06-02 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-article-browse-delete-temp-files): Don't make query + for each temp file when gnus-article-browse-delete-temp is ask. + +2010-05-20 Kevin Ryde <[email protected]> + + * gnus-start.el (gnus-level-unsubscribed): Doc fix. (Bug#6206) + +2010-05-14 Katsumi Yamaoka <[email protected]> + + * gnus-sum.el (gnus-summary-save-article): Don't bother to re-fetch + article unless decoding article to be saved. + +2010-05-13 Katsumi Yamaoka <[email protected]> + + * mml1991.el (mml1991-mailcrypt-encrypt, mml1991-gpg-encrypt) + * mml2015.el (mml2015-gpg-encrypt): Disable multibyte in buffers + generated within the mm-with-unibyte-current-buffer macro. + +2010-05-13 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-bind-safe-url-regexp): Bind mm-w3m-safe-url-regexp + to nil when we're in a mml-preview buffer and no group is selected. + +2010-05-12 Andreas Seltenreich <[email protected]> + + * gnus-sum.el (gnus-summary-read-group-1): Don't jump to next group + when catching the `C-g'. Reported by "Leo". + +2010-05-12 Katsumi Yamaoka <[email protected]> + + * message.el (message-forward-make-body-plain) + (message-forward-make-body-mml): Use mm-multibyte-string-p instead of + multibyte-string-p. + +2010-05-12 Katsumi Yamaoka <[email protected]> + + * message.el (message-forward-make-body-mml): Assume original message + is multibyte string; error on unibyte. + (message-forward-make-body-plain): Ditto; don't add excessive newline + in body end. + +2010-05-11 Andreas Seltenreich <[email protected]> + + * gnus-sum.el (gnus-summary-kill-thread): Use gnus-summary-mark-article + instead of g-s-m-a-as-unread to set the expirable mark. (Bug#5284) + +2010-05-11 Katsumi Yamaoka <[email protected]> + + * mm-extern.el (mm-extern-url): Don't use + mm-with-unibyte-current-buffer. + (mm-extern-cache-contents): Use with-current-buffer instead of + save-excursion + set-buffer. + +2010-05-10 Katsumi Yamaoka <[email protected]> + + * mm-util.el (mm-emacs-mule): Remove. + +2010-05-10 Andreas Seltenreich <[email protected]> + + * gnus-sum.el (gnus-summary-mode): Don't make minor-mode-alist + buffer-local as it's incompatible with Stefan Monnier's 2010-05-03 + change. + +2010-05-10 Katsumi Yamaoka <[email protected]> + + * mm-util.el (mm-with-unibyte-current-buffer): Redefine it so as not to + bind the default value of enable-multibyte-characters to nil. + +2010-05-10 Katsumi Yamaoka <[email protected]> + + * message.el (message-forward-make-body-plain) + (message-forward-make-body-mml): + Don't use mm-with-unibyte-current-buffer. + +2010-05-07 Christian von Roques <[email protected]> (tiny change) + + * mml2015.el (mml2015-epg-find-usable-key): Skip disabled key + (Bug#5592). + +2010-05-07 Julien Danjou <[email protected]> + + * gnus-art.el (gnus-mime-pipe-part): Add optional argument `cmd'; pass + it to mm-pipe-part. + + * mm-decode.el (mm-pipe-part): Add optional argument `cmd'; use it if + it is given. + +2010-05-07 Katsumi Yamaoka <[email protected]> + + * nnweb.el (nnweb-gmane-search) + * yenc.el (yenc-decode-region): Don't run set-buffer-multibyte for + XEmacs. + + * gnus-art.el (gnus-article-browse-html-parts) + * gnus-group.el (gnus-read-ephemeral-gmane-group) + (gnus-read-ephemeral-bug-grou): Use mm-make-temp-file instead of + make-temp-file. + + * gnus-dired.el (gnus-dired-mode): Bind gnus-dired-mode-hook, + gnus-dired-mode-on-hook and gnus-dired-mode-off-hook for XEmacs when + compiling. + + * gnus-ml.el (gnus-mailing-list-mode): Bind gnus-mailing-list-mode-hook, + gnus-mailing-list-mode-on-hook and gnus-mailing-list-mode-off-hook for + XEmacs when compiling. + + * gnus-salt.el (gnus-pick-mode): Bind gnus-pick-mode-on-hook and + gnus-pick-mode-off-hook for XEmacs when compiling. + (gnus-binary-mode): Bind gnus-binary-mode-on-hook and + gnus-binary-mode-off-hook for XEmacs when compiling. + + * gnus-sum.el (gnus-summary-limit-strange-charsets-predicate): + Return nil if char-charset is not available. + + * sieve-manage.el (sieve-manage-disable-multibyte): Redefine it as a + macro. + + * mm-url.el (mm-url-form-encode-xwfu): Use mm-encode-coding-string + instead of encode-coding-string. + + * mm-util.el (mm-enable-multibyte, mm-disable-multibyte): Use (featurep + 'xemacs) instead of mm-emacs-mule to switch function definitions. + (mm-with-unibyte-current-buffer): Make it a progn macro for XEmacs. + +2010-05-06 Tommi Vainikainen <[email protected]> (tiny change) + + * mml-sec.el (mml-secure-message-sign): Fix cut and paste error. + +2010-05-06 Katsumi Yamaoka <[email protected]> + + * gnus-dired.el, gnus-draft.el, gnus-ml.el, gnus-salt.el, gnus-sum.el, + gnus-undo.el, mml.el: Require easy-mmode for XEmacs when compiling. + +2010-05-03 Juanma Barranquero <[email protected]> + + * mm-util.el (mm-decompress-buffer): Use `delete-file'; + alias `jka-compr-delete-temp-file' no longer exists. + +2010-05-03 Stefan Monnier <[email protected]> + + Use define-minor-mode in Gnus where applicable. + * mml.el (mml-mode): Use define-minor-mode. + * gnus-undo.el (gnus-undo-mode-map): Initialize in declaration. + (gnus-undo-mode): Use define-minor-mode. + * gnus-sum.el (gnus-dead-summary-mode-map): Initialize in declaration. + (gnus-dead-summary-mode): Use define-minor-mode. + * gnus-salt.el (gnus-pick-mode-map, gnus-binary-mode-map): + Initialize in declaration. + (gnus-pick-mode, gnus-binary-mode): Use define-minor-mode. + * gnus-ml.el (gnus-mailing-list-mode-map): Initialize in declaration. + (gnus-mailing-list-mode): Use define-minor-mode. + * gnus-draft.el (gnus-draft-mode-map): Initialize in declaration. + (gnus-draft-mode): Use define-minor-mode. + * gnus-dired.el (gnus-dired-mode-map): Initialize in declaration. + (gnus-dired-mode): Use define-minor-mode. + +2010-05-01 Andreas Seltenreich <[email protected]> + + * mml.el (mml-generate-mime-1,mml-compute-boundary-1): Update 'mml + handles on recursive mml-to-mime translation and check them for + boundary delimiter collisions. Reported by Greg Troxel. + +2010-04-27 Katsumi Yamaoka <[email protected]> + + * gnus-util.el: Don't load tm and apel XEmacs packages when compiling. + +2010-04-23 Stefan Monnier <[email protected]> + + * mm-util.el (mm-find-buffer-file-coding-system): + * yenc.el (yenc-decode-region): Don't let-bind a read-only variable. + 2010-04-22 Andreas Seltenreich <[email protected]> * message.el (message-generate-headers): Record insertion of optional @@ -26,22 +4903,86 @@ * nnir.el: Don't mention CVS. +2010-04-14 Stefan Monnier <[email protected]> + + * gnus-sum.el (gnus-summary-bookmark-make-record): + Add `location' field. + +2010-04-12 Stefan Monnier <[email protected]> + + * gnus-sum.el: Add bookmark declarations to silence the compiler. + (gnus-mark-xrefs-as-read, gnus-summary-limit-to-bodies): + Use with-current-buffer to silence the byte-compiler. + (gnus-summary-bookmark-make-record): Use derived-mode-p and don't + bother to require `gnus'. + (gnus-summary-bookmark-jump): Don't forget to autoload. Simplify. + +2010-04-12 Thierry Volpiatto <[email protected]> + + * gnus-sum.el (gnus-summary-bookmark-make-record) + (gnus-summary-bookmark-jump): New functions. + (gnus-summary-mode): Setup bookmark support. + 2010-04-01 Andreas Schwab <[email protected]> * mm-uu.el (mm-uu-pgp-signed-extract-1): Use buffer-file-coding-system if set. -2010-03-29 Katsumi Yamaoka <[email protected]> +2010-03-31 Katsumi Yamaoka <[email protected]> - * mm-decode.el (mm-add-meta-html-tag): Fix regexp matching meta tag. + * gnus-art.el (gnus-article-browse-html-save-cid-content): Rename from + gnus-article-browse-html-save-cid-image; make it work recursively for + forwarded messages as well. + (gnus-article-browse-html-parts): Work when prefix arg is given. + (gnus-article-browse-html-article): Doc fix. -2010-03-27 Chong Yidong <[email protected]> +2010-03-30 Chong Yidong <[email protected]> * message.el (message-default-mail-headers): (message-default-headers): Carry the value mail-default-headers over into message-default-mail-headers, rather than message-default-headers. -2010-03-22 Juanma Barranquero <[email protected]> +2010-03-30 Martin Stjernholm <[email protected]> + + * mm-decode.el (mm-add-meta-html-tag): Add option to override the + charset. + + * gnus-art.el (gnus-article-browse-html-parts): Force the correct + charset into the <meta> tag when the article is encoded to utf-8. + +2010-03-30 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (gnus-article-browse-delete-temp-files): + Delete directories as well. + (gnus-article-browse-html-parts): Work for images that do not specify + file names; delete temp directory when quitting; insert header at the + right place; use file: scheme for image files. + +2010-03-30 Eric Schulte <[email protected]> + + * gnus-art.el (gnus-article-browse-html-save-cid-image): New function. + (gnus-article-browse-html-parts): Use it to make temporary cid image + files in addition to html file so that browser may display them. + +2010-03-29 Katsumi Yamaoka <[email protected]> + + * mm-decode.el (mm-add-meta-html-tag): Fix regexp matching meta tag. + +2010-03-29 Teodor Zlatanov <[email protected]> + + * auth-source.el (auth-source-pick): Fix for non-secrets specifier. + +2010-03-27 Teodor Zlatanov <[email protected]> + + * auth-source.el (auth-sources): Change default to be simpler. + Explain about Secret Service API sources. Improve Customize options. + (auth-source-pick): Change to accept any number of search parameters. + Implement fallbacks iteratively, not recursively. Add scoring on the + second pass and sort by score. Call Secret Service API when needed. + (auth-source-user-or-password): Use it. Call Secret Service API + directly when needed to get the user name and the password. + +2010-03-24 Juanma Barranquero <[email protected]> * message.el (message-interactive): Doc fix. (message-qmail-inject-args): Reflow. @@ -49,6 +4990,199 @@ * smiley.el (smiley-buffer): Fix typo in docstring. +2010-03-24 Glenn Morris <[email protected]> + + * mail-source.el (gnus-message): Declare. + (mail-source-delete-old-incoming): Require gnus-util. + +2010-03-23 Katsumi Yamaoka <[email protected]> + + * gnus-art.el (canlock-verify): Autoload it for Emacs 21. + + * message.el (ecomplete-setup): Autoload it for Emacs <23. + + * mml-sec.el (mml-secure-cache-passphrase): Default to t that is + password-cache's default if it is not bound. + (mml-secure-passphrase-cache-expiry): Default to 16 that is + password-cache-expiry's default if it is not bound. + + * pop3.el (pop3-list): Don't use 3rd arg of `split-string' which is not + available in Emacs 21. + +2010-03-23 Teodor Zlatanov <[email protected]> + + * auth-source.el (auth-sources): Fix up definition so extra parameters + are always inline. + +2010-03-22 Martin Stjernholm <[email protected]> + + * nnimap.el (nnimap-verify-uidvalidity): Fix bug where uidvalidity + wasn't updated after mismatch. Clear cached mailbox info correctly + when uidvalidity changes. + (nnimap-group-prefixed-name): New function to avoid some code + duplication. + (nnimap-verify-uidvalidity, nnimap-group-overview-filename) + (nnimap-request-group): Use it. + (nnimap-retrieve-groups, nnimap-verify-uidvalidity) + (nnimap-update-unseen): Significantly improved speed of Gnus startup + with many imap folders. This is done by caching the group status from + the imap server persistently in a group parameter `imap-status'. (This + was cached before too if `nnimap-retrieve-groups-asynchronous' was set, + but not persistently, so every Gnus startup was still very slow.) + +2010-03-20 Teodor Zlatanov <[email protected]> + + * auth-source.el: Set up autoloads. Bump to 23.2 because of the + secrets.el dependency. + (auth-sources): Add optional user name. Add secrets.el configuration + choice (unused right now). + +2010-03-20 Teodor Zlatanov <[email protected]> + + * gnus-sum.el (gnus-summary-make-menu-bar): + Let `gnus-registry-install-shortcuts' fill in the functions. + + * gnus-registry.el (gnus-summary-misc-menu): Declare to avoid + warnings. + (gnus-registry-misc-menus): Variable to hold registry mark menus. + (gnus-registry-install-shortcuts): Populate and use it in a + `gnus-summary-menu-hook' lambda, under "Gnus"->"Registry Marks". + +2010-03-20 Martin Stjernholm <[email protected]> + + * nnimap.el (nnimap-decode-group-name, nnimap-encode-group-name): + In-place substitutions for the group name encoding/decoding. + (nnimap-find-minmax-uid, nnimap-possibly-change-group) + (nnimap-retrieve-headers-progress, nnimap-possibly-change-group) + (nnimap-retrieve-headers-progress, nnimap-request-article-part) + (nnimap-update-unseen, nnimap-request-list) + (nnimap-retrieve-groups, nnimap-request-update-info-internal) + (nnimap-request-set-mark, nnimap-split-to-groups) + (nnimap-split-articles, nnimap-request-newgroups) + (nnimap-request-create-group, nnimap-request-accept-article) + (nnimap-request-delete-group, nnimap-request-rename-group) + (nnimap-acl-get, nnimap-acl-edit): Use them. Replace `mbx' with + `encoded-mbx' for consistency. + (nnimap-close-group): Call `imap-current-mailbox' instead of using the + variable `imap-current-mailbox'. + + * gnus-agent.el (gnus-agent-fetch-articles, gnus-agent-fetch-headers) + (gnus-agent-regenerate-group): Use `gnus-agent-decoded-group-name'. + +2010-03-20 Bojan Petrovic <[email protected]> + + * pop3.el (pop3-display-message-size-flag): Display message size byte + counts during POP3 download. + (pop3-movemail): Use it. + (pop3-list): Implement listing of available messages. + +2010-03-20 Mark Triggs <[email protected]> (tiny change) + + * nnir.el (nnir-get-article-nov-override-function): New function to + override the normal NOV retrieval. + (nnir-retrieve-headers): Use it. + +2010-03-19 Michael Albinus <[email protected]> + + * auth-source.el (netrc-machine-user-or-password): Autoload. + +2010-03-19 Glenn Morris <[email protected]> + + Stop message.el from loading about 40 libraries it doesn't always need. + The general approach is to autoload rather than require, and to + require in the specific functions rather than the file. (Bug#5642) + + * gmm-utils.el: Don't require wid-edit. + (widget-create-child-value, widget-convert, widget-default-get): + Autoload. + + * gnus-util.el: Don't require time-date, netrc. + (message-fetch-field, gnus-group-name-decode): Declare rather than + autoloading. + (gnus-fetch-field): Require message. + (gnus-decode-newsgroups): Require gnus-group. + + * ietf-drums.el: Don't require time-date. + + * message.el: Don't require hashcash, canlock, ecomplete. + Do require mail-utils. Require nnheader only when compiling. + (smtpmail-default-smtp-server): Remove declaration. + (message-send-mail-function): Check smtpmail-default-smtp-server + is bound rather than requiring smtpmail. + (message-auto-save-directory, message-insert-signature): + Use expand-file-name rather than nnheader-concat. + (nnheader-insert-file-contents): Autoload. + (hashcash-wait-async): Declare. + (message-send-mail): Only call gnus-setup-posting-charset if + gnus-group-posting-charset-alist is bound. Require hashcash if needed. + (message-send-mail-with-sendmail): Require sendmail. + (canlock-password, canlock-password-for-verify): Declare. + (message-canlock-password): Require canlock. + (nnheader-get-report): Autoload. + (gnus-setup-posting-charset): Declare. + (message-send-news): Require gnus-msg. + (message-make-references, message-make-in-reply-to): Use mail-header-id + rather than the alias mail-header-message-id. + (ecomplete-add-item, ecomplete-save): Declare. + (message-put-addresses-in-ecomplete): Require ecomplete. + (ecomplete-display-matches): Autoload. + + * mm-decode.el: Don't require mailcap, gnus-util. + (gnus-map-function, gnus-replace-in-string, gnus-read-shell-command) + (message-fetch-field, mailcap-parse-mailcaps, mailcap-mime-info): + Autoload. + (mailcap-mime-extensions): Declare. + + * mm-encode.el: Don't require mailcap. + (mailcap-extension-to-mime): Autoload. + + * mml-sec.el: Don't require password-cache. + + * mml.el (gnus-setup-posting-charset): Declare rather than autoload. + (mailcap-parse-mimetypes, mailcap-mime-types): Declare. + (mml-minibuffer-read-type): Require mailcap. + (mml-preview): Require gnus-msg. + + * mml1991.el: Require password-cache. + (password-cache-expiry): Remove declaration. + + * mml2015.el: Require password-cache. + (password-cache-expiry): Remove declaration. + + * nneething.el (mailcap): Require mailcap. + + * nnheader.el (declare-function): Add compatibility stub. + (message-remove-header): Declare rather than autoload. + (nnheader-replace-header): Require message. + + * nnimap.el (declare-function): Add compatibility stub. + (netrc-parse, netrc-machine-user-or-password): Declare. + (nnimap-open-connection): Require netrc. + + * nntp.el (declare-function): Add compatibility stub. + (netrc-parse, netrc-machine, netrc-get): Declare. + (nntp-send-authinfo): Require netrc. + + * rfc2047.el: Don't require qp. + (quoted-printable-encode-region, quoted-printable-decode-string): + Autoload. + + * sieve-mode.el: Don't require easymenu. + (easy-menu-add-item): Autoload it. + + * spam-stat.el (time-to-number-of-days): Autoload it. + +2010-03-17 Kevin Ryde <[email protected]> + + * mml.el (mml-read-tag): Unquote values with `read' to reverse + prin1 in mml-insert-tag (just stripping the quotes gave wrong + value if any backslash escapes). + +2010-03-15 Katsumi Yamaoka <[email protected]> + + * mm-util.el (mm-charset-to-coding-system): Use coding-system-from-name + if it is available. (bug#5647) + 2010-02-26 Glenn Morris <[email protected]> * message.el (message-send-mail-function): Change the default, so that @@ -115,8 +5249,8 @@ 2010-01-01 Chong Yidong <[email protected]> - * message.el (message-exchange-point-and-mark): Call - exchange-point-and-mark with an argument rather than setting + * message.el (message-exchange-point-and-mark): + Call exchange-point-and-mark with an argument rather than setting mark-active by hand (Bug#5175). 2009-12-18 Katsumi Yamaoka <[email protected]> @@ -710,9 +5844,9 @@ * legacy-gnus-agent.el (gnus-agent-unlist-expire-days): Don't use cadar. - * sieve-manage.el (sieve-manage-starttls-p): Renamed from + * sieve-manage.el (sieve-manage-starttls-p): Rename from imap-starttls-p. - (sieve-manage-starttls-open): Renamed from imap-starttls-open. + (sieve-manage-starttls-open): Rename from imap-starttls-open. 2008-12-22 Reiner Steib <[email protected]> @@ -739,8 +5873,8 @@ 2008-12-21 Reiner Steib <[email protected]> - * gnus-start.el (gnus-before-startup-hook): Fix doc string. Reported - by Stephen Berman <[email protected]>. + * gnus-start.el (gnus-before-startup-hook): Fix doc string. + Reported by Stephen Berman <[email protected]>. 2008-12-18 Katsumi Yamaoka <[email protected]> @@ -922,7 +6056,7 @@ 2008-09-25 Teodor Zlatanov <[email protected]> - * message.el (message-confirm-send): Fixed variable documentation to + * message.el (message-confirm-send): Fix variable documentation to avoid the "y/n" wording. 2008-09-25 Francis Litterio <[email protected]> (tiny change) @@ -1056,8 +6190,8 @@ 2008-07-22 Katsumi Yamaoka <[email protected]> - * gnus-art.el (gnus-summary-save-in-pipe): Consider - gnus-save-all-headers. + * gnus-art.el (gnus-summary-save-in-pipe): + Consider gnus-save-all-headers. 2008-07-21 Dan Nicolaescu <[email protected]> @@ -1277,16 +6411,16 @@ * nnheader.el (nnheader-read-timeout): Change the default timeout from 0.1 seconds to 0.01 seconds. This will make nntp and pop3 article - retrieval faster in some cases, but might make CPU usage larger. If - this has any bad side effects, we might revert this change. + retrieval faster in some cases, but might make CPU usage larger. + If this has any bad side effects, we might revert this change. * pop3.el (pop3-movemail): Change the sit-for from 0.1 to 0.01, which seems to make mail retrieval much, much faster. (pop3-movemail): Use nnheader-accept-process-output instead of sleeping unconditionally. - * gnus-draft.el (gnus-group-send-queue): Bind - message-send-mail-partially-limit to nil to avoid being prompted. + * gnus-draft.el (gnus-group-send-queue): + Bind message-send-mail-partially-limit to nil to avoid being prompted. 2008-05-16 Reiner Steib <[email protected]> @@ -1319,7 +6453,7 @@ * nnimap.el: Autoload `auth-source-user-or-password'. (nnimap-open-connection): Use it. - * auth-source.el: Added docs on using with url-auth. Import gnus-util + * auth-source.el: Add docs on using with url-auth. Import gnus-util for the gnus-message function. (auth-source-user-or-password): Use it. @@ -1462,7 +6596,7 @@ 2008-04-09 Teodor Zlatanov <[email protected]> - * auth-source.el: Added docs. + * auth-source.el: Add docs. (auth-sources): Modify format to support server. (auth-source-pick, auth-source-user-or-password) (auth-source-user-or-password-imap) @@ -1641,8 +6775,8 @@ 2008-03-17 Teodor Zlatanov <[email protected]> - * gnus-registry.el (gnus-registry-split-fancy-with-parent): Eliminate - unnecessary duplicates from the match list. + * gnus-registry.el (gnus-registry-split-fancy-with-parent): + Eliminate unnecessary duplicates from the match list. 2008-03-17 Katsumi Yamaoka <[email protected]> @@ -1668,13 +6802,13 @@ 2008-03-13 Teodor Zlatanov <[email protected]> - * auth-source.el (auth-sources): Renamed from auth-source-choices. + * auth-source.el (auth-sources): Rename from auth-source-choices. (auth-source-pick): Use it. 2008-03-12 Teodor Zlatanov <[email protected]> * auth-source.el (auth-source-protocols) - (auth-source-protocols-customize, auth-source-choices): Added and + (auth-source-protocols-customize, auth-source-choices): Add and modified variable customizations and defaults. (auth-source-pick, auth-source-user-or-password) (auth-source-protocol-defaults, auth-source-user-or-password-imap) @@ -1698,8 +6832,8 @@ nntp-with-open-group macro. (nntp-with-open-group): Use the function, so it's easier to debug. Add indentation and debugging info. - (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet): Recommend - the use of the netcat alternatives. + (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet): + Recommend the use of the netcat alternatives. * rfc2047.el (rfc2047-decode-string): Don't use `m'. Avoid mm-string-as-multibyte as well. @@ -1805,12 +6939,12 @@ 2008-03-04 Teodor Zlatanov <[email protected]> - * gnus-registry.el (gnus-registry-user-format-function-M): Add - formatting function. + * gnus-registry.el (gnus-registry-user-format-function-M): + Add formatting function. 2008-03-03 Teodor Zlatanov <[email protected]> - * gnus-registry.el (gnus-registry-marks): Changed format to be nicer + * gnus-registry.el (gnus-registry-marks): Change format to be nicer with plists. (gnus-registry-do-marks, gnus-registry-install-shortcuts-and-menus): Use new format. @@ -1842,8 +6976,8 @@ * mml.el (mml-menu): Improve help entries. Move Sign/Encrypt Part. (mml-dnd-attach-options): Fix typo in custom choice. - * gnus-group.el (gnus-group-read-ephemeral-gmane-group): Change - nndoc-article-type to mbox. + * gnus-group.el (gnus-group-read-ephemeral-gmane-group): + Change nndoc-article-type to mbox. (gnus-group-read-ephemeral-gmane-group-url): Support permalink. * mm-decode.el (mm-text-html-renderer): Prefer w3m over w3. Fall back @@ -1907,14 +7041,14 @@ (nnmairix-last-server, nnmairix-current-server): Defvar them. (nnmairix-goto-original-article): Defvar gnus-registry-install and autoload gnus-registry-fetch-group when compiling. - (nnmairix-request-group-with-article-number-correction): Remove - unreferenced argument passed to nnmairix-call-backend. + (nnmairix-request-group-with-article-number-correction): + Remove unreferenced argument passed to nnmairix-call-backend. 2008-02-27 Reiner Steib <[email protected]> * mm-uu.el (mm-uu-type-alist): Fix message-marks non-hide arguments. - (mm-uu-extract): Improve face for low color ttys. Reported by Sascha - Wilde. + (mm-uu-extract): Improve face for low color ttys. + Reported by Sascha Wilde. 2008-02-27 Glenn Morris <[email protected]> @@ -2105,8 +7239,8 @@ 2008-01-12 Reiner Steib <[email protected]> * gnus-sum.el (gnus-article-sort-by-random) - (gnus-thread-sort-by-random): Fix doc strings. Reported by + (gnus-thread-sort-by-random): Fix doc strings. + Reported by [email protected]. 2008-01-11 Katsumi Yamaoka <[email protected]> @@ -2118,13 +7252,13 @@ * gnus-art.el (gnus-article-read-summary-keys): Work for `C-h' on XEmacs. - (gnus-article-describe-key, gnus-article-describe-key-briefly): Protect - against non-character events. + (gnus-article-describe-key, gnus-article-describe-key-briefly): + Protect against non-character events. 2008-01-09 Reiner Steib <[email protected]> - * gnus-group.el (gnus-group-read-ephemeral-gmane-group-url): New - command. + * gnus-group.el (gnus-group-read-ephemeral-gmane-group-url): + New command. (gnus-group-read-ephemeral-gmane-group): Use optional argument RANGE instead of END. Change name of the temp file. (gnus-group-gmane-group-download-format): Add doc string. Make it @@ -2139,8 +7273,8 @@ continuation keys correctly in the echo area; describe bindings correctly when keys end with `C-h'. (gnus-article-read-summary-send-keys): New function. - (gnus-article-describe-key, gnus-article-describe-key-briefly): Work - for gnus-article-read-summary-send-keys; display continuation keys + (gnus-article-describe-key, gnus-article-describe-key-briefly): + Work for gnus-article-read-summary-send-keys; display continuation keys correctly in the echo area. (gnus-article-reply-with-original): Ignore prefix argument. (gnus-article-wide-reply-with-original): New function. @@ -2234,8 +7368,8 @@ 2007-12-14 Reiner Steib <[email protected]> - * gnus-sum.el (gnus-summary-prev-article): Fix doc string. Reported by - Christoph Conrad <[email protected]>. + * gnus-sum.el (gnus-summary-prev-article): Fix doc string. + Reported by Christoph Conrad <[email protected]>. 2007-12-14 Reiner Steib <[email protected]> @@ -2247,8 +7381,8 @@ * mm-decode.el (mm-add-meta-html-tag): New function. (mm-save-part-to-file, mm-pipe-part): Use it. - * gnus-art.el (gnus-article-browse-delete-temp-files): Use - gnus-y-or-n-p instead of y-or-n-p. + * gnus-art.el (gnus-article-browse-delete-temp-files): + Use gnus-y-or-n-p instead of y-or-n-p. (gnus-article-browse-html-parts): Work with message/external-body; use mm-add-meta-html-tag. @@ -2258,8 +7392,8 @@ * gnus-fun.el (gnus-display-x-face-in-from): Require gnus-art. - * gnus-int.el (gnus-server-opened, gnus-status-message): Move - definitions before use. + * gnus-int.el (gnus-server-opened, gnus-status-message): + Move definitions before use. * mm-decode.el: Require gnus-util. (mm-remove-part): Only call delete-annotation on XEmacs. @@ -2367,15 +7501,15 @@ 2007-12-06 Christian Plate <[email protected]> (tiny change) - * nnmaildir.el (nnmaildir-request-update-info): Improved performance. + * nnmaildir.el (nnmaildir-request-update-info): Improve performance. Call gnus-add-to-range ranges only once with a prepared article-list. 2007-12-06 Paul Jarc <[email protected]> * nnmaildir.el (nnmaildir-request-list, nnmaildir-retrieve-groups) (nnmaildir-request-group, nnmaildir-retrieve-headers): Escape spaces in - group names with backslashes. Reported by Tassilo Horn - <[email protected]>. + group names with backslashes. + Reported by Tassilo Horn <[email protected]>. 2007-12-06 Deepak Goel <[email protected]> @@ -2394,8 +7528,8 @@ 2007-12-05 Katsumi Yamaoka <[email protected]> * gnus-art.el (gnus-article-browse-html-parts): Add meta html tag to - specify charset to html source. Reported by Christoph Conrad - <[email protected]>. + specify charset to html source. + Reported by Christoph Conrad <[email protected]>. 2007-12-05 Katsumi Yamaoka <[email protected]> @@ -2419,8 +7553,8 @@ * gnus-group.el (gnus-group-highlight-line): Add FIXME. * gnus-dired.el: Reduce Gnus dependencies. - (gnus-ems, gnus-msg, gnus-util, message, mm-decode, mml): Don't - require. Use autoloads instead. + (gnus-ems, gnus-msg, gnus-util, message, mm-decode, mml): + Don't require. Use autoloads instead. (mml-attach-file, mm-default-file-encoding, mailcap-extension-to-mime) (mailcap-mime-info, mm-mailcap-command, ps-print-preprint) (message-buffers, gnus-setup-message, gnus-print-buffer): Autoload. @@ -2479,8 +7613,7 @@ * yenc.el (yenc-first-part-p, yenc-last-part-p): New functions. - * mm-uu.el (mm-uu-yenc-extract): Get the data from the original - buffer. + * mm-uu.el (mm-uu-yenc-extract): Get the data from the original buffer. 2007-12-02 Glenn Morris <[email protected]> @@ -2496,8 +7629,8 @@ * message.el (message-cite-prefix-regexp): Remove `-' and `+' to avoid matches on patches. - * gnus-art.el (gnus-article-browse-html-article): Mention - `mm-text-html-renderer' in the doc string. + * gnus-art.el (gnus-article-browse-html-article): + Mention `mm-text-html-renderer' in the doc string. * rfc2047.el (rfc2047-encode-max-chars): Refer to RFC 2047 in doc string. Add comments. @@ -2526,8 +7659,8 @@ (gnus-agent-method-p): Canonicalize server names by pushing their method through `gnus-method-to-server' using the no-cache argument. - * gnus-srvr.el (gnus-server-insert-server-line): Call - `gnus-method-to-server' with `no-cache' argument. + * gnus-srvr.el (gnus-server-insert-server-line): + Call `gnus-method-to-server' with `no-cache' argument. * gnus-agent.el (gnus-agent-toggle-plugged): Don't call gnus-agent-possibly-synchronize-flags as this should be called when the @@ -2769,12 +7902,12 @@ 2007-11-15 Katsumi Yamaoka <[email protected]> - * nntp.el (nntp-insert-buffer-substring, nntp-copy-to-buffer): New - macros. + * nntp.el (nntp-insert-buffer-substring, nntp-copy-to-buffer): + New macros. (nntp-wait-for, nntp-retrieve-articles, nntp-async-trigger) (nntp-retrieve-headers-with-xover): Use nntp-insert-buffer-substring to copy data from unibyte buffer to multibyte current buffer. - (nntp-retrieve-headers, nntp-retrieve-groups); Use nntp-copy-to-buffer + (nntp-retrieve-headers, nntp-retrieve-groups): Use nntp-copy-to-buffer to copy data from unibyte current buffer to multibyte buffer. (nntp-make-process-buffer): Make process buffer unibyte. @@ -2855,8 +7988,8 @@ 2007-10-29 Stefan Monnier <[email protected]> - * message.el (message-check-news-body-syntax): Avoid - mm-string-as-multibyte. + * message.el (message-check-news-body-syntax): + Avoid mm-string-as-multibyte. (message-hide-headers): Don't assume (point-min)==1. 2007-10-28 Reiner Steib <[email protected]> @@ -2887,8 +8020,8 @@ 2007-10-27 Reiner Steib <[email protected]> - * gnus-msg.el (gnus-message-setup-hook): Add - `message-remove-blank-cited-lines' to options. + * gnus-msg.el (gnus-message-setup-hook): + Add `message-remove-blank-cited-lines' to options. 2007-10-26 Reiner Steib <[email protected]> @@ -2960,8 +8093,8 @@ * gnus-group.el (gnus-group-suspend): Replace mapcar called for effect with dolist. - * gnus-registry.el (gnus-registry-split-fancy-with-parent): Replace - mapcar called for effect with dolist. + * gnus-registry.el (gnus-registry-split-fancy-with-parent): + Replace mapcar called for effect with dolist. * gnus-spec.el (gnus-correct-length): Make it simple and fast. @@ -2994,7 +8127,7 @@ * gnus-agent.el (gnus-agent-expire-group-1): The check for an unsorted overview buffer needed a catch to receive its throw. - (gnus-agent-flush-cache): Declared as interactive to make this function + (gnus-agent-flush-cache): Declare as interactive to make this function easier to use. 2007-10-20 Reiner Steib <[email protected]> @@ -3058,8 +8191,8 @@ * mm-decode.el (mm-possibly-verify-or-decrypt): Replace PARTS with the ones returned from the verify-function. - * mm-uu.el (mm-uu-pgp-signed-extract-1): Call - mml2015-extract-cleartext-signature if extraction failed. + * mm-uu.el (mm-uu-pgp-signed-extract-1): + Call mml2015-extract-cleartext-signature if extraction failed. 2007-10-07 Daiki Ueno <[email protected]> @@ -3235,7 +8368,7 @@ 2007-08-14 Tassilo Horn <[email protected]> - * gnus-art.el (gnus-sticky-article): Fixed problems described in + * gnus-art.el (gnus-sticky-article): Fix problems described in <[email protected]> on ding. Thanks to Katsumi. Don't perform gnus-configure-windows here; reuse existing sticky article buffer. @@ -3357,8 +8490,8 @@ 2007-07-23 Katsumi Yamaoka <[email protected]> - * gnus-sum.el (gnus-summary-move-article): Make - gnus-summary-respool-article work. + * gnus-sum.el (gnus-summary-move-article): + Make gnus-summary-respool-article work. 2007-07-21 Reiner Steib <[email protected]> @@ -3417,8 +8550,8 @@ nnmail-pathname-coding-system. (nnml-request-article): Pass server argument to nnml-find-group-number. - (nnml-request-create-group, nnml-active-number, nnml-save-marks): Pass - server argument to nnml-possibly-create-directory. + (nnml-request-create-group, nnml-active-number, nnml-save-marks): + Pass server argument to nnml-possibly-create-directory. (nnml-request-accept-article): Pass server argument to nnml-active-number and nnml-save-mail. (nnml-find-group-number): Pass server argument to nnml-find-id. @@ -3447,8 +8580,8 @@ 2007-07-18 Katsumi Yamaoka <[email protected]> - * gnus-agent.el (gnus-agent-save-active): Bind - nnheader-file-coding-system to gnus-agent-file-coding-system. + * gnus-agent.el (gnus-agent-save-active): + Bind nnheader-file-coding-system to gnus-agent-file-coding-system. * gnus-cache.el (gnus-cache-save-buffers) (gnus-cache-possibly-enter-article, gnus-cache-request-article) @@ -3457,10 +8590,10 @@ (gnus-cache-braid-nov, gnus-cache-braid-heads) (gnus-cache-generate-active, gnus-cache-rename-group) (gnus-cache-delete-group, gnus-cache-update-file-total-fetched-for) - (gnus-cache-update-overview-total-fetched-for): Bind - file-name-coding-system to nnmail-pathname-coding-system. - (gnus-cache-decoded-group-names, gnus-cache-unified-group-names): New - variables. + (gnus-cache-update-overview-total-fetched-for): + Bind file-name-coding-system to nnmail-pathname-coding-system. + (gnus-cache-decoded-group-names, gnus-cache-unified-group-names): + New variables. (gnus-cache-decoded-group-name): New function. (gnus-cache-file-name): Use it. (gnus-cache-generate-active): Use non-decoded group name for active. @@ -3494,8 +8627,8 @@ (gnus-agent-retrieve-headers, gnus-agent-request-article) (gnus-agent-regenerate-group) (gnus-agent-update-files-total-fetched-for) - (gnus-agent-update-view-total-fetched-for): Bind - file-name-coding-system to nnmail-pathname-coding-system. + (gnus-agent-update-view-total-fetched-for): + Bind file-name-coding-system to nnmail-pathname-coding-system. (gnus-agent-group-pathname): Don't encode file names by nnmail-pathname-coding-system. (gnus-agent-save-local): Bind file-name-coding-system correctly; bind @@ -3516,8 +8649,8 @@ * nnrss.el (nnrss-file-coding-system): Doc fix; make it begin with *. (nnrss-request-delete-group): Bind file-name-coding-system to nnmail-pathname-coding-system. - (nnrss-read-server-data, nnrss-read-group-data): Bind - file-name-coding-system correctly. + (nnrss-read-server-data, nnrss-read-group-data): + Bind file-name-coding-system correctly. (nnrss-check-group): Pass nnrss-file-coding-system to md5. * nntp.el: Require gnus-group for the function gnus-group-name-charset. @@ -3592,8 +8725,8 @@ * message.el (message-fix-before-sending): Skip raw message part to be forwarded while checking illegible text. - (message-forward-make-body-mime, message-forward-make-body): Mark - signed or encrypted raw message as having no illegible text. + (message-forward-make-body-mime, message-forward-make-body): + Mark signed or encrypted raw message as having no illegible text. 2007-06-19 Katsumi Yamaoka <[email protected]> @@ -3612,8 +8745,8 @@ 2007-06-14 Katsumi Yamaoka <[email protected]> * gnus-agent.el (gnus-agent-fetch-headers) - (gnus-agent-retrieve-headers): Bind - gnus-decode-encoded-address-function to identity. + (gnus-agent-retrieve-headers): + Bind gnus-decode-encoded-address-function to identity. * nntp.el (nntp-send-xover-command): Recognize an xover command is available also when the server returns simply a dot. @@ -3674,8 +8807,8 @@ 2007-05-29 Katsumi Yamaoka <[email protected]> - * gnus-sum.el (gnus-summary-limit-to-address): New function. Suggested - by Loic Dachary <[email protected]>. + * gnus-sum.el (gnus-summary-limit-to-address): New function. + Suggested by Loic Dachary <[email protected]>. (gnus-summary-limit-map, gnus-summary-make-menu-bar): Add it. 2007-05-28 Katsumi Yamaoka <[email protected]> @@ -3732,13 +8865,13 @@ * gnus-util.el (gnus-limit-string): Delete this function. - * gnus-sum.el (gnus-simplify-subject-fully): Use - `truncate-string-to-width' instead. + * gnus-sum.el (gnus-simplify-subject-fully): + Use `truncate-string-to-width' instead. 2007-05-11 Michaël Cadilhac <[email protected]> - * gnus-sum.el (gnus-summary-next-group-on-exit): New variable. Tell - if, on summary exit, the next group has to be selected. + * gnus-sum.el (gnus-summary-next-group-on-exit): New variable. + Tell if, on summary exit, the next group has to be selected. (gnus-summary-exit): Use it. 2007-05-10 Reiner Steib <[email protected]> @@ -3792,8 +8925,8 @@ 2007-04-27 Didier Verna <[email protected]> - * gnus-util.el (gnus-orify-regexp): Moved and renamed to ... - * gmm-utils.el (gmm-regexp-concat): here. + * gnus-util.el (gnus-orify-regexp): Move and rename to ... + * gmm-utils.el (gmm-regexp-concat): ... here. * message.el: Don't require 'gnus-util. (message-dont-reply-to-names): Handle name change above. * gnus-sum.el (gnus-ignored-from-addresses): Ditto. @@ -3860,9 +8993,9 @@ 2007-04-16 Didier Verna <[email protected]> - * gnus-msg.el (gnus-configure-posting-styles): Handle - message-signature-directory properly with :file syntax. Reported by - "Leo". + * gnus-msg.el (gnus-configure-posting-styles): + Handle message-signature-directory properly with :file syntax. + Reported by "Leo". 2007-04-11 Didier Verna <[email protected]> @@ -3874,8 +9007,8 @@ 2007-04-10 Katsumi Yamaoka <[email protected]> - * gnus-msg.el (gnus-inews-yank-articles): Use - message-exchange-point-and-mark instead of exchange-point-and-mark. + * gnus-msg.el (gnus-inews-yank-articles): + Use message-exchange-point-and-mark instead of exchange-point-and-mark. 2007-04-09 Katsumi Yamaoka <[email protected]> @@ -4035,7 +9168,7 @@ 2007-02-20 Daiki Ueno <[email protected]> - * mml2015.el (mml2015-epg-verify): Simplified. + * mml2015.el (mml2015-epg-verify): Simplify. 2007-02-19 Katsumi Yamaoka <[email protected]> @@ -4101,8 +9234,8 @@ (gnus-message-citation-keywords): Set LAXMATCH flag in every HIGHLIGHT. (gnus-message-add-citation-keywords): Append keywords rather than prepending; emulate font-lock-add-keywords if it is not available. - (gnus-message-remove-citation-keywords): Emulate - font-lock-remove-keywords if it is not available. + (gnus-message-remove-citation-keywords): + Emulate font-lock-remove-keywords if it is not available. * gnus-msg.el (gnus-message-highlight-citation): Default to t. @@ -4130,8 +9263,8 @@ 2007-01-23 Reiner Steib <[email protected]> - * gnus-score.el (gnus-home-score-file, gnus-home-adapt-file): Fix - custom choice. + * gnus-score.el (gnus-home-score-file, gnus-home-adapt-file): + Fix custom choice. * gnus-art.el (gnus-signature-limit): Fix custom choice. @@ -4173,8 +9306,8 @@ * gnus-sum.el (gnus-auto-select-first): Improve doc string. - * message.el (message-cite-original-1): Call - gnus-article-highlight-citation if requested. + * message.el (message-cite-original-1): + Call gnus-article-highlight-citation if requested. (message-make-from): Allow name and address as optional arguments. * gnus-cite.el (gnus-article-highlight-citation): Add SAME-BUFFER arg. @@ -4292,8 +9425,8 @@ 2006-12-29 Jouni K. Seppänen <[email protected]> - * nnimap.el (nnimap-expunge-search-string): Mention - nnimap-search-uids-not-since-is-evil in docstring. + * nnimap.el (nnimap-expunge-search-string): + Mention nnimap-search-uids-not-since-is-evil in docstring. 2006-12-28 Reiner Steib <[email protected]> @@ -4305,8 +9438,8 @@ make-obsolete-variable. (spam-bsfilter-path, spam-bsfilter-program) (spam-spamassassin-path, spam-spamassassin-program) - (spam-sa-learn-path, spam-sa-learn-program): Rename variables. Don't - use "path" inappropriately. + (spam-sa-learn-path, spam-sa-learn-program): Rename variables. + Don't use "path" inappropriately. (spam-check-spamassassin, spam-spamassassin-register-with-sa-learn) (spam-check-bsfilter, spam-bsfilter-register-with-bsfilter): Use new variable names. @@ -4358,8 +9491,8 @@ (spam-spamoracle-database, spam-get-ifile-database-parameter): Fix doc strings. (spam-check-ifile, spam-ifile-register-with-ifile) - (spam-check-bogofilter, spam-bogofilter-register-with-bogofilter): Use - new variable names. + (spam-check-bogofilter, spam-bogofilter-register-with-bogofilter): + Use new variable names. * gnus-art.el (gnus-treat-display-x-face, gnus-treat-display-face) (gnus-treat-display-smileys): Simplify using @@ -4434,7 +9567,7 @@ specifying array size. (gnus-summary-insert-line, gnus-summary-prepare-threads): Regrow indent array if it is too small. - (gnus-sort-threads-recursive): Renamed from gnus-sort-thread-1. + (gnus-sort-threads-recursive): Rename from gnus-sort-thread-1. (gnus-sort-threads-loop): New function. 2006-12-06 Chris Moore <[email protected]> @@ -4471,8 +9604,8 @@ 2006-11-29 Katsumi Yamaoka <[email protected]> - * nneething.el (nneething-decode-file-name): Replace - decode-coding-string with mm-decode-coding-string. + * nneething.el (nneething-decode-file-name): + Replace decode-coding-string with mm-decode-coding-string. * gnus-int.el (gnus-open-server): Say failed server's name. @@ -4569,7 +9702,7 @@ 2006-11-13 Daiki Ueno <[email protected]> - * mml2015.el (mml2015-epg-encrypt): Removed backward compatibility for + * mml2015.el (mml2015-epg-encrypt): Remove backward compatibility for EasyPG (< 0.0.6). (mml2015-always-trust): New user option. (mml2015-epg-passphrase-callback): Display key ID on the passphrase @@ -4595,12 +9728,12 @@ 2006-11-07 Reiner Steib <[email protected]> * message.el (message-strip-subject-encoded-words): Reformat prompt. - (message-simplify-subject-functions): Enable - message-strip-subject-encoded-words by default. + (message-simplify-subject-functions): + Enable message-strip-subject-encoded-words by default. 2006-11-06 Reiner Steib <[email protected]> - * message.el (message-strip-subject-encoded-words): New function + * message.el (message-strip-subject-encoded-words): New function. (message-simplify-subject-functions): New variable. (message-simplify-subject): Use it. Fix typo in doc string. Support message-strip-subject-encoded-words. @@ -4628,8 +9761,8 @@ (mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions. (mm-charset-synonym-alist): Move some entries to mm-codepage-iso-8859-list. - (mm-charset-synonym-alist, mm-charset-override-alist): Add - iso-8859-8/windows-1255 and iso-8859-9/windows-1254. + (mm-charset-synonym-alist, mm-charset-override-alist): + Add iso-8859-8/windows-1255 and iso-8859-9/windows-1254. 2006-10-29 Katsumi Yamaoka <[email protected]> @@ -4656,8 +9789,8 @@ 2006-10-24 Reiner Steib <[email protected]> - * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list): New - variables. + * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list): + New variables. (mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions. (mm-charset-synonym-alist): Move some entries to mm-codepage-iso-8859-list. @@ -4672,8 +9805,8 @@ 2006-10-20 Teodor Zlatanov <[email protected]> - * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use - car-safe to avoid bad parses. + * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): + Use car-safe to avoid bad parses. 2006-10-20 Katsumi Yamaoka <[email protected]> @@ -4703,8 +9836,8 @@ 2006-10-16 Teodor Zlatanov <[email protected]> - * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use - ietf-drums-parse-address instead of gnus-extract-address-components. + * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): + Use ietf-drums-parse-address instead of gnus-extract-address-components. Reported by Damien Elmes <[email protected]>. 2006-10-19 Reiner Steib <[email protected]> @@ -4733,8 +9866,8 @@ 2006-10-04 Reiner Steib <[email protected]> - * mm-util.el (mm-charset-synonym-alist, mm-charset-override-alist): Add - iso-8859-8/windows-1255 and iso-8859-9/windows-1254. + * mm-util.el (mm-charset-synonym-alist, mm-charset-override-alist): + Add iso-8859-8/windows-1255 and iso-8859-9/windows-1254. * nnheader.el (nnheader-find-file-noselect): Inhibit version-control. @@ -4743,8 +9876,8 @@ (message-simplify-subject): New function to remove duplicate code. (message-reply, message-followup): Use it. - * gnus-sum.el (gnus-summary-make-menu-bar): Clarify - gnus-summary-limit-to-articles. + * gnus-sum.el (gnus-summary-make-menu-bar): + Clarify gnus-summary-limit-to-articles. 2006-10-03 Katsumi Yamaoka <[email protected]> @@ -4782,8 +9915,8 @@ * gmm-utils.el (gmm): Adjust custom version. - * mm-util.el (mm-charset-override-alist, mm-charset-eval-alist): Adjust - custom version. + * mm-util.el (mm-charset-override-alist, mm-charset-eval-alist): + Adjust custom version. * gnus-draft.el (gnus-draft-mode): Don't call `mml-mode'. @@ -4803,8 +9936,9 @@ 2006-09-20 Maxime Edouard Robert Froumentin <[email protected]> - (gnus-insert-mime-button, gnus-insert-mime-security-button): Apply - gnus-article-button-face to MIME and security buttons. + * gnus-art.el (gnus-insert-mime-button) + (gnus-insert-mime-security-button): + Apply gnus-article-button-face to MIME and security buttons. 2006-09-20 Reiner Steib <[email protected]> @@ -4968,8 +10102,8 @@ 2006-08-09 Katsumi Yamaoka <[email protected]> * compface.el (uncompface): Make sure the eol conversion doesn't take - place when communicating with the external programs. Reported by - ARISAWA Akihiro <[email protected]>. + place when communicating with the external programs. + Reported by ARISAWA Akihiro <[email protected]>. 2006-07-31 Katsumi Yamaoka <[email protected]> @@ -5089,8 +10223,8 @@ (mml2015-function-alist): Add epg. (mml2015-epg-passphrase-callback, mml2015-epg-decrypt) (mml2015-epg-clear-decrypt, mml2015-epg-verify) - (mml2015-epg-clear-verify, mml2015-epg-sign, mml2015-epg-encrypt): New - functions. + (mml2015-epg-clear-verify, mml2015-epg-sign, mml2015-epg-encrypt): + New functions. 2006-07-08 Andreas Seltenreich <[email protected]> @@ -5100,8 +10234,8 @@ 2006-06-27 Andreas Seltenreich <[email protected]> - * gnus-group.el (gnus-group-sort-by-unread): Fix typo. Reported by - Kenneth Jacker <[email protected]>. + * gnus-group.el (gnus-group-sort-by-unread): Fix typo. + Reported by Kenneth Jacker <[email protected]>. 2006-06-26 Reiner Steib <[email protected]> @@ -5145,8 +10279,8 @@ nnmail-fix-eudora-headers. (nnmail-fix-eudora-headers): Now obsolete. - * gnus-art.el (gnus-button-handle-custom): Support - `customize-apropos*'. + * gnus-art.el (gnus-button-handle-custom): + Support `customize-apropos*'. 2006-06-21 Lars Magne Ingebrigtsen <[email protected]> @@ -5180,8 +10314,8 @@ (gnus-bookmark-write-file): Simplify. (gnus-bookmark-maybe-sort-alist): Use `when'. (gnus-bookmark-get-bookmark): Fix typo in doc string. - (gnus-bookmark-set-bookmark-name, gnus-bookmark-get-bookmark): Add - FIXME about Emacs 21 and XEmacs compatibility. + (gnus-bookmark-set-bookmark-name, gnus-bookmark-get-bookmark): + Add FIXME about Emacs 21 and XEmacs compatibility. (gnus-bookmark-set-bookmark-name): Use `gnus-replace-in-string' for compatibility. (gnus-bookmark-bmenu-mode): Use `gnus-run-mode-hooks' for @@ -5268,17 +10402,17 @@ 2006-05-29 Kevin Greiner <[email protected]> - * gnus-agent.el: Added gnus-agent-flush* to purge agent info. - (gnus-agent-read-agentview): Fixed handling of end-of-file error. - (gnus-agent-read-local): All symbols allocated in my-obarray + * gnus-agent.el: Add gnus-agent-flush* to purge agent info. + (gnus-agent-read-agentview): Fix handling of end-of-file error. + (gnus-agent-read-local): All symbols allocated in my-obarray. (gnus-agent-set-local): Skip invalid entries (min and/or max is nil). (gnus-agent-regenerate-group): Check numeric names to see if they are messages or groups. (gnus-agent-total-fetched-for): Ignore 'dummy.group' (there should be a better way of do this...) - * gnus-cache.el (gnus-agent-total-fetched-for): Ignore - 'dummy.group' (there should be a better way of do this...) + * gnus-cache.el (gnus-agent-total-fetched-for): + Ignore 'dummy.group' (there should be a better way of do this...) 2006-05-29 Katsumi Yamaoka <[email protected]> @@ -5308,8 +10442,8 @@ (gnus-article-mode): Use it. (gnus-article-toggle-truncate-lines): New function. - * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): Add - gnus-article-toggle-truncate-lines. + * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): + Add gnus-article-toggle-truncate-lines. * uudecode.el (uudecode-decode-region-external): nil isn't a valid coding system in XEmacs, use binary. @@ -5336,8 +10470,8 @@ 2006-05-25 Katsumi Yamaoka <[email protected]> - * gnus-art.el (gnus-default-article-saver): Add - gnus-summary-write-body-to-file. + * gnus-art.el (gnus-default-article-saver): + Add gnus-summary-write-body-to-file. (gnus-article-save-coding-system): Don't use coding system object in XEmacs. (gnus-read-save-file-name): Add optional `dir-var' argument which @@ -5402,13 +10536,14 @@ * gnus-art.el (gnus-button-alist): Improve gnus-button-handle-symbol entry. - * gnus-sum.el (gnus-summary-make-menu-bar): Add - gnus-article-browse-html-article. + * gnus-sum.el (gnus-summary-make-menu-bar): + Add gnus-article-browse-html-article. 2006-05-23 Hynek Schlawack <[email protected]> - * gnus-sum.el (gnus-summary-mime-map): Add - gnus-article-browse-html-article. + * gnus-sum.el (gnus-summary-mime-map): + Add gnus-article-browse-html-article. + 2006-05-23 Reiner Steib <[email protected]> * gnus-sum.el (gnus-summary-save-article-coding-system): Offer some @@ -5424,16 +10559,16 @@ (gnus-summary-expire-articles-now): Shorten prompt. * gmm-utils.el (wid-edit): Require. - (defun-gmm): Renamed from `gmm-defun-compat'. + (defun-gmm): Rename from `gmm-defun-compat'. (gmm-image-search-load-path): Use it. (gmm-image-load-path-for-library): Use it. Sync with `mh-compat.el'. 2006-05-17 Katsumi Yamaoka <[email protected]> - * gnus-sum.el (gnus-summary-save-article-coding-system): New - variable. - (gnus-summary-save-article): Add optional `decode' argument. If - it is set and gnus-summary-save-article-coding-system is non-nil, + * gnus-sum.el (gnus-summary-save-article-coding-system): + New variable. + (gnus-summary-save-article): Add optional `decode' argument. + If it is set and gnus-summary-save-article-coding-system is non-nil, save decoded article. (gnus-summary-write-article-file): Save decoded article if gnus-summary-save-article-coding-system is non-nil. @@ -5450,8 +10585,8 @@ * gnus-art.el (gnus-article-setup-buffer): Go to summary buffer first to test gnus-single-article-buffer which may be buffer-local. - * gnus-sum.el (gnus-summary-setup-buffer): Make - gnus-single-article-buffer buffer-local and nil in ephemeral + * gnus-sum.el (gnus-summary-setup-buffer): + Make gnus-single-article-buffer buffer-local and nil in ephemeral group; make gnus-article-buffer, gnus-article-current, and gnus-original-article-buffer always buffer-local. (gnus-summary-exit): Kill article buffer belonging to ephemeral @@ -5486,8 +10621,8 @@ (message-signature-file, message-signature-insert-empty-line): Remove autoloads. - * gnus-art.el (gnus-buttonized-mime-types): Remove - "multipart/signed". Revert 2006-04-26 change. + * gnus-art.el (gnus-buttonized-mime-types): + Remove "multipart/signed". Revert 2006-04-26 change. 2006-05-01 Lars Magne Ingebrigtsen <[email protected]> @@ -5506,8 +10641,8 @@ * message.el (hashcash): Require hashcash as normal. - * ecomplete.el (ecomplete-highlight-match-line): Use - point-at-eol. + * ecomplete.el (ecomplete-highlight-match-line): + Use point-at-eol. (ecomplete-highlight-match-line): Use `highlight', because that face exists in both Emacs and XEmacs. @@ -5564,8 +10699,8 @@ * message.el (message-citation-line-format): New variable. (message-insert-formated-citation-line): New function. - (message-citation-line-function): Add - `message-insert-formated-citation-line' to custom type. + (message-citation-line-function): + Add `message-insert-formated-citation-line' to custom type. * mm-decode.el (mm-verify-option): Add gnus-buttonized-mime-types to doc string. @@ -5624,8 +10759,8 @@ (message-mode): Ditto. (message-strip-forbidden-properties): Ditto. - * ecomplete.el (ecomplete-database-file-coding-system): New - variable. + * ecomplete.el (ecomplete-database-file-coding-system): + New variable. (ecomplete-save): Use it. (ecomplete-setup): Use it. @@ -5701,8 +10836,8 @@ * rfc2231.el (rfc2231-parse-string): Sort the parameters first. - * message.el (message-forward-make-body-plain): Allow - message-forward-ignored-headers to be a list. + * message.el (message-forward-make-body-plain): + Allow message-forward-ignored-headers to be a list. (message-remove-ignored-headers): Factor out into function. (message-forward-make-body-mml): Use it. * rfc2231.el (rfc2231-parse-string): Remove dead code. @@ -5740,8 +10875,8 @@ 2006-04-16 Lars Magne Ingebrigtsen <[email protected]> - * message.el (message-put-addresses-in-ecomplete): Use - gnus-replace-in-string. + * message.el (message-put-addresses-in-ecomplete): + Use gnus-replace-in-string. (message-is-yours-p): Use the more correct mail-header-parse-address instead of mail-extract-address-components. @@ -5755,8 +10890,8 @@ * message.el (message-hidden-headers): Add X-Draft-From. - * gnus-sum.el (gnus-summary-repeat-search-article-forward): New - command. + * gnus-sum.el (gnus-summary-repeat-search-article-forward): + New command. (gnus-summary-repeat-search-article-backward): New command. * gnus-topic.el (gnus-topic-display-missing-topic): Skip past @@ -5770,7 +10905,7 @@ 2006-04-16 Lars Magne Ingebrigtsen <[email protected]> - * gnus-art.el (gnus-face-properties-alist): Moved here from + * gnus-art.el (gnus-face-properties-alist): Move here from gnus-fun. * gnus-fun.el (gnus-face-properties-alist): Move to gnus-art. @@ -5802,8 +10937,8 @@ 2006-04-15 Lars Magne Ingebrigtsen <[email protected]> - * hashcash.el (hashcash-insert-payment-async-2): Use - message-goto-eoh instead of doing it manually. + * hashcash.el (hashcash-insert-payment-async-2): + Use message-goto-eoh instead of doing it manually. (mail-add-payment): Use message-narrow-to-header instead of trying to do the same itself. @@ -5843,8 +10978,8 @@ * ecomplete.el (ecomplete-display-matches): Allow automatic display. - * message.el (message-strip-forbidden-properties): Display - abbrevs. + * message.el (message-strip-forbidden-properties): + Display abbrevs. (message-display-abbrev): Get automatic display right. * ecomplete.el (ecomplete-display-matches): Use M-n/M-p @@ -5855,15 +10990,15 @@ TODO: Backport to v5-10! * gnus-util.el (gnus-alist-to-hashtable, gnus-hashtable-to-alist): - Moved here (and renamed) from gnus-registry.el. + Move here (and rename) from gnus-registry.el. * gnus-registry.el: Require gnus-util. Use `gnus-alist-to-hashtable' and `gnus-hashtable-to-alist'. 2006-04-13 Lars Magne Ingebrigtsen <[email protected]> - * gnus-group.el (gnus-group-catchup-current): Change - if-then-else-if-then-else into cond. + * gnus-group.el (gnus-group-catchup-current): + Change if-then-else-if-then-else into cond. (gnus-group-catchup): Indent. (group-name-at-point): New function. (gnus-fetch-group): Provide default from thing at point. @@ -5872,8 +11007,8 @@ * message.el (message-display-abbrev): Fix regexp. - * ecomplete.el (ecomplete-highlight-match-line): Reimplement - choosing. + * ecomplete.el (ecomplete-highlight-match-line): + Reimplement choosing. (ecomplete-highlight-match-line): Fix up code rewrite, remove dead variables. @@ -5882,8 +11017,8 @@ 2006-04-12 Reiner Steib <[email protected]> - * gnus-art.el (gnus-article-mode): Set - cursor-in-non-selected-windows to nil. + * gnus-art.el (gnus-article-mode): + Set cursor-in-non-selected-windows to nil. * smiley.el: Revert previous change. (smiley-data-directory): defvar it before using it in the @@ -5900,8 +11035,8 @@ * ecomplete.el (ecomplete-add-item): Chop off decimals. - * gnus-sum.el (gnus-summary-save-parts): Bind - gnus-summary-save-parts-counter and use it to make unique file + * gnus-sum.el (gnus-summary-save-parts): + Bind gnus-summary-save-parts-counter and use it to make unique file names. * gnus-art.el (gnus-ignored-headers): Add some more headers. @@ -6008,8 +11143,8 @@ 2006-04-05 Daiki Ueno <[email protected]> - * pgg-gpg.el (pgg-gpg-encrypt-region, pgg-gpg-sign-region): Wait - for BEGIN_SIGNING too, new in GnuPG 1.4.3. + * pgg-gpg.el (pgg-gpg-encrypt-region, pgg-gpg-sign-region): + Wait for BEGIN_SIGNING too, new in GnuPG 1.4.3. 2006-04-04 Andreas Seltenreich <[email protected]> @@ -6019,8 +11154,8 @@ 2006-04-04 Reiner Steib <[email protected]> - * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Check - gnus-extra-headers for 'Newsgroups. + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): + Check gnus-extra-headers for 'Newsgroups. * message.el (message-tool-bar-gnome): Check if `flyspell-mode' is bound. @@ -6068,8 +11203,8 @@ 2006-03-27 Karl Kleinpaste <[email protected]> - * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Improve - newsgroups handling for NNTP overviews which don't include + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): + Improve newsgroups handling for NNTP overviews which don't include Newsgroups. 2006-03-26 Andreas Seltenreich <[email protected]> @@ -6195,8 +11330,8 @@ 2006-03-14 Reiner Steib <[email protected]> - * gmm-utils.el (gmm-image-load-path-for-library): Fix typo. Use - `defun' instead of `gmm-defun-compat'. + * gmm-utils.el (gmm-image-load-path-for-library): Fix typo. + Use `defun' instead of `gmm-defun-compat'. 2006-03-14 Simon Josefsson <[email protected]> @@ -6281,8 +11416,8 @@ * gnus-group.el (gnus-group-make-tool-bar): Use add-hook. Suggested by Stefan Monnier <[email protected]>. - * gnus-art.el (gnus-article-browse-delete-temp-files): Simplify - resetting gnus-article-browse-html-temp-list. + * gnus-art.el (gnus-article-browse-delete-temp-files): + Simplify resetting gnus-article-browse-html-temp-list. * gmm-utils.el (gmm-image-load-path-for-library): Sync with mh-compat.el at 2006-03-04T21:23:[email protected] in Emacs. Rename `gmm-image-load-path'. @@ -6327,12 +11462,12 @@ * gnus-art.el (gnus-article-browse-html-temp-list): Rename from gnus-article-browse-html-temp. - (gnus-article-browse-delete-temp): Make it customizable. Add - `file'. Adjust doc string. - (gnus-article-browse-delete-temp-files): Add argument. Allow - query for each file. Adjust doc string. - (gnus-article-browse-html-parts): Add - `gnus-article-browse-delete-temp-files' to + (gnus-article-browse-delete-temp): Make it customizable. + Add `file'. Adjust doc string. + (gnus-article-browse-delete-temp-files): Add argument. + Allow query for each file. Adjust doc string. + (gnus-article-browse-html-parts): + Add `gnus-article-browse-delete-temp-files' to `gnus-summary-prepare-exit-hook' and `gnus-exit-gnus-hook'. 2006-03-02 Hynek Schlawack <[email protected]> @@ -6350,8 +11485,8 @@ string. * gnus-sum.el (gnus-summary-tool-bar-gnome): Don't use - gnus-summary-insert-new-articles when unplugged. Remove - gnus-summary-search-article-forward. + gnus-summary-insert-new-articles when unplugged. + Remove gnus-summary-search-article-forward. * gmm-utils.el (gmm-tool-bar-style): Test tool-bar-mode and display-visual-class instead of display-color-cells. @@ -6401,8 +11536,8 @@ * gnus-art.el (gnus-button): New face. (gnus-article-button-face): Use it. - * gnus-sum.el (gnus-summary-tool-bar-gnome): Add - gnus-summary-next-page. Re-order. + * gnus-sum.el (gnus-summary-tool-bar-gnome): + Add gnus-summary-next-page. Re-order. * gnus-group.el (gnus-group-tool-bar-gnome): prev-node and next-node are now included. @@ -6415,8 +11550,8 @@ * spam.el (spam-spamassassin-score-regexp): New internal variable. (spam-extra-header-to-number, spam-check-spamassassin-headers): - Use it to match format of Spamassassin 3.0 and later. Reported by - IRIE Tetsuya <[email protected]>. + Use it to match format of Spamassassin 3.0 and later. + Reported by IRIE Tetsuya <[email protected]>. (spam-check-bogofilter) (spam-bogofilter-register-with-bogofilter): Fix args of `gnus-error' calls. @@ -6424,8 +11559,8 @@ 2006-02-28 Reiner Steib <[email protected]> * gnus-draft.el (gnus-draft-send): Bind message-signature to avoid - unnecessary interaction when sending queued mails. Reported by - TAKAHASHI Yoshio <[email protected]>. + unnecessary interaction when sending queued mails. + Reported by TAKAHASHI Yoshio <[email protected]>. 2006-02-27 Reiner Steib <[email protected]> @@ -6460,17 +11595,17 @@ 2006-02-23 Reiner Steib <[email protected]> - * gnus-group.el (gnus-group-tool-bar-gnome): Fix - gnus-agent-toggle-plugged. Re-order icons. - (gnus-group-tool-bar-gnome): Add - gnus-group-{prev,next}-unread-group. + * gnus-group.el (gnus-group-tool-bar-gnome): + Fix gnus-agent-toggle-plugged. Re-order icons. + (gnus-group-tool-bar-gnome): + Add gnus-group-{prev,next}-unread-group. (gnus-group-tool-bar-gnome): Re-order icons. - * gnus-sum.el (gnus-summary-tool-bar-gnome): Move - gnus-summary-insert-new-articles. + * gnus-sum.el (gnus-summary-tool-bar-gnome): + Move gnus-summary-insert-new-articles. - * message.el (message-tool-bar-gnome, message-tool-bar-retro): Fix - comments. + * message.el (message-tool-bar-gnome, message-tool-bar-retro): + Fix comments. * utf7.el (utf7-utf-16-coding-system): Fix comment. utf-16-be is also available in Emacs 21.3. @@ -6523,7 +11658,7 @@ * message.el (message-make-tool-bar): Ditto. - * mml.el (mml-preview): Added comment concerning tool bar icons. + * mml.el (mml-preview): Add comment concerning tool bar icons. * gnus-group.el (gnus-group-tool-bar-gnome): Use new icon names. (gnus-group-make-tool-bar): Use `gmm-image-load-path'. @@ -6534,10 +11669,10 @@ * message.el (message-tool-bar-gnome): Use new icon names. (message-make-tool-bar): Use `gmm-image-load-path'. - * gmm-utils.el (gmm-defun-compat, gmm-image-search-load-path): New - functions from MH-E. + * gmm-utils.el (gmm-defun-compat, gmm-image-search-load-path): + New functions from MH-E. (gmm-image-load-path): New variable from MH-E. - (gmm-image-load-path): New function from MH-E. Added arguments + (gmm-image-load-path): New function from MH-E. Add arguments LIBRARY, IMAGE and PATH. Don't modify paths. Don't use *-image-load-path-called-flag. @@ -6554,8 +11689,8 @@ * mm-util.el (mm-charset-override-alist): Fix type in doc string. - * gnus-art.el (mm-url-insert-file-contents-external): Autoload - mm-url. + * gnus-art.el (mm-url-insert-file-contents-external): + Autoload mm-url. * mm-uu.el (mm-uu-type-alist): Improve `LaTeX'. @@ -6576,13 +11711,13 @@ 2006-02-17 Katsumi Yamaoka <[email protected]> - * gnus-art.el (article-strip-banner): Call - article-really-strip-banner only when the regexp match is made. + * gnus-art.el (article-strip-banner): + Call article-really-strip-banner only when the regexp match is made. 2006-02-16 Katsumi Yamaoka <[email protected]> - * gnus-art.el (article-strip-banner): Use - gnus-extract-address-components instead of + * gnus-art.el (article-strip-banner): + Use gnus-extract-address-components instead of mail-header-parse-addresses to make it work with non-ASCII text; remove mail-encode-encoded-word-string. @@ -6674,8 +11809,8 @@ 2006-02-08 Katsumi Yamaoka <[email protected]> - * nnfolder.el (nnfolder-insert-newsgroup-line): Use - message-make-date instead of current-time-string. + * nnfolder.el (nnfolder-insert-newsgroup-line): + Use message-make-date instead of current-time-string. * mm-view.el (mm-inline-message): Don't set gnus-newsgroup-charset to gnus-decoded which mm-uu might set. @@ -6822,8 +11957,8 @@ 2006-01-26 Steve Youngs <[email protected]> - * gmm-utils.el (gmm-tool-bar-item, gmm-tool-bar-zap-list): Don't - autoload. + * gmm-utils.el (gmm-tool-bar-item, gmm-tool-bar-zap-list): + Don't autoload. 2006-01-26 Katsumi Yamaoka <[email protected]> @@ -6840,8 +11975,8 @@ `gmm-tool-bar-from-list'. * gnus-group.el (gnus-group-tool-bar, gnus-group-tool-bar-gnome) - (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): New - variables. + (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): + New variables. (gnus-group-make-tool-bar): Complete rewrite using `gmm-tool-bar-from-list'. (gnus-group-tool-bar-update): New function. @@ -6891,13 +12026,13 @@ (mm-inline-text-html-render-with-w3m-standalone): Use it to alter w3m usage. - * gnus-art.el (gnus-article-wash-html-with-w3m-standalone): Use - mm-w3m-standalone-supports-m17n-p to alter w3m usage. + * gnus-art.el (gnus-article-wash-html-with-w3m-standalone): + Use mm-w3m-standalone-supports-m17n-p to alter w3m usage. 2006-01-23 Reiner Steib <[email protected]> - * message.el (message-tool-bar-zap-list): Use - gmm-tool-bar-zap-list as custom type. + * message.el (message-tool-bar-zap-list): + Use gmm-tool-bar-zap-list as custom type. (message-tool-bar-update): New function. (message-tool-bar, message-tool-bar-gnome) (message-tool-bar-retro): Add message-tool-bar-update. @@ -7017,8 +12152,8 @@ 2006-01-13 Katsumi Yamaoka <[email protected]> - * gnus-art.el (article-wash-html): Use - gnus-summary-show-article-charset-alist if a numeric arg is given. + * gnus-art.el (article-wash-html): + Use gnus-summary-show-article-charset-alist if a numeric arg is given. (gnus-article-wash-html-with-w3m-standalone): New function. * mm-view.el (mm-text-html-renderer-alist): Map w3m-standalone to @@ -7045,8 +12180,8 @@ * gnus-cus.el (gnus-group-parameters): Sync posting-style with custom definition of `gnus-posting-styles'. - * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Bind - print-circle. Suggested by Kalle Olavi Niemitalo <[email protected]>. + * gnus-start.el (gnus-gnus-to-quick-newsrc-format): + Bind print-circle. Suggested by Kalle Olavi Niemitalo <[email protected]>. 2006-01-05 Reiner Steib <[email protected]> @@ -7133,8 +12268,8 @@ `customize-apropos' for any "M-x customize-*" button but the function called for. Accept both the function name and its argument in order to achieve this. - (gnus-button-alist): Remove support for "custom:" URL's. Pass - function name to `gnus-button-handle-custom' in case of "M-x + (gnus-button-alist): Remove support for "custom:" URL's. + Pass function name to `gnus-button-handle-custom' in case of "M-x customize-*" buttons. 2005-12-12 Katsumi Yamaoka <[email protected]> @@ -7163,11 +12298,11 @@ 2005-12-12 Katsumi Yamaoka <[email protected]> - * rfc2047.el (rfc2047-charset-to-coding-system): Recognize - us-ascii as a MIME charset. + * rfc2047.el (rfc2047-charset-to-coding-system): + Recognize us-ascii as a MIME charset. - * mm-bodies.el (mm-decode-content-transfer-encoding): Protect - against the case where the 2nd arg TYPE is nil. + * mm-bodies.el (mm-decode-content-transfer-encoding): + Protect against the case where the 2nd arg TYPE is nil. 2005-12-09 Reiner Steib <[email protected]> @@ -7195,8 +12330,8 @@ * gnus-fun.el (gnus-face-from-file): Decrease quant in smaller steps when < 10. - * gnus-start.el (gnus-no-server-1): Mention - `gnus-level-default-subscribed' in doc string. + * gnus-start.el (gnus-no-server-1): + Mention `gnus-level-default-subscribed' in doc string. 2005-12-02 ARISAWA Akihiro <[email protected]> (tiny change) @@ -7304,8 +12439,8 @@ 2005-11-12 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-article-alist-save-format): Changed - internal variable to a custom variable. Changed default value + * gnus-agent.el (gnus-agent-article-alist-save-format): + Change internal variable to a custom variable. Change default value from compressed(2) to uncompressed(1). (gnus-agent-read-agentview): Reversed revision 7.8 to restore support for uncompressed agentview files. Taken together, reading @@ -7319,12 +12454,12 @@ 2005-12-09 Reiner Steib <[email protected]> - * gnus-start.el (gnus-start-draft-setup): Enforce - `gnus-draft-mode' for nndraft:drafts at startup. + * gnus-start.el (gnus-start-draft-setup): + Enforce `gnus-draft-mode' for nndraft:drafts at startup. * gnus.el (gnus-splash): Change custom group. - (gnus-group-get-parameter, gnus-group-parameter-value): Describe - allow-list argument. + (gnus-group-get-parameter, gnus-group-parameter-value): + Describe allow-list argument. * gnus-agent.el (gnus-agent-article-alist-save-format): Format doc string. @@ -7529,8 +12664,8 @@ * mm-uu.el (mm-uu-verbatim-marks-extract): Add four start and end arguments. - (mm-uu-type-alist): Add message-marks and insert-marks. Pass - arguments to mm-uu-verbatim-marks-extract. + (mm-uu-type-alist): Add message-marks and insert-marks. + Pass arguments to mm-uu-verbatim-marks-extract. (mm-uu-hide-markers): New variable. (mm-uu-extract): Use face similar to `gnus-cite-3'. @@ -7569,8 +12704,8 @@ * message.el (message-tool-bar-local-item-from-menu): Fix comment. - * mm-bodies.el (mm-decode-string): Call - `mm-charset-to-coding-system' with allow-override argument. + * mm-bodies.el (mm-decode-string): + Call `mm-charset-to-coding-system' with allow-override argument. 2005-10-19 Katsumi Yamaoka <[email protected]> @@ -7597,7 +12732,7 @@ 2005-10-15 Bill Wohler <[email protected]> - * message.el (message-tool-bar-map): Renamed image file from + * message.el (message-tool-bar-map): Rename image file from mail_send to mail/send. 2005-10-16 Masatake YAMATO <[email protected]> @@ -7609,14 +12744,14 @@ * mml-sec.el (mml-secure-method): New internal variable. (mml-secure-sign, mml-secure-encrypt, mml-secure-message-sign) - (mml-secure-message-sign-encrypt, mml-secure-message-encrypt): New - functions using mml-secure-method. + (mml-secure-message-sign-encrypt, mml-secure-message-encrypt): + New functions using mml-secure-method. * mml.el (mml-mode-map): Add key bindings for those functions. (mml-menu): Simplify security menu entries. Suggested by Jesper Harder <[email protected]>. - (mml-attach-file, mml-attach-buffer, mml-attach-external): Goto - end of message if point is the headers of the message. + (mml-attach-file, mml-attach-buffer, mml-attach-external): + Goto end of message if point is the headers of the message. * message.el (message-in-body-p): New function. @@ -7625,8 +12760,8 @@ * mm-util.el (mm-charset-to-coding-system): Add allow-override. Use `mm-charset-override-alist' only when decoding. - * mm-bodies.el (mm-decode-body): Call - `mm-charset-to-coding-system' with allow-override argument. + * mm-bodies.el (mm-decode-body): + Call `mm-charset-to-coding-system' with allow-override argument. * gnus-art.el (gnus-mime-view-part-as-type-internal): Try to fetch `filename' from Content-Disposition if Content-Type doesn't @@ -7649,8 +12784,8 @@ (mm-charset-to-coding-system): Use it. (mm-codepage-setup): New helper function. (mm-charset-eval-alist): New variable. - (mm-charset-to-coding-system): Use mm-charset-eval-alist. Warn - about unknown charsets. + (mm-charset-to-coding-system): Use mm-charset-eval-alist. + Warn about unknown charsets. 2005-10-04 David Hansen <[email protected]> @@ -7704,15 +12839,15 @@ 2005-09-29 Simon Josefsson <[email protected]> - * spam.el: Load hashcash when compiling, to avoid warnings. Don't - autoload mail-check-payment. + * spam.el: Load hashcash when compiling, to avoid warnings. + Don't autoload mail-check-payment. (spam-check-hashcash): Define unconditionally, since hashcash.el is part of Gnus now. Ignore errors from payment checking. 2005-09-28 Reiner Steib <[email protected]> - * message.el (message-bold-region, message-unbold-region): Rename - from `bold-region' and `unbold-region'. + * message.el (message-bold-region, message-unbold-region): + Rename from `bold-region' and `unbold-region'. * message.el: Remove useless autoloads. @@ -7809,20 +12944,20 @@ * gnus-agent.el (gnus-agent-synchronize-flags): Explain why the default value is nil. - * mm-uu.el (mm-uu-type-alist): Added slrn style verbatim-marks. + * mm-uu.el (mm-uu-type-alist): Add slrn style verbatim-marks. (mm-uu-verbatim-marks-extract): New function. (mm-uu-extract): New face. (mm-uu-copy-to-buffer): Use it. - * spam-report.el (spam-report-gmane-ham): Renamed from + * spam-report.el (spam-report-gmane-ham): Rename from `spam-report-gmane-unspam'. - (spam-report-gmane-internal): Renamed from `spam-report-gmane'. + (spam-report-gmane-internal): Rename from `spam-report-gmane'. Simplify use of UNSPAM argument. Fetch "X-Report-Unspam" header. * spam.el (spam-report-gmane-spam, spam-report-gmane-ham): Autoload. - (spam-report-gmane-unregister-routine): Renamed - `spam-report-gmane-unspam' to `spam-report-gmane-ham'. + (spam-report-gmane-unregister-routine): + Rename `spam-report-gmane-unspam' to `spam-report-gmane-ham'. 2005-09-21 Teodor Zlatanov <[email protected]> @@ -7860,11 +12995,11 @@ * gnus-art.el (gnus-article-replace-part) (gnus-mime-replace-part): New functions. (gnus-mime-action-alist, gnus-mime-button-commands) - (gnus-mime-save-part-and-strip): Added file argument. - (gnus-article-part-wrapper): Added interactive argument. + (gnus-mime-save-part-and-strip): Add file argument. + (gnus-article-part-wrapper): Add interactive argument. - * gnus-sum.el (gnus-summary-mime-map): Add - `gnus-article-replace-part'. + * gnus-sum.el (gnus-summary-mime-map): + Add `gnus-article-replace-part'. 2005-09-19 Didier Verna <[email protected]> @@ -7913,8 +13048,8 @@ (message-setup-1): Call `message-use-alternative-email-as-from' after `message-setup-hook' to give it precedence over posting styles, etc. - (message-use-alternative-email-as-from): Add docstring. Remove - the original From header if present. + (message-use-alternative-email-as-from): Add docstring. + Remove the original From header if present. * nnml.el (nnml-compressed-files-size-threshold): New variable. (nnml-save-mail): Use it. @@ -7988,13 +13123,13 @@ 2005-09-04 Reiner Steib <[email protected]> - * mml.el (mml-dnd-protocol-alist, mml-dnd-attach-options): New - variables. + * mml.el (mml-dnd-protocol-alist, mml-dnd-attach-options): + New variables. (mml-dnd-attach-file, mml-mode): Use them. * nnweb.el (nnweb-type-definition, nnweb-google-wash-article): - Make fetching article by MID work again for Google Groups. Added - FIXME concerning gnus-group-make-web-group. + Make fetching article by MID work again for Google Groups. + Add FIXME concerning gnus-group-make-web-group. * mml-smime.el (mml-smime-sign-query, mml-smime-get-dns-cert): Don't depend on Gnus by using mail-extract-address-components if @@ -8014,8 +13149,8 @@ 2005-09-02 Hrvoje Niksic <[email protected]> - * mm-encode.el (mm-encode-content-transfer-encoding): Likewise - when encoding. + * mm-encode.el (mm-encode-content-transfer-encoding): + Likewise when encoding. * mm-bodies.el (mm-decode-content-transfer-encoding): De-canonicalize CRLF for all text content types, not just @@ -8035,20 +13170,20 @@ 2005-08-29 Jari Aalto <[email protected]> - * gnus-msg.el (gnus-inews-add-send-actions): Made - `message-post-method' lambda parameter ARG `&optional'. + * gnus-msg.el (gnus-inews-add-send-actions): + Make `message-post-method' lambda parameter ARG `&optional'. 2005-08-29 Reiner Steib <[email protected]> - * gnus-sum.el (gnus-summary-mime-map): Added - gnus-article-save-part-and-strip, gnus-article-delete-part and + * gnus-sum.el (gnus-summary-mime-map): + Add gnus-article-save-part-and-strip, gnus-article-delete-part and gnus-article-jump-to-part. - * gnus-art.el (gnus-article-edit-article): Added quiet argument. + * gnus-art.el (gnus-article-edit-article): Add quiet argument. (gnus-article-edit-part): Use it. - (gnus-article-part-wrapper): Added no-handle argument. - (gnus-article-save-part-and-strip, gnus-article-delete-part): New - functions. + (gnus-article-part-wrapper): Add no-handle argument. + (gnus-article-save-part-and-strip, gnus-article-delete-part): + New functions. 2005-08-29 Romain Francoise <[email protected]> @@ -8111,7 +13246,7 @@ * pgg.el (url-insert-file-contents): Don't autoload it, Emacs has it in url-handlers.el and XEmacs in url.el. Reported by Luca Capello and Romain Francoise. - (pgg-fetch-key-function): Removed, not used? + (pgg-fetch-key-function): Remove, not used? (pgg-insert-url-with-w3): Require url, to get url-insert-file-contents regardless of where it is defined. @@ -8168,8 +13303,8 @@ 2005-08-02 Katsumi Yamaoka <[email protected]> - * sieve-manage.el (sieve-manage-interactive-login): Use - make-local-variable rather than make-variable-buffer-local. + * sieve-manage.el (sieve-manage-interactive-login): + Use make-local-variable rather than make-variable-buffer-local. (sieve-manage-open): Ditto. (sieve-manage-authenticate): Ditto. @@ -8277,8 +13412,8 @@ 2005-07-16 Lars Magne Ingebrigtsen <[email protected]> - * gnus-msg.el (gnus-button-mailto): Remove - save-selected-window-window hackery because it relies on + * gnus-msg.el (gnus-button-mailto): + Remove save-selected-window-window hackery because it relies on save-selected-window internals. 2005-07-15 Katsumi Yamaoka <[email protected]> @@ -8292,14 +13427,14 @@ 2005-07-14 Hiroshi Fujishima <[email protected]> (tiny change) - * gnus-score.el (gnus-score-edit-all-score): Set - gnus-score-edit-exit-function to gnus-score-edit-done and call + * gnus-score.el (gnus-score-edit-all-score): + Set gnus-score-edit-exit-function to gnus-score-edit-done and call gnus-message. 2005-07-14 Lars Magne Ingebrigtsen <[email protected]> - * gnus-msg.el (gnus-button-mailto): Remove - save-selected-window-window hackery because it relies on + * gnus-msg.el (gnus-button-mailto): + Remove save-selected-window-window hackery because it relies on save-selected-window internals. 2005-07-13 Katsumi Yamaoka <[email protected]> @@ -8860,8 +13995,8 @@ 2005-04-21 Reiner Steib <[email protected]> - * message.el (message-kill-buffer-query): Renamed from - `message-kill-buffer-query-if-modified'. Added :version. + * message.el (message-kill-buffer-query): Rename from + `message-kill-buffer-query-if-modified'. Add :version. 2005-04-19 Katsumi Yamaoka <[email protected]> @@ -8933,7 +14068,7 @@ to get all the groups a message ID is in. * spam-stat.el (spam-stat-split-fancy-spam-threshold) - (spam-stat-split-fancy): Change "threshhold" to "threshold" + (spam-stat-split-fancy): Change "threshhold" to "threshold". (spam-stat-score-buffer-user-functions): Add :number custom type. 2005-04-06 Katsumi Yamaoka <[email protected]> @@ -9039,8 +14174,8 @@ 2005-03-09 Lars Magne Ingebrigtsen <[email protected]> - * gnus-msg.el (gnus-confirm-mail-reply-to-news): Add - gnus-expert-user to default. + * gnus-msg.el (gnus-confirm-mail-reply-to-news): + Add gnus-expert-user to default. 2005-03-08 Juergen Kreileder <[email protected]> (tiny change) @@ -9056,12 +14191,12 @@ 2005-03-06 Kevin Greiner <[email protected]> - * gnus-start.el (gnus-convert-old-newsrc): Fixed numeric + * gnus-start.el (gnus-convert-old-newsrc): Fix numeric comparison on string. * gnus-agent.el (gnus-agent-long-article, gnus-agent-short-article) - (gnus-agent-score): Renamed category keywords to match gnus-cus. - (gnus-agent-summary-fetch-series): Modified to protect against + (gnus-agent-score): Rename category keywords to match gnus-cus. + (gnus-agent-summary-fetch-series): Modify to protect against gnus-agent-summary-fetch-group clearing processable flags. (gnus-agent-synchronize-group-flags): Update live group buffer as synchronization may occur due to the user toggle the plugged @@ -9070,10 +14205,10 @@ successfully downloaded. (gnus-agent-expire-group-1): Avoid using markers when the overview is in ascending order; greatly improves performance. - (gnus-agent-regenerate-group): Use - gnus-agent-synchronize-group-flags to reset read status in both + (gnus-agent-regenerate-group): + Use gnus-agent-synchronize-group-flags to reset read status in both gnus and server. - (gnus-agent-update-files-total-fetched-for): Fixed initial size. + (gnus-agent-update-files-total-fetched-for): Fix initial size. 2005-03-04 Reiner Steib <[email protected]> @@ -9158,13 +14293,13 @@ 2005-02-25 Teodor Zlatanov <[email protected]> - * gnus-sum.el (gnus-summary-move-article): Set - gnus-sum-hint-move-is-internal for gnus-request-move-article and + * gnus-sum.el (gnus-summary-move-article): + Set gnus-sum-hint-move-is-internal for gnus-request-move-article and whatever it calls (right now, only nnimap-request-move article respects it). - * nnimap.el (nnimap-request-move-article): When - gnus-sum-hint-move-is-internal is set, don't do the extra + * nnimap.el (nnimap-request-move-article): + When gnus-sum-hint-move-is-internal is set, don't do the extra nnimap-request-article. 2005-02-24 Reiner Steib <[email protected]> @@ -9210,7 +14345,7 @@ 2005-02-21 Arne Jørgensen <[email protected]> - * nnrss.el (nnrss-verbose): Removed. + * nnrss.el (nnrss-verbose): Remove. (nnrss-request-group): Use `nnheader-message' instead. 2005-02-19 Mark Plaksin <[email protected]> (tiny change) @@ -9268,7 +14403,7 @@ * smime.el (smime-cert-by-dns): Add doc-string. (smime-cert-by-ldap-1): Indent. - * mml-smime.el (mml-smime-get-ldap-cert): Renamed from + * mml-smime.el (mml-smime-get-ldap-cert): Rename from mml-smime-get-dns-ldap. (mml-smime-encrypt-query): Use new function. Default to ldap. @@ -9336,8 +14471,8 @@ * mm-view.el (mm-display-inline-fontify): Allow the name parameter as well as the filename parameter. - * mm-util.el (mm-decompress-buffer): Merge - gnus-mime-jka-compr-maybe-uncompress. + * mm-util.el (mm-decompress-buffer): + Merge gnus-mime-jka-compr-maybe-uncompress. (mm-find-buffer-file-coding-system): Doc fix; force decompressing of compressed data. @@ -9421,7 +14556,7 @@ 2005-01-26 Steve Youngs <[email protected]> - * run-at-time.el: Removed. It is no longer needed as + * run-at-time.el: Remove. It is no longer needed as timer-funcs.el in the xemacs-base package has a working version of `run-at-time'. @@ -9505,8 +14640,8 @@ 2005-01-10 Reiner Steib <[email protected]> * gnus.el (gnus-user-agent): Use list of symbols instead of - symbols. Display full version number for (S)XEmacs. Optionally - display (S)XEmacs codename. + symbols. Display full version number for (S)XEmacs. + Optionally display (S)XEmacs codename. * gnus-util.el (gnus-emacs-version): Update for new `gnus-user-agent'. @@ -9718,12 +14853,12 @@ 2004-11-25 Reiner Steib <[email protected]> - * message.el (message-forbidden-properties): Fixed typo in doc + * message.el (message-forbidden-properties): Fix typo in doc string. 2004-11-25 Reiner Steib <[email protected]> - * gnus-util.el (gnus-replace-in-string): Added doc string. + * gnus-util.el (gnus-replace-in-string): Add doc string. * nnmail.el (nnmail-split-header-length-limit): Increase to 2048 to avoid problems when splitting mails with many recipients. @@ -9741,8 +14876,8 @@ 2004-12-03 Reiner Steib <[email protected]> - * gnus-sum.el (gnus-summary-limit-to-recipient): Implement - not-matching option. + * gnus-sum.el (gnus-summary-limit-to-recipient): + Implement not-matching option. 2004-12-02 Reiner Steib <[email protected]> @@ -9861,8 +14996,8 @@ 2004-11-23 Lars Magne Ingebrigtsen <[email protected]> - * message.el (message-strip-forbidden-properties): Bind - buffer-read-only (etc) to nil. + * message.el (message-strip-forbidden-properties): + Bind buffer-read-only (etc) to nil. 2004-11-23 Katsumi Yamaoka <[email protected]> @@ -9917,21 +15052,21 @@ 2004-11-14 Magnus Henoch <[email protected]> - * hashcash.el (hashcash-default-payment): Change default to 20 - (hashcash-default-accept-payment): Change default to 20 - (hashcash-process-alist): New variable - (hashcash-generate-payment-async): Add - (hashcash-already-paid-p): Add - (hashcash-insert-payment): Don't generate payments twice - (hashcash-insert-payment-async): Add - (hashcash-insert-payment-async-2): Add - (hashcash-cancel-async): Add - (hashcash-wait-async): Add - (hashcash-processes-running-p): Add - (hashcash-wait-or-cancel): Add + * hashcash.el (hashcash-default-payment): Change default to 20. + (hashcash-default-accept-payment): Change default to 20. + (hashcash-process-alist): New variable. + (hashcash-generate-payment-async): Add. + (hashcash-already-paid-p): Add. + (hashcash-insert-payment): Don't generate payments twice. + (hashcash-insert-payment-async): Add. + (hashcash-insert-payment-async-2): Add. + (hashcash-cancel-async): Add. + (hashcash-wait-async): Add. + (hashcash-processes-running-p): Add. + (hashcash-wait-or-cancel): Add. (mail-add-payment): New optional argument. Conditionally start asynchronous calculation. - (mail-add-payment-async): Add + (mail-add-payment-async): Add. * message.el (message-send-mail): Wait for asynchronous hashcash results. Don't clobber existing X-Hashcash headers. @@ -10069,8 +15204,8 @@ * deuglify.el (gnus-outlook-deuglify): Add :version. - * html2text.el: Beautify code. Improve doc strings. Some - checkdoc cleanup. + * html2text.el: Beautify code. Improve doc strings. + Some checkdoc cleanup. (html2text-get-attr, html2text-fix-paragraph): Simplify code. 2004-11-01 Alfred M. Szmidt <[email protected]> (tiny change) @@ -10086,8 +15221,8 @@ for people who want to override the default SpamAssassin over Bogofilter preference (when both are set). (spam-necessary-extra-headers): Add spam-use-bogofilter as an option. - (spam-user-format-function-S): Check - spam-summary-score-preferred-header. + (spam-user-format-function-S): + Check spam-summary-score-preferred-header. (spam-extra-header-to-number): Add X-Bogosity header parsing. (spam-user-format-function-S): Format the score correctly. @@ -10184,7 +15319,7 @@ 2004-10-18 Reiner Steib <[email protected]> * gnus-art.el (gnus-copy-article-ignored-headers): Default to - nil. Changed custom type. + nil. Change custom type. 2004-10-17 Reiner Steib <[email protected]> @@ -10236,8 +15371,8 @@ * netrc.el (netrc-machine-user-or-password): Add convenience wrapper for netrc-machine. - * nnimap.el (nnimap-open-connection): Use - netrc-machine-user-or-password. + * nnimap.el (nnimap-open-connection): + Use netrc-machine-user-or-password. 2004-10-17 Richard M. Stallman <[email protected]> @@ -10290,7 +15425,7 @@ * pop3.el (pop3-maildrop, pop3-mailhost, pop3-port) (pop3-password-required, pop3-authentication-scheme) - (pop3-leave-mail-on-server): Made customizable. + (pop3-leave-mail-on-server): Make customizable. (pop3): New custom group. (pop3-retr): Remove `sleep-for' statements. Suggested by Dave Love <[email protected]>. @@ -10299,8 +15434,8 @@ Windows/DOS. * imap.el (imap-parse-flag-list, imap-parse-body-extension) - (imap-parse-body): Fix incorrect use of `assert'. Suggested by - Dave Love <[email protected]>. + (imap-parse-body): Fix incorrect use of `assert'. + Suggested by Dave Love <[email protected]>. * mml.el (mml-minibuffer-read-disposition): Require match. Suggested by Dave Love <[email protected]>. @@ -10359,8 +15494,8 @@ * mm-decode.el (mm-dissect-singlepart): Revert 2004-08-18 change. - * gnus-topic.el (gnus-topic-hierarchical-parameters): Use - gnus-current-topics instead of gnus-current-topic. + * gnus-topic.el (gnus-topic-hierarchical-parameters): + Use gnus-current-topics instead of gnus-current-topic. 2004-10-06 Jesper Harder <[email protected]> @@ -10419,7 +15554,7 @@ (nnsoup-unpack-packets, nnsoup-make-active): Simplify. * nnspool.el (nnspool-find-id): Use with-temp-buffer. - (nnspool-sift-nov-with-sed): Use last + (nnspool-sift-nov-with-sed): Use last. (nnspool-retrieve-headers-with-nov): Use mapc. (nnspool-request-newgroups): Use dolist. (nnspool-request-group): Use last. @@ -10432,8 +15567,8 @@ 2004-10-01 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-synchronize-group-flags): Added - support for sync'ing tick marks. + * gnus-agent.el (gnus-agent-synchronize-group-flags): + Add support for sync'ing tick marks. 2004-10-01 Katsumi Yamaoka <[email protected]> @@ -10442,8 +15577,8 @@ 2004-10-01 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-synchronize-group-flags): When - necessary, pass full group name to gnus-request-set-marks. + * gnus-agent.el (gnus-agent-synchronize-group-flags): + When necessary, pass full group name to gnus-request-set-marks. 2004-10-01 Simon Josefsson <[email protected]> @@ -10472,11 +15607,11 @@ 2004-09-28 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-synchronize-group-flags): Replaced + * gnus-agent.el (gnus-agent-synchronize-group-flags): Replace gnus-requst-update-info with explicit code to sync the in-memory info read flags with the marks being sync'd to the backend. - *gnus-util.el (gnus-pp): Added optional stream to match pp API. + *gnus-util.el (gnus-pp): Add optional stream to match pp API. 2004-09-28 Teodor Zlatanov <[email protected]> @@ -10491,8 +15626,8 @@ 2004-09-28 Teodor Zlatanov <[email protected]> - * gnus-registry.el (gnus-registry-split-fancy-with-parent): Use - gnus-extract-references instead of gnus-split-references. + * gnus-registry.el (gnus-registry-split-fancy-with-parent): + Use gnus-extract-references instead of gnus-split-references. * gnus-util.el (gnus-extract-references): Add new function, analogous to gnus-split-references but extracts only the message-ID without @@ -10548,7 +15683,7 @@ 2004-09-25 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-check-overview-buffer): Fixed range of + * gnus-agent.el (gnus-agent-check-overview-buffer): Fix range of deletion to remove entire duplicate line. Fixes merged article number bug. @@ -10565,10 +15700,10 @@ Updates marks in memory (in the info structure) AND in the backend. - * gnus-util.el (gnus-remassoc): Fixed typo in documentation. + * gnus-util.el (gnus-remassoc): Fix typo in documentation. - * nnagent.el (nnagent-request-set-mark): Use - gnus-agent-synchronize-group-flags, not backend's request-set-mark + * nnagent.el (nnagent-request-set-mark): + Use gnus-agent-synchronize-group-flags, not backend's request-set-mark method, to ensure that synchronization updates marks in the backend and in the info (in memory) structure. @@ -10585,7 +15720,7 @@ an error. * gnus-int.el (gnus-request-set-mark, gnus-request-update-mark): - Reverted 2004-09-21 change. The backend must be opened while + Revert 2004-09-21 change. The backend must be opened while synchronizing flags even when the backend stores the flags locally. @@ -10647,7 +15782,7 @@ * nnimap.el (nnimap-split-download-body, nnimap-dont-close) (nnimap-retrieve-groups-asynchronous): Add :version. - (nnimap-close-asynchronous): Add :version. Fixed typo in doc string. + (nnimap-close-asynchronous): Add :version. Fix typo in doc string. * mml.el (mml-content-disposition-parameters) (mml-insert-mime-headers-always): Add :version. @@ -10861,8 +15996,8 @@ 2004-09-09 Kevin Greiner <[email protected]> - * gnus-agent.el (directory-files-and-attributes): Optionally - defined to support XEmacs. + * gnus-agent.el (directory-files-and-attributes): + Optionally defined to support XEmacs. 2004-09-09 Kevin Greiner <[email protected]> @@ -10873,27 +16008,27 @@ article numbers even when local .overview file is missing. (gnus-agent-read-article-number): New function. Only accepts 27-bit article numbers. - (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): Use - gnus-agent-read-article-number. + (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): + Use gnus-agent-read-article-number. (gnus-agent-braid-nov): Rewrote to validate article numbers coming from backend while recognizing that article numbers in .overview must be valid. - (gnus-agent-update-files-total-fetched-for): Use - directory-files-and-attributes to improve performance. - * gnus-int.el (gnus-request-move-article): Use - gnus-agent-unfetch-articles in place of gnus-agent-expire to + (gnus-agent-update-files-total-fetched-for): + Use directory-files-and-attributes to improve performance. + * gnus-int.el (gnus-request-move-article): + Use gnus-agent-unfetch-articles in place of gnus-agent-expire to improve performance. - * gnus-start.el (gnus-convert-old-newsrc): Changed message text as + * gnus-start.el (gnus-convert-old-newsrc): Change message text as some users confused by references to .newsrc when they only have a .newsrc.eld file. (gnus-convert-mark-converter-prompt) - (gnus-convert-converter-needs-prompt): Fixed use of property list. + (gnus-convert-converter-needs-prompt): Fix use of property list. * legacy-gnus-agent.el (gnus-agent-convert-to-compressed-agentview-prompt): New function. Used internally to only display 'gnus converting files' message when actually necessary. - * gnus-sum.el (): Removed (require 'gnus-agent) as required + * gnus-sum.el (): Remove (require 'gnus-agent) as required methods now autoloaded. 2004-09-03 Katsumi Yamaoka <[email protected]> @@ -10918,7 +16053,7 @@ * message.el: Don't autoload sha1 (there is a autoload cookie in sha1.el). - * sha1-el.el: Renamed to sha1.el. + * sha1-el.el: Rename to sha1.el. 2004-08-30 Juanma Barranquero <[email protected]> @@ -11057,13 +16192,13 @@ * gnus-sum.el (gnus-summary-make-menu-bar): Add help texts. - * gnus-art.el (gnus-button-alist): Improve - `gnus-button-handle-library' entry. + * gnus-art.el (gnus-button-alist): + Improve `gnus-button-handle-library' entry. 2004-08-19 Sebastian Freundt <[email protected]> (tiny change) - * nnmaildir.el (nnmaildir--emlink-p, nnmaildir--enoent-p): Use - downcase, since XEmacs capitalizes error messages differently. + * nnmaildir.el (nnmaildir--emlink-p, nnmaildir--enoent-p): + Use downcase, since XEmacs capitalizes error messages differently. 2004-08-18 Jesper Harder <[email protected]> @@ -11072,8 +16207,8 @@ 2004-08-18 Florian Weimer <[email protected]> - * gnus-sum.el (gnus-summary-force-verify-and-decrypt): Bind - `mm-fill-flowed'. + * gnus-sum.el (gnus-summary-force-verify-and-decrypt): + Bind `mm-fill-flowed'. * mm-decode.el (mm-dissect-singlepart): Check it. @@ -11107,8 +16242,8 @@ 2004-08-06 Simon Josefsson <[email protected]> - * gnus-sum.el (gnus-article-loose-mime): Change default to t. Doc - fix. + * gnus-sum.el (gnus-article-loose-mime): Change default to t. + Doc fix. 2004-08-05 Katsumi Yamaoka <[email protected]> @@ -11117,10 +16252,10 @@ 2004-08-04 Teodor Zlatanov <[email protected]> - * gnus-registry.el (gnus-registry-split-fancy-with-parent): Try - to append in-reply-to: data to the references: header. + * gnus-registry.el (gnus-registry-split-fancy-with-parent): + Try to append in-reply-to: data to the references: header. - * netrc.el: Remove old encryption support, autoload gnus-encrypt.el + * netrc.el: Remove old encryption support, autoload gnus-encrypt.el. (netrc-parse): Use gnus-encrypt.el functions. * gnus-encrypt.el: Add new file for encryption support; currently @@ -11150,8 +16285,8 @@ 2004-07-25 Katsumi Yamaoka <[email protected]> - * rfc2047.el (rfc2047-encode-region): Don't infloop. Suggested by - Hiroshi Fujishima <[email protected]>. + * rfc2047.el (rfc2047-encode-region): Don't infloop. + Suggested by Hiroshi Fujishima <[email protected]>. 2004-07-25 Lars Magne Ingebrigtsen <[email protected]> @@ -11232,8 +16367,8 @@ 2004-07-02 Katsumi Yamaoka <[email protected]> - * mm-encode.el (mm-content-transfer-encoding-defaults): Use - qp-or-base64 for the application/* types. + * mm-encode.el (mm-content-transfer-encoding-defaults): + Use qp-or-base64 for the application/* types. 2004-07-02 Joakim Verona <[email protected]> (tiny change) @@ -11257,8 +16392,8 @@ 2004-06-29 Lars Magne Ingebrigtsen <[email protected]> - * gnus-group.el (gnus-group-get-new-news-this-group): Don't - update info that isn't there. + * gnus-group.el (gnus-group-get-new-news-this-group): + Don't update info that isn't there. 2004-06-29 Ilya N. Golubev <[email protected]>. @@ -11289,15 +16424,15 @@ (mm-coding-system-priorities): Use shift_jis and iso-8859-1 instead of japanese-shift-jis and iso-latin-1 respectively in order to share the default value with both Emacs and XEmacs-mule. - (mm-mule-charset-to-mime-charset): Make - mm-coding-system-priorities effective. + (mm-mule-charset-to-mime-charset): + Make mm-coding-system-priorities effective. (mm-sort-coding-systems-predicate): Canonicalize coding-systems while predicating of candidates upon the priorities. 2004-06-27 Jesper Harder <[email protected]> - * gnus-sum.el (gnus-summary-make-menu-bar): Add - gnus-uu-invert-processable. + * gnus-sum.el (gnus-summary-make-menu-bar): + Add gnus-uu-invert-processable. * gnus.el: Autoload gnus-uu-invert-processable. @@ -11317,8 +16452,8 @@ 2004-06-23 Katsumi Yamaoka <[email protected]> * gnus-cite.el (gnus-cite-ignore-quoted-from): New user option. - (gnus-cite-parse): Ignore quoted envelope From_. Suggested by - Karl Chen <[email protected]>. + (gnus-cite-parse): Ignore quoted envelope From_. + Suggested by Karl Chen <[email protected]>. 2004-06-23 Jesper Harder <[email protected]> @@ -11373,8 +16508,8 @@ (spam-move-ham-routine): Add code to copy/move ham or spam. (spam-fetch-field-fast): Improve doc and code, plus allow the 'number request. - (spam-list-of-checks, spam-list-of-statistical-checks): Remove - variables. + (spam-list-of-checks, spam-list-of-statistical-checks): + Remove variables. (spam-split, spam-find-spam): Use the new backend code. (spam-registration-functions): Remove variable. (spam-unregister-routine): Add convenience wrapper. @@ -11449,8 +16584,8 @@ (nnheader-fake-message-id-p): Change regex to accommodate new fake ID format. - * gnus-sum.el (gnus-get-newsgroup-headers): Call - nnheader-generate-fake-message-id with the article number. + * gnus-sum.el (gnus-get-newsgroup-headers): + Call nnheader-generate-fake-message-id with the article number. 2004-06-12 YAGI Tatsuya <[email protected]> (tiny change) @@ -11521,8 +16656,8 @@ 2004-06-06 Lars Magne Ingebrigtsen <[email protected]> - * message.el (message-cite-articles-with-x-no-archive): New - variable. + * message.el (message-cite-articles-with-x-no-archive): + New variable. (message-cite-original): Use it. 2004-06-04 Lars Magne Ingebrigtsen <[email protected]> @@ -11556,12 +16691,12 @@ 2004-05-28 Reiner Steib <[email protected]> - * gnus-art.el (gnus-button-alist): Fixed regexp for manual links. + * gnus-art.el (gnus-button-alist): Fix regexp for manual links. - * gnus-group.el (gnus-group-get-new-news-this-group): Added - doc-string. + * gnus-group.el (gnus-group-get-new-news-this-group): + Add doc-string. - * gnus-start.el (gnus-activate-group): Added doc-string. + * gnus-start.el (gnus-activate-group): Add doc-string. 2004-05-28 Katsumi Yamaoka <[email protected]> @@ -11582,21 +16717,21 @@ 2004-05-27 Daniel Pittman <[email protected]> - * spam.el (spam-report-resend-register-routine): Allow - spam-report-resend-to to be a group parameter or a global value. + * spam.el (spam-report-resend-register-routine): + Allow spam-report-resend-to to be a group parameter or a global value. 2004-05-26 Simon Josefsson <[email protected]> * starttls.el: Merge with my GNUTLS based starttls.el. (starttls-gnutls-program, starttls-use-gnutls) (starttls-extra-arguments, starttls-process-connection-type) - (starttls-connect, starttls-failure, starttls-success): New - variables. + (starttls-connect, starttls-failure, starttls-success): + New variables. (starttls-program, starttls-extra-args): Doc fix. - (starttls-negotiate-gnutls, starttls-open-stream-gnutls): New - functions. - (starttls-negotiate, starttls-open-stream): Check - `starttls-use-gnutls' and pass on to corresponding *-gnutls + (starttls-negotiate-gnutls, starttls-open-stream-gnutls): + New functions. + (starttls-negotiate, starttls-open-stream): + Check `starttls-use-gnutls' and pass on to corresponding *-gnutls function if it is set. 2004-05-27 Katsumi Yamaoka <[email protected]> @@ -11610,14 +16745,14 @@ 2004-05-26 Teodor Zlatanov <[email protected]> - * spam.el (spam-mark-new-messages-in-spam-group-as-spam): Add - variable. + * spam.el (spam-mark-new-messages-in-spam-group-as-spam): + Add variable. (spam-mark-junk-as-spam-routine): Use it. Allow to disable assigning the spam-mark to new messages. 2004-05-26 Adam Sjøgren <[email protected]> (tiny change) - (spam-ham-copy-or-move-routine): Don't declare `todo' twice. + * spam.el (spam-ham-copy-or-move-routine): Don't declare `todo' twice. 2004-05-26 Katsumi Yamaoka <[email protected]> @@ -11663,8 +16798,8 @@ 2004-05-24 Daniel Pittman <[email protected]> - * spam-report.el (spam-report-resend-to, spam-report-resend): Start - with resend-to set to nil, and then ask the user if necessary. + * spam-report.el (spam-report-resend-to, spam-report-resend): + Start with resend-to set to nil, and then ask the user if necessary. (spam-report-resend): spam-report-resend takes a list of articles, not separate article numbers. @@ -11753,8 +16888,8 @@ (spam-crm114-register-spam-routine) (spam-crm114-unregister-spam-routine) (spam-crm114-register-ham-routine) - (spam-crm114-unregister-ham-routine): Add CRM114 support. From - [email protected] (Adam Sjøgren). + (spam-crm114-unregister-ham-routine): Add CRM114 support. + From [email protected] (Adam Sjøgren). * gnus.el: Add spam-use-crm114. @@ -11782,7 +16917,7 @@ 2004-05-20 Katsumi Yamaoka <[email protected]> - * rfc2047.el (rfc2047-encode-function-alist): Renamed from + * rfc2047.el (rfc2047-encode-function-alist): Rename from `rfc2047-encoding-function-alist' in order to avoid conflicting with the old version. (rfc2047-encode-region): Concatenate words containing non-ASCII @@ -11795,17 +16930,17 @@ iso-2022-* charsets. (rfc2047-fold-region): Use existing whitespace for LWSP; make it sure not to break a line just after the header name. - (rfc2047-b-encode-region): Removed. + (rfc2047-b-encode-region): Remove. (rfc2047-b-encode-string): New function. - (rfc2047-q-encode-region): Removed. + (rfc2047-q-encode-region): Remove. (rfc2047-q-encode-string): New function. * mm-util.el (mm-replace-in-string): New function. 2004-05-20 Lars Magne Ingebrigtsen <[email protected]> - * gnus-msg.el (gnus-inews-make-draft-meta-information): Really - get it right. + * gnus-msg.el (gnus-inews-make-draft-meta-information): + Really get it right. (gnus-inews-make-draft): Really. 2004-05-19 Ben Menasha <[email protected]> @@ -11818,8 +16953,8 @@ * gnus-msg.el (gnus-inews-make-draft-meta-information): Fix quote stuff. - * gnus-start.el (gnus-subscribe-hierarchical-interactive): Match - on real group name. + * gnus-start.el (gnus-subscribe-hierarchical-interactive): + Match on real group name. * gnus-art.el (gnus-signature-limit): Doc fix. @@ -11827,8 +16962,8 @@ 2004-05-19 Lars Magne Ingebrigtsen <[email protected]> - * gnus-draft.el (gnus-draft-send): Bind - rfc2047-encode-encoded-words. + * gnus-draft.el (gnus-draft-send): + Bind rfc2047-encode-encoded-words. * rfc2047.el (rfc2047-encode-region): Encode =? strings. (rfc2047-encodable-p): Say that =? needs encoding. @@ -11847,8 +16982,8 @@ 2004-05-19 Reiner Steib <[email protected]> - * gnus-msg.el (gnus-summary-followup-with-original): Document - yanking of region when active. + * gnus-msg.el (gnus-summary-followup-with-original): + Document yanking of region when active. 2004-05-19 Katsumi Yamaoka <[email protected]> @@ -11858,7 +16993,7 @@ 2004-05-18 Reiner Steib <[email protected]> * gnus-group.el (gnus-group-jump-to-group-prompt): Allow an alist. - (gnus-group-jump-to-group): Added prefix argument using + (gnus-group-jump-to-group): Add prefix argument using `gnus-group-jump-to-group-prompt'. Query before jumping to non-active group. @@ -11892,9 +17027,9 @@ 2004-05-18 Reiner Steib <[email protected]> * gnus-picon.el (gnus-picon-style): New variable. - (gnus-picon-insert-glyph): Added optional `nostring' argument. - (gnus-picon-transform-address): Support `gnus-picon-style'. From - Jesper Harder <[email protected]>. + (gnus-picon-insert-glyph): Add optional `nostring' argument. + (gnus-picon-transform-address): Support `gnus-picon-style'. + From Jesper Harder <[email protected]>. 2004-05-18 Lars Magne Ingebrigtsen <[email protected]> @@ -11935,7 +17070,7 @@ (message-fill-field-address): Rename. (message-narrow-to-field): Find the start of the header. (message-header-format-alist): Don't pre-fill. - (message-fill-header): Removed. + (message-fill-header): Remove. (message-insert-header): New function. (message-shorten-references): Use it. @@ -11954,10 +17089,10 @@ 2004-05-16 Lars Magne Ingebrigtsen <[email protected]> - * message.el (message-idna-inside-rhs-p): Removed. + * message.el (message-idna-inside-rhs-p): Remove. (message-idna-to-ascii-rhs-1): Use proper address parsing. - * gnus-art.el (gnus-emphasis-alist): Removed strikethru; too many + * gnus-art.el (gnus-emphasis-alist): Remove strikethru; too many false positives. 2004-05-16 Kim-Minh Kaplan <[email protected]> @@ -11980,7 +17115,7 @@ 2004-05-15 Teodor Zlatanov <[email protected]> - * spam.el (spam-summary-prepare-exit): Fixed (length). + * spam.el (spam-summary-prepare-exit): Fix (length). 2004-05-14 Teodor Zlatanov <[email protected]> @@ -11995,8 +17130,8 @@ 2004-05-14 Kai Grossjohann <[email protected]> - * nntp.el (nntp-request-set-mark, nntp-request-update-info): Call - nntp-possibly-create-directory, not nntp-possibly-change-group. + * nntp.el (nntp-request-set-mark, nntp-request-update-info): + Call nntp-possibly-create-directory, not nntp-possibly-change-group. (nntp-marks-changed-p): New arg SERVER. (nntp-request-update-info): Adjust caller. @@ -12011,13 +17146,13 @@ (nntp-marks-modtime, nntp-marks-directory): New variables. (nntp-request-set-mark, nntp-request-update-info) (nntp-possibly-create-directory, nntp-marks-changed-p) - (nntp-save-marks, nntp-open-marks, nntp-marks-directory): New - functions. + (nntp-save-marks, nntp-open-marks, nntp-marks-directory): + New functions. 2004-05-12 Jesper Harder <[email protected]> - * gnus-score.el (gnus-score-insert-help): Use - gnus-select-lowest-window. + * gnus-score.el (gnus-score-insert-help): + Use gnus-select-lowest-window. * gnus-ems.el (gnus-select-lowest-window): Copy definition of appt-select-lowest-window and rename to gnus-select-lowest-window. @@ -12057,8 +17192,8 @@ 2004-05-01 Lars Magne Ingebrigtsen <[email protected]> - * gnus-agent.el (gnus-agent-read-agentview): Inline - gnus-uncompress-range. + * gnus-agent.el (gnus-agent-read-agentview): + Inline gnus-uncompress-range. 2004-05-01 TSUCHIYA Masatoshi <[email protected]> @@ -12067,8 +17202,8 @@ 2004-04-30 TSUCHIYA Masatoshi <[email protected]> - * gnus.el (spam-process, spam-autodetect-methods): Add - bsfilter and bsfilter-headers. + * gnus.el (spam-process, spam-autodetect-methods): + Add bsfilter and bsfilter-headers. * spam.el (spam-bsfilter): New customize group. (spam-use-bsfilter, spam-use-bsfilter-headers, spam-bsfilter-path) @@ -12118,7 +17253,7 @@ * spam.el (spam-summary-prepare-exit) (spam-mark-junk-as-spam-routine, spam-fetch-field-fast) (spam-split, spam-find-spam, spam-log-undo-registration) - (spam-check-blackholes, spam-enter-ham-BBDB): Changed message + (spam-check-blackholes, spam-enter-ham-BBDB): Change message level from 5 to 6. 2004-04-26 Katsumi Yamaoka <[email protected]> @@ -12219,7 +17354,7 @@ 2004-04-15 Kevin Greiner <[email protected]> * legacy-gnus-agent.el - (gnus-agent-convert-to-compressed-agentview): Fixed typos with + (gnus-agent-convert-to-compressed-agentview): Fix typos with help from Florian Weimer <[email protected]> 2004-04-15 Katsumi Yamaoka <[email protected]> @@ -12280,25 +17415,25 @@ `method' parameter is nil. Don't write nil entries into the active file. (gnus-agent-get-group-info): New function. - (gnus-agent-fetch-articles): Use - gnus-agent-update-files-total-fetched-for to increment disk space + (gnus-agent-fetch-articles): + Use gnus-agent-update-files-total-fetched-for to increment disk space used. - (gnus-agent-fetch-headers, gnus-agent-save-alist): Use - gnus-agent-update-view-total-fetched-for to increment disk space + (gnus-agent-fetch-headers, gnus-agent-save-alist): + Use gnus-agent-update-view-total-fetched-for to increment disk space used. - (gnus-agent-get-local): Added optional parameters to avoid calling + (gnus-agent-get-local): Add optional parameters to avoid calling gnus-group-real-name and gnus-find-method-for-group. (gnus-agent-set-local): Delete stored entry if either min, or max, are nil. - (gnus-agent-fetch-session): Reworded error/quit messages. On - quit, use gnus-agent-regenerate-group to record existence of any + (gnus-agent-fetch-session): Reworded error/quit messages. + On quit, use gnus-agent-regenerate-group to record existence of any articles fetched to disk before the quit occurred. (gnus-agent-expire-group-1): Use gnus-agent-with-refreshed-group, gnus-agent-update-view-total-fetched-for, and gnus-agent-update-files-total-fetched-for to decrement disk space used. - (gnus-agent-retrieve-headers): Use - gnus-agent-update-view-total-fetched-for to increment disk space + (gnus-agent-retrieve-headers): + Use gnus-agent-update-view-total-fetched-for to increment disk space used. (gnus-agent-regenerate-group): Replace gnus-group-update-group with gnus-agent-update-files-total-fetched-for to decrement disk @@ -12309,14 +17444,14 @@ (gnus-agent-update-view-total-fetched-for): New function. (gnus-agent-total-fetched-for): New function. - * gnus-cache.el (gnus-cache-save-buffers): Use - gnus-cache-update-overview-total-fetched-for to change disk space + * gnus-cache.el (gnus-cache-save-buffers): + Use gnus-cache-update-overview-total-fetched-for to change disk space used by this group. - (gnus-cache-possibly-enter-article): Use - gnus-cache-update-file-total-fetched-for to increment disk space + (gnus-cache-possibly-enter-article): + Use gnus-cache-update-file-total-fetched-for to increment disk space used by this group. - (gnus-cache-possibly-remove-article): Use - gnus-cache-update-file-total-fetched-for to decrement disk space + (gnus-cache-possibly-remove-article): + Use gnus-cache-update-file-total-fetched-for to decrement disk space used by this group. (gnus-cache-generate-nov-databases): Purge total fetched cache. (gnus-cache-rename-group): New function. @@ -12332,7 +17467,7 @@ * gnus-group.el: Require gnus-sum and autoload functions to resolve warnings when gnus-group.el compiled alone. - (gnus-group-line-format): Documented new %F + (gnus-group-line-format): Documented new %F. (size of Fetched data) group line format; identifies disk space used by agent and cache. (gnus-group-line-format-alist): Defined new F format. @@ -12387,8 +17522,8 @@ 2004-03-27 Katsumi Yamaoka <[email protected]> - * message.el (message-exchange-point-and-mark): Use - message-mark-active-p. Suggested by Jesper Harder + * message.el (message-exchange-point-and-mark): + Use message-mark-active-p. Suggested by Jesper Harder 2004-03-26 Katsumi Yamaoka <[email protected]> @@ -12437,8 +17572,8 @@ 2004-03-19 Katsumi Yamaoka <[email protected]> - * gnus-art.el (gnus-mime-recompute-hierarchical-structure): New - user option. + * gnus-art.el (gnus-mime-recompute-hierarchical-structure): + New user option. (gnus-mime-multipart-functions): Doc and customization fix. (gnus-article-mime-hierarchy): New variable. (gnus-article-mime-hierarchy-next): New variable. @@ -12506,8 +17641,8 @@ 2004-03-09 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-read-local): Bind - nnheader-file-coding-system to gnus-agent-file-coding-system to + * gnus-agent.el (gnus-agent-read-local): + Bind nnheader-file-coding-system to gnus-agent-file-coding-system to avoid the implicit assumption that they will always be equal. (gnus-agent-save-local): Bind buffer-file-coding-system, not coding-system-for-write, as the with-temp-file macro first prints @@ -12522,16 +17657,16 @@ 2004-03-08 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-read-agentview): Removed support for + * gnus-agent.el (gnus-agent-read-agentview): Remove support for old file versions. - (gnus-group-prepare-hook): Removed function that converted list + (gnus-group-prepare-hook): Remove function that converted list form of gnus-agent-expire-days to group properties. * gnus-int.el: Autoload gnus-agent-regenerate-group. (gnus-request-accept-article): Re-indented. * gnus-start.el (gnus-convert-old-newsrc): Registered new - converters to handle old agent file formats. Added logic for a + converters to handle old agent file formats. Add logic for a "backup before upgrading warning". (gnus-convert-mark-converter-prompt): Developers can mark functions as needing (default), or not needing, @@ -12632,7 +17767,7 @@ 2004-03-04 Kevin Greiner <[email protected]> - * gnus-agent.el (gnus-agent-file-header-cache): Removed. + * gnus-agent.el (gnus-agent-file-header-cache): Remove. (gnus-agent-possibly-alter-active): Avoid null in numeric comparison. (gnus-agent-set-local): Refuse to save null in local object table. @@ -12653,8 +17788,8 @@ * gnus-agent.el (gnus-agent-read-local, gnus-agent-save-local): Don't bind "obarray". - * gnus-sum.el (gnus-thread-sort-functions): Added - `gnus-thread-sort-by-most-recent-number' and + * gnus-sum.el (gnus-thread-sort-functions): + Add `gnus-thread-sort-by-most-recent-number' and `gnus-thread-sort-by-most-recent-date'. Reported by Kai Grossjohann <[email protected]>. @@ -12664,8 +17799,8 @@ 2004-03-02 Kevin Greiner <[email protected]> - * gnus-cus.el (gnus-agent-customize-category): Removed - ignore-errors macro reference that required cl to be loaded at + * gnus-cus.el (gnus-agent-customize-category): + Remove ignore-errors macro reference that required cl to be loaded at run-time. * gnus-range.el (gnus-sorted-range-intersection): Now accepts @@ -12703,8 +17838,8 @@ * gnus-msg.el (gnus-setup-message): Ignore an article copy while parsing gnus-posting-styles when the message is not for replying. - * nnrss.el (nnrss-opml-export): Use - mm-set-buffer-file-coding-system instead of + * nnrss.el (nnrss-opml-export): + Use mm-set-buffer-file-coding-system instead of set-buffer-file-coding-system. 2004-02-27 Jesper Harder <[email protected]> @@ -12750,20 +17885,20 @@ * spam-stat.el (spam-stat-washing-hook): New option. (spam-stat-buffer-words): Use it. - (spam-stat-process-directory, spam-stat-test-directory): Use - insert-file-contents-literally. + (spam-stat-process-directory, spam-stat-test-directory): + Use insert-file-contents-literally. (spam-stat-coding-system): New variable. (spam-stat-load, spam-stat-save): Use it. 2004-02-25 Katsumi Yamaoka <[email protected]> - * spam-report.el (spam-report-plug-agent): Quote - spam-report-url-to-file and spam-report-url-ping-plain. + * spam-report.el (spam-report-plug-agent): + Quote spam-report-url-to-file and spam-report-url-ping-plain. 2004-02-25 Reiner Steib <[email protected]> - * gnus-art.el (gnus-button-alist, gnus-header-button-alist): Allow - / in mailto URLs. + * gnus-art.el (gnus-button-alist, gnus-header-button-alist): + Allow / in mailto URLs. 2004-02-24 Reiner Steib <[email protected]> @@ -12771,9 +17906,8 @@ (spam-report-url-ping-temp-agent-function, spam-report-plug-agent) (spam-report-unplug-agent): Doc fixes. (spam-report-url-ping-mm-url, spam-report-url-to-file) - (spam-report-agentize, spam-report-deagentize): Autoload - -2004-02-24 Katsumi Yamaoka <[email protected]> + (spam-report-agentize, spam-report-deagentize): + Autoload 2004-02-24 Katsumi Yamaoka <[email protected]> * message.el (message-setup-fill-variables): Add mml tags to paragraph-start and paragraph-separate. Suggested by Andrew Korty @@ -12835,8 +17969,8 @@ (nntp-send-buffer, nntp-retrieve-groups, nntp-handle-authinfo) (nntp-possibly-change-group): Use it. - * nnnil.el (nnnil-retrieve-headers, nnnil-request-list): Use - with-current-buffer. + * nnnil.el (nnnil-retrieve-headers, nnnil-request-list): + Use with-current-buffer. 2004-02-12 TAKAI Kousuke <[email protected]> @@ -12973,8 +18107,8 @@ 2004-02-03 Jesper Harder <[email protected]> - * spam.el (spam-check-spamoracle, spam-spamoracle-learn): Fix - format string mismatch. + * spam.el (spam-check-spamoracle, spam-spamoracle-learn): + Fix format string mismatch. * sieve.el (sieve-deactivate-all): do. @@ -13035,8 +18169,8 @@ New macros and functions. * nnmaildir.el (nnmaildir--group-maxnum, nnmaildir--update-nov): Handle > NLINK_MAX messages. - * nnmaildir.el (nnmaildir-request-set-mark): Use - nnmaildir--emlink-p and nnmaildir--eexist-p. + * nnmaildir.el (nnmaildir-request-set-mark): + Use nnmaildir--emlink-p and nnmaildir--eexist-p. 2004-01-25 Alex Schroeder <[email protected]> @@ -13076,8 +18210,8 @@ 2004-01-23 Jesper Harder <[email protected]> - * spam-stat.el (spam-stat-store-gnus-article-buffer): Use - with-current-buffer. + * spam-stat.el (spam-stat-store-gnus-article-buffer): + Use with-current-buffer. (spam-stat-store-current-buffer): Use insert-buffer-substring to avoid consing a string. @@ -13103,29 +18237,29 @@ (gnus-agent-prompt-send-queue): New variables. (gnus-agent-send-mail): Use gnus-agent-queue-mail. * gnus-draft.el (gnus-group-send-queue): Pass the group name - "nndraft:queue" along to gnus-draft-send. Use - gnus-agent-prompt-send-queue. + "nndraft:queue" along to gnus-draft-send. + Use gnus-agent-prompt-send-queue. (gnus-draft-send): Rebind gnus-agent-queue-mail to nil when group is "nndraft:queue". Suggested by Gaute Strokkenes - * gnus-agent.el (agent-disable-undownloaded-faces): Removed - (agent-enable-undownloaded-faces): Added + * gnus-agent.el (agent-disable-undownloaded-faces): Remove. + (agent-enable-undownloaded-faces): Add. (gnus-agent-cat-groups): Use eval-and-compile, not eval-when-compile, to define gnus-agent-set-cat-groups as the setf method of gnus-agent-cat-groups even when the buffer has been evaled. - (gnus-agent-save-active, gnus-agent-save-active-1): Merged to + (gnus-agent-save-active, gnus-agent-save-active-1): Merge to delete gnus-agent-save-active-1. - (gnus-agent-save-groups): Deleted. Identical to + (gnus-agent-save-groups): Delete. Identical to gnus-agent-save-active. (gnus-agent-write-active): No longer adjust agent's copy of active file as agent's adjustments are now stored in their own - file. Removed optional parameter. + file. Remove optional parameter. (gnus-agent-possibly-alter-active): Ignore groups of unagentized servers. Add use of min/max range limits from server's local file. - (gnus-agent-save-alist): Removed unused optional argument. + (gnus-agent-save-alist): Remove unused optional argument. (gnus-agent-load-local, gnus-agent-read-and-cache-local) (gnus-agent-read-local, gnus-agent-save-local, gnus-agent-get-local) (gnus-agent-set-local): A per-server file that keeps min/max range @@ -13133,10 +18267,10 @@ for altering many active ranges. (gnus-agent-expire-group, gnus-agent-expire): No longer save the active file (local makes it unnecessary). - (gnus-agent-regenerate-group): Fixed XEmacs compatibility. + (gnus-agent-regenerate-group): Fix XEmacs compatibility. - * gnus-cus.el (agent-disable-undownloaded-faces): Removed - (agent-enable-undownloaded-faces): Added + * gnus-cus.el (agent-disable-undownloaded-faces): Remove. + (agent-enable-undownloaded-faces): Add. * gnus-draft.el (gnus-draft-send): Bind gnus-agent-queue-mail to disable it when sending to "nndraft:queue". @@ -13149,7 +18283,7 @@ numbers of articles. Use gnus-range-map to avoid having to uncompress the unread list. (gnus-group-archive-directory, gnus-group-recent-archive-directory): - Fixed invalid ange-ftp reference. + Fix invalid ange-ftp reference. * gnus-range.el (gnus-range-map): Iterate over list or sequence. (gnus-sorted-range-intersection): Intersection of two ranges @@ -13160,11 +18294,11 @@ and agentized articles. (gnus-convert-old-newsrc): Rewrote in anticipation of having multiple version-dependent converters. - (gnus-groups-to-gnus-format): Replaced gnus-agent-save-groups with + (gnus-groups-to-gnus-format): Replace gnus-agent-save-groups with gnus-agent-save-active. (gnus-save-newsrc-file): Save dirty agent range limits. - * gnus-sum.el (gnus-select-newgroup): Replaced inline code with + * gnus-sum.el (gnus-select-newgroup): Replace inline code with gnus-agent-possibly-alter-active. (gnus-adjust-marked-articles): Faster handling of simple lists @@ -13205,8 +18339,8 @@ spam-use-spamassassin or spam-use-spamassassin-headers is on; spam-bogofilter-score otherwise. - * gnus.el (spam-process, spam-autodetect-methods): Add - spamassassin and spamassassin-headers. + * gnus.el (spam-process, spam-autodetect-methods): + Add spamassassin and spamassassin-headers. 2004-01-20 Nevin Kapur <[email protected]> @@ -13270,7 +18404,7 @@ 2004-01-14 Kai Grossjohann <[email protected]> - (message-kill-to-signature): Change docstring. + * message.el (message-kill-to-signature): Change docstring. 2004-01-14 Katsumi Yamaoka <[email protected]> @@ -13290,11 +18424,11 @@ 2004-01-13 Simon Josefsson <[email protected]> * gnus-score.el (gnus-score-edit-all-score): Fix prototype. - Invoke gnus-score-mode. Reported by - [email protected] (Johan Bockgård). + Invoke gnus-score-mode. + Reported by [email protected] (Johan Bockgård). - * gnus-range.el (gnus-compress-sequence): Doc fix. Suggested by - Jim Blandy <[email protected]> (tiny change). + * gnus-range.el (gnus-compress-sequence): Doc fix. + Suggested by Jim Blandy <[email protected]> (tiny change). 2004-01-12 Jesper Harder <[email protected]> @@ -13417,8 +18551,8 @@ * mm-bodies.el: base64 is always built-in. - * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use - with-current-buffer. + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): + Use with-current-buffer. 2004-01-08 Katsumi Yamaoka <[email protected]> @@ -13455,8 +18589,8 @@ 2004-01-08 Jesper Harder <[email protected]> * gnus-art.el (gnus-mime-view-all-parts) - (gnus-article-part-wrapper, gnus-article-view-part): Use - with-current-buffer. + (gnus-article-part-wrapper, gnus-article-view-part): + Use with-current-buffer. 2004-01-07 Teodor Zlatanov <[email protected]> @@ -13503,10 +18637,10 @@ (spam-find-spam): Don't try to guess spam-cache-lookups. (spam-enter-whitelist, spam-enter-blacklist): Clear the spam-caches entry. - (spam-filelist-build-cache, spam-filelist-check-cache): Fix - caching of whitelist/blacklist entries. - (spam-check-whitelist, spam-check-blacklist): Invoke - spam-from-listed-p with a type, not a cache variable. + (spam-filelist-build-cache, spam-filelist-check-cache): + Fix caching of whitelist/blacklist entries. + (spam-check-whitelist, spam-check-blacklist): + Invoke spam-from-listed-p with a type, not a cache variable. (spam-from-listed-p): Wrap around spam-filelist-check-cache. 2004-01-07 Jesper Harder <[email protected]> @@ -13585,7 +18719,7 @@ 2004-01-06 Reiner Steib <[email protected]> - * gnus-art.el (gnus-treat-ansi-sequences): Changed default. + * gnus-art.el (gnus-treat-ansi-sequences): Change default. 2004-01-07 Steve Youngs <[email protected]> @@ -13618,10 +18752,10 @@ * gnus-art.el (gnus-button-push): Use set-text-properties instead of gnus-. - * gnus.el: Changed calls to nnheader-run-at-time and + * gnus.el: Change calls to nnheader-run-at-time and password-run-at-time throughout to use run-at-time directly. - * password.el: Removed definition of run-at-time. + * password.el: Remove definition of run-at-time. 2004-01-05 Karl Pflästerer <[email protected]> (tiny change) @@ -13647,8 +18781,8 @@ * gnus-util.el (gnus-local-map-property): Remove. - * mm-view.el (mm-view-pkcs7-decrypt): Replace - gnus-completing-read-maybe-default with completing-read. + * mm-view.el (mm-view-pkcs7-decrypt): + Replace gnus-completing-read-maybe-default with completing-read. * gnus-util.el (gnus-completing-read): do. (gnus-completing-read-maybe-default): Remove. @@ -13668,8 +18802,8 @@ * netrc.el: Autoload password-read. (netrc): Add configuration group. - (netrc-encoding-method, netrc-openssl-path): Add - variables for encoding and decoding of files with symmetric + (netrc-encoding-method, netrc-openssl-path): + Add variables for encoding and decoding of files with symmetric ciphers. (netrc-encode): Add assistant function to encode a file with netrc-encoding-method. @@ -13689,7 +18823,7 @@ 2004-01-05 Reiner Steib <[email protected]> - * gnus-art.el (gnus-treat-ansi-sequences, + * gnus-art.el (gnus-treat-ansi-sequences) (article-treat-ansi-sequences): New variable and function. Suggested by Dan Jacobson <[email protected]>. @@ -13756,8 +18890,8 @@ * smime.el (smime-point-at-eol): Replace with point-at-eol. - * rfc2047.el (rfc2047-point-at-bol, rfc2047-point-at-eol): Replace - with point-at-{eol,bol}. + * rfc2047.el (rfc2047-point-at-bol, rfc2047-point-at-eol): + Replace with point-at-{eol,bol}. * netrc.el (netrc-point-at-eol): Replace with point-at-eol. @@ -13794,13 +18928,13 @@ ntlm-smb-perm5, smb-perm6 into ntlm-smb-perm6, smb-sc into ntlm-smb-sc, smb-sbox into ntlm-smb-sbox, string-permute into ntlm-string-permute, string-lshift into ntlm-string-lshift, - string-xor into ntlm-string-xor. Suggested by - Jesper Harder <[email protected]>. + string-xor into ntlm-string-xor. + Suggested by Jesper Harder <[email protected]>. * ntlm.el: Don't include poem. - * md4.el (print-int32, print-string-hexa): Remove. Suggested by - Jesper Harder <[email protected]>. + * md4.el (print-int32, print-string-hexa): Remove. + Suggested by Jesper Harder <[email protected]>. * sasl-ntlm.el, ntlm.el, md4.el: New files. @@ -13814,8 +18948,8 @@ condition-case around loop. * pgg.el (pgg-passphrase-cache, pgg-run-at-time): Remove. - (pgg-add-passphrase-cache, pgg-remove-passphrase-cache): Use - the password package. + (pgg-add-passphrase-cache, pgg-remove-passphrase-cache): + Use the password package. 2003-02-19 Simon Josefsson <[email protected]> @@ -13868,15 +19002,15 @@ 2004-01-04 Mario Lang <[email protected]> * dns.el (dns-query-types): Fix typo. - (dns-query-types): New function + (dns-query-types): New function. (dns-read-type): Add support for AAAA records, see RFC 3596. Parse MX, PTR and SOA replies, see RFC 1035. 2004-01-04 Lars Magne Ingebrigtsen <[email protected]> - * gnus.el (gnus-logo-color-style): Changed colors to `no'. + * gnus.el (gnus-logo-color-style): Change colors to `no'. - * Moved to Changelog.2. + * Move to Changelog.2. 2004-01-04 Lars Magne Ingebrigtsen <[email protected]> @@ -13919,5 +19053,3 @@ See ChangeLog.2 for earlier changes. ;; fill-column: 79 ;; add-log-time-zone-rule: t ;; End: - -;;; arch-tag: 3f33a3e7-090d-492b-bedd-02a1417d32b4 diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1 index 0338f9a8d1..aef65e8116 100644 --- a/lisp/gnus/ChangeLog.1 +++ b/lisp/gnus/ChangeLog.1 @@ -28,10 +28,10 @@ * gnus-start.el (gnus-slave-save-newsrc): * gnus-uu.el (gnus-uu-tmp-dir, gnus-uu-decode-binhex) - (gnus-uu-decode-binhex-view, gnus-uu-digest-mail-forward) - (gnus-uu-initialize): + (gnus-uu-decode-binhex-view, gnus-uu-digest-mail-forward) + (gnus-uu-initialize): * nnmail.el (nnmail-make-complex-temp-name, nnmail-get-new-mail): - Use make-temp-file. + Use make-temp-file. 1999-09-07 Eli Zaretskii <[email protected]> @@ -506,10 +506,10 @@ 1998-08-13 Simon Josefsson <[email protected]> - * gnus-msg.el (gnus-setup-message): use message-setup-hook - instead - (gnus-configure-posting-styles): new posting-style 'body - (gnus-configure-posting-styles): insert headers immediately + * gnus-msg.el (gnus-setup-message): Use message-setup-hook + instead. + (gnus-configure-posting-styles): New posting-style 'body. + (gnus-configure-posting-styles): Insert headers immediately 1998-08-13 Lars Magne Ingebrigtsen <[email protected]> @@ -524,9 +524,9 @@ 1998-08-12 Simon Josefsson <[email protected]> - * gnus-cache.el (gnus-uncacheable-groups): doc change - (gnus-cacheable-groups): new variable - (gnus-cache-possibly-enter-article): use it + * gnus-cache.el (gnus-uncacheable-groups): Doc change. + (gnus-cacheable-groups): New variable. + (gnus-cache-possibly-enter-article): Use it. 1998-08-12 Lars Magne Ingebrigtsen <[email protected]> diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2 index b74c810666..933734f8cc 100644 --- a/lisp/gnus/ChangeLog.2 +++ b/lisp/gnus/ChangeLog.2 @@ -694,11 +694,11 @@ (gnus-agent-regenerate): Uses new gnus-agent-covered-methods function as gnus-agent-covered-methods variable no longer provides methods. - (gnus-agent-covered-methods): New function + (gnus-agent-covered-methods): New function. (gnus-agent-expire-group, gnus-agent-expire): Final message will, if gnus-verbose is greater than 4, report statistics of NOV entries and files deleted as well as total bytes recovered. - (gnus-agent-expire-done-message): New function + (gnus-agent-expire-done-message): New function. (gnus-agent-unread-articles): Bug fix. No longer drops last unread article onto read list. (gnus-agent-regenerate-group): Changed prompt to use typical @@ -900,7 +900,7 @@ * spam.el (spam-log-processing-to-registry): Improved message and comments. - (spam-log-unregistration-needed-p): New function + (spam-log-unregistration-needed-p): New function. (spam-ifile-register-spam-routine) (spam-ifile-register-ham-routine, spam-stat-register-spam-routine) (spam-stat-register-ham-routine) @@ -1120,7 +1120,7 @@ * message.el (message-mode-field-menu): Added message-generate-unsubscribed-mail-followup-to. - (message-forward-subject-fwd): Avoid double "Fwd: " + (message-forward-subject-fwd): Avoid double "Fwd: ". (message-change-subject): Added comment. 2003-10-19 Lars Magne Ingebrigtsen <[email protected]> @@ -2084,7 +2084,7 @@ (spam-spamoracle-learn-ham, spam-spamoracle-learn-spam): New functions. * gnus.el (gnus-group-spam-exit-processor-spamoracle) - (gnus-group-ham-exit-processor-spamoracle): New variables for SpamOracle + (gnus-group-ham-exit-processor-spamoracle): New variables for SpamOracle. (spam-process, ham-process): Added spamoracle spam/ham processors. 2003-06-08 Jesper Harder <[email protected]> @@ -2781,7 +2781,7 @@ * gnus-registry.el (gnus-registry-split-fancy-with-parent): Added diagnostic message. (gnus-registry-grep-in-list): Don't run when word is nil. - (gnus-registry-fetch-message-id-fast): New function + (gnus-registry-fetch-message-id-fast): New function. (gnus-registry-delete-group, gnus-registry-add-group): Make sure the id and group are not nil. (gnus-registry-register-message-ids): New function. @@ -3561,7 +3561,7 @@ `message-valid-fqdn-regexp' for initialization. (gnus-button-handle-info-url): Renamed and extended version of `gnus-button-handle-info'. - (gnus-button-message-level): Renamed from `gnus-button-mail-level' + (gnus-button-message-level): Renamed from `gnus-button-mail-level'. (gnus-button-handle-symbol, gnus-button-handle-library) (gnus-button-handle-info-keystrokes): New functions. (gnus-button-browse-level): New variable. @@ -4904,8 +4904,8 @@ 2003-02-08 Michael Welsh Duggan <[email protected]> * nnmail.el (nnmail-split-it): If a message ends up matching the - same mailbox more than once, it will cause duplicates to appear - in the mailbox. + same mailbox more than once, it will cause duplicates to appear + in the mailbox. 2003-02-08 Simon Josefsson <[email protected]> @@ -5552,8 +5552,8 @@ 2003-01-13 Jhair Tocancipa Triana <[email protected]> * gnus-audio.el (gnus-audio-au-player, gnus-audio-wav-player): Use - /usr/bin/play as default player. - (gnus-audio-play): Added ARG-DESCRIPTOR to prompt for a file to play. + /usr/bin/play as default player. + (gnus-audio-play): Added ARG-DESCRIPTOR to prompt for a file to play. 2003-01-14 Katsumi Yamaoka <[email protected]> @@ -6295,8 +6295,8 @@ 2003-01-02 Reiner Steib <[email protected]> - * gnus-art.el (gnus-button-url-regexp, - (gnus-button-mid-or-mail-regexp, gnus-button-alist, + * gnus-art.el (gnus-button-url-regexp) + (gnus-button-mid-or-mail-regexp, gnus-button-alist) (gnus-header-button-alist): Regexps are case insensitive here. 2003-01-02 Simon Josefsson <[email protected]> @@ -7194,7 +7194,7 @@ 2002-10-31 Alex Schroeder <[email protected]> - * spam-stat.el (spam-stat-process-directory): Add dir to message + * spam-stat.el (spam-stat-process-directory): Add dir to message. (spam-stat-reduce-size): No longer remove words with values close to 0.5, because the default value is 0.2. @@ -9033,7 +9033,7 @@ boolean not a string * gnus-group.el (gnus-group-line-format): Add description of %C * gnus-group.el (gnus-group-line-format-alist): Add gnus-tmp-comment - as %C + as %C * gnus-group.el (gnus-group-insert-group-line): Add gnus-tmp-comment. 2002-04-22 Paul Jarc <[email protected]> @@ -11325,7 +11325,7 @@ 2002-01-02 ShengHuo ZHU <[email protected]> * gnus-picon.el (gnus-picon-transform-newsgroups): Fix for the case - "Newsgroups: rec.music.beatles.moderated, rec.music.beatles". + "Newsgroups: rec.music.beatles.moderated, rec.music.beatles". 2002-01-03 Steve Youngs <[email protected]> @@ -12255,7 +12255,7 @@ (imap-stream-alist): Backslash. * gnus-sum.el (gnus-summary-limit-to-author): Missing arguments. - Thanks to [email protected] (David S. Goldberg). + Thanks to [email protected] (David S. Goldberg). 2001-11-27 14:00:00 ShengHuo ZHU <[email protected]> @@ -12402,7 +12402,7 @@ Support "Importance:" header in Message. * message.el (message-mode-map): Bind C-c C-p to - `message-insert-or-toggle-importance' + `message-insert-or-toggle-importance'. (message-mode-menu): Add message-insert-importance-{high,low}. (message-insert-importance-high, message-insert-importance-low) (message-insert-or-toggle-importance): New functions. @@ -12754,7 +12754,7 @@ 2001-10-30 13:00:00 ShengHuo ZHU <[email protected]> * gnus-spec.el (gnus-parse-simple-format): Use - buffer-substring-no-properties. + buffer-substring-no-properties. 2001-10-30 Katsumi Yamaoka <[email protected]> @@ -12870,7 +12870,7 @@ 2001-10-21 Simon Josefsson <[email protected]> - * nnimap.el (nnimap): Defgroup + * nnimap.el (nnimap): Defgroup. (nnimap-strict-function, nnimap-strict-function-match): New widget, from Per Abrahamsen <[email protected]>. (nnimap-split-crosspost, nnimap-split-inbox) @@ -16433,7 +16433,7 @@ 2001-01-09 Didier Verna <[email protected]> * gnus-agent.el: Moved some XEmacs specific hook add-ons from - `gnus-xmas-[re]define' to avoid loosing user custom settings. + `gnus-xmas-[re]define' to avoid losing user custom settings. * gnus-art.el: Ditto. * gnus-group.el: Ditto. * gnus-salt.el: Ditto. @@ -16688,7 +16688,7 @@ * gnus-cus.el (gnus-group-customize): Use it. * gnus.el (gnus-define-group-parameter): New macro. - (auto-expire): Use it + (auto-expire): Use it. (total-expire): Use it. * gnus-art.el (banner): Use it. diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index 3718f82c79..70d9323cb7 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -29,12 +29,27 @@ ;; See the auth.info Info documentation for details. +;; TODO: + +;; - never decode the backend file unless it's necessary +;; - a more generic way to match backends and search backend contents +;; - absorb netrc.el and simplify it +;; - protect passwords better +;; - allow creating and changing netrc lines (not files) e.g. change a password + ;;; Code: (require 'gnus-util) +(require 'netrc) (eval-when-compile (require 'cl)) -(eval-when-compile (require 'netrc)) +(autoload 'secrets-create-item "secrets") +(autoload 'secrets-delete-item "secrets") +(autoload 'secrets-get-alias "secrets") +(autoload 'secrets-get-attribute "secrets") +(autoload 'secrets-get-secret "secrets") +(autoload 'secrets-list-collections "secrets") +(autoload 'secrets-search-items "secrets") (defgroup auth-source nil "Authentication sources." @@ -42,28 +57,29 @@ :group 'gnus) (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993") - (pop3 "pop3" "pop" "pop3s" "110" "995") - (ssh "ssh" "22") - (sftp "sftp" "115") - (smtp "smtp" "25")) + (pop3 "pop3" "pop" "pop3s" "110" "995") + (ssh "ssh" "22") + (sftp "sftp" "115") + (smtp "smtp" "25")) "List of authentication protocols and their names" :group 'auth-source - :version "23.1" ;; No Gnus + :version "23.2" ;; No Gnus :type '(repeat :tag "Authentication Protocols" - (cons :tag "Protocol Entry" - (symbol :tag "Protocol") - (repeat :tag "Names" - (string :tag "Name"))))) + (cons :tag "Protocol Entry" + (symbol :tag "Protocol") + (repeat :tag "Names" + (string :tag "Name"))))) ;;; generate all the protocols in a format Customize can use +;;; TODO: generate on the fly from auth-source-protocols (defconst auth-source-protocols-customize (mapcar (lambda (a) - (let ((p (car-safe a))) - (list 'const - :tag (upcase (symbol-name p)) - p))) - auth-source-protocols)) + (let ((p (car-safe a))) + (list 'const + :tag (upcase (symbol-name p)) + p))) + auth-source-protocols)) (defvar auth-source-cache (make-hash-table :test 'equal) "Cache for auth-source data") @@ -71,7 +87,7 @@ (defcustom auth-source-do-cache t "Whether auth-source should cache information." :group 'auth-source - :version "23.1" ;; No Gnus + :version "23.2" ;; No Gnus :type `boolean) (defcustom auth-source-debug nil @@ -85,40 +101,72 @@ If the value is t, debug messages are logged with `message'. If the value is a function, debug messages are logged by calling that function using the same arguments as `message'." :group 'auth-source - :version "23.1" ;; No Gnus - :type `(choice - :tag "auth-source debugging mode" - (const :tag "Log using `message' to the *Messages* buffer" t) - (function :tag "Function that takes arguments like `message'") - (const :tag "Don't log anything" nil))) + :version "23.2" ;; No Gnus + :type `(choice + :tag "auth-source debugging mode" + (const :tag "Log using `message' to the *Messages* buffer" t) + (function :tag "Function that takes arguments like `message'") + (const :tag "Don't log anything" nil))) (defcustom auth-source-hide-passwords t "Whether auth-source should hide passwords in log messages. Only relevant if `auth-source-debug' is not nil." :group 'auth-source - :version "23.1" ;; No Gnus + :version "23.2" ;; No Gnus :type `boolean) -(defcustom auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)) +(defcustom auth-sources '((:source "~/.authinfo.gpg") + (:source "~/.authinfo")) "List of authentication sources. -Each entry is the authentication type with optional properties." +The default will get login and password information from a .gpg +file, which you should set up with the EPA/EPG packages to be +encrypted. See the auth.info manual for details. + +Each entry is the authentication type with optional properties. + +It's best to customize this with `M-x customize-variable' because the choices +can get pretty complex." :group 'auth-source - :version "23.1" ;; No Gnus + :version "23.2" ;; No Gnus :type `(repeat :tag "Authentication Sources" - (list :tag "Source definition" - (const :format "" :value :source) - (string :tag "Authentication Source") - (const :format "" :value :host) - (choice :tag "Host (machine) choice" - (const :tag "Any" t) - (regexp :tag "Host (machine) regular expression (TODO)") - (const :tag "Fallback" nil)) - (const :format "" :value :protocol) - (choice :tag "Protocol" - (const :tag "Any" t) - (const :tag "Fallback" nil) - ,@auth-source-protocols-customize)))) + (list :tag "Source definition" + (const :format "" :value :source) + (choice :tag "Authentication backend choice" + (string :tag "Authentication Source (file)") + (list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)" + (const :format "" :value :secrets) + (choice :tag "Collection to use" + (string :tag "Collection name") + (const :tag "Default" 'default) + (const :tag "Login" "login") + (const :tag "Temporary" "session")))) + (repeat :tag "Extra Parameters" :inline t + (choice :tag "Extra parameter" + (list :tag "Host (omit to match as a fallback)" + (const :format "" :value :host) + (choice :tag "Host (machine) choice" + (const :tag "Any" t) + (regexp :tag "Host (machine) regular expression"))) + (list :tag "Protocol (omit to match as a fallback)" + (const :format "" :value :protocol) + (choice :tag "Protocol" + (const :tag "Any" t) + ,@auth-source-protocols-customize)) + (list :tag "User (omit to match as a fallback)" :inline t + (const :format "" :value :user) + (choice :tag "Personality or username" + (const :tag "Any" t) + (string :tag "Specific user name")))))))) + +(defcustom auth-source-gpg-encrypt-to t + "List of recipient keys that `authinfo.gpg' encrypted to. +If the value is not a list, symmetric encryption will be used." + :group 'auth-source + :version "23.2" ;; No Gnus + :type '(choice (const :tag "Symmetric encryption" t) + (repeat :tag "Recipient public keys" + (string :tag "Recipient public key")))) ;; temp for debugging ;; (unintern 'auth-source-protocols) @@ -129,7 +177,7 @@ Each entry is the authentication type with optional properties." ;; (customize-variable 'auth-source-protocols) ;; (setq auth-source-protocols nil) ;; (format "%S" auth-source-protocols) -;; (auth-source-pick "a" 'imap) +;; (auth-source-pick nil :host "a" :port 'imap) ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap) ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap) ;; (auth-source-user-or-password-imap "login" "imap.myhost.com") @@ -145,78 +193,319 @@ Each entry is the authentication type with optional properties." ;; we also check the value (when auth-source-debug (let ((logger (if (functionp auth-source-debug) - auth-source-debug - 'message))) + auth-source-debug + 'message))) (apply logger msg)))) -(defun auth-source-pick (host protocol &optional fallback) - "Parse `auth-sources' for HOST, and PROTOCOL matches. - -Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t." - (interactive "sHost: \nsProtocol: \n") ;for testing - (let (choices) - (dolist (choice auth-sources) - (let ((h (plist-get choice :host)) - (p (plist-get choice :protocol))) - (when (and - (or (equal t h) - (and (stringp h) (string-match h host)) - (and fallback (equal h nil))) - (or (equal t p) - (and (symbolp p) (equal p protocol)) - (and fallback (equal p nil)))) - (push choice choices)))) - (if choices - choices - (unless fallback - (auth-source-pick host protocol t))))) - -(defun auth-source-forget-user-or-password (mode host protocol) +;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe") +;; (auth-source-pick t :host "any" :protocol 'imap :user "joe") +;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe") +;; (:source (:secrets "session") :host t :protocol t :user "joe") +;; (:source (:secrets "login") :host t :protocol t) +;; (:source "~/.authinfo.gpg" :host t :protocol t))) + +;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe") +;; (:source (:secrets "session") :host t :protocol t :user "joe") +;; (:source (:secrets "login") :host t :protocol t) +;; )) + +;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))) + +(defun auth-get-source (entry) + "Return the source string of ENTRY, which is one entry in `auth-sources'. +If it is a Secret Service API, return the collection name, otherwise +the file name." + (let ((source (plist-get entry :source))) + (if (stringp source) + source + ;; Secret Service API. + (setq source (plist-get source :secrets)) + (when (eq source 'default) + (setq source (or (secrets-get-alias "default") "login"))) + (or source "session")))) + +(defun auth-source-pick (&rest spec) + "Parse `auth-sources' for matches of the SPEC plist. + +Common keys are :host, :protocol, and :user. A value of t in +SPEC means to always succeed in the match. A string value is +matched as a regex." + (let ((keys (loop for i below (length spec) by 2 collect (nth i spec))) + choices) + (dolist (choice (copy-tree auth-sources) choices) + (let ((source (plist-get choice :source)) + (match t)) + (when + (and + ;; Check existence of source. + (if (consp source) + ;; Secret Service API. + (member (auth-get-source choice) (secrets-list-collections)) + ;; authinfo file. + (file-exists-p source)) + + ;; Check keywords. + (dolist (k keys match) + (let* ((v (plist-get spec k)) + (choicev (if (plist-member choice k) + (plist-get choice k) t))) + (setq match + (and match + (or + ;; source always matches spec key + (eq t choicev) + ;; source key gives regex to match against spec + (and (stringp choicev) (string-match choicev v)) + ;; source key gives symbol to match against spec + (and (symbolp choicev) (eq choicev v)))))))) + + (add-to-list 'choices choice 'append)))))) + +(defun auth-source-retrieve (mode entry &rest spec) + "Retrieve MODE credentials according to SPEC from ENTRY." + (catch 'no-password + (let ((host (plist-get spec :host)) + (user (plist-get spec :user)) + (prot (plist-get spec :protocol)) + (source (plist-get entry :source)) + result) + (cond + ;; Secret Service API. + ((consp source) + (let ((coll (auth-get-source entry)) + item) + ;; Loop over candidates with a matching host attribute. + (dolist (elt (secrets-search-items coll :host host) item) + (when (and (or (not user) + (string-equal + user (secrets-get-attribute coll elt :user))) + (or (not prot) + (string-equal + prot (secrets-get-attribute coll elt :protocol)))) + (setq item elt) + (return elt))) + ;; Compose result. + (when item + (setq result + (mapcar (lambda (m) + (if (string-equal "password" m) + (or (secrets-get-secret coll item) + ;; When we do not find a password, + ;; we return nil anyway. + (throw 'no-password nil)) + (or (secrets-get-attribute coll item :user) + user))) + (if (consp mode) mode (list mode))))) + (if (consp mode) result (car result)))) + ;; Anything else is netrc. + (t + (let ((search (list source (list host) (list (format "%s" prot)) + (auth-source-protocol-defaults prot)))) + (setq result + (mapcar (lambda (m) + (if (string-equal "password" m) + (or (apply + 'netrc-machine-user-or-password m search) + ;; When we do not find a password, we + ;; return nil anyway. + (throw 'no-password nil)) + (or (apply + 'netrc-machine-user-or-password m search) + user))) + (if (consp mode) mode (list mode))))) + (if (consp mode) result (car result))))))) + +(defun auth-source-create (mode entry &rest spec) + "Create interactively credentials according to SPEC in ENTRY. +Return structure as specified by MODE." + (let* ((host (plist-get spec :host)) + (user (plist-get spec :user)) + (prot (plist-get spec :protocol)) + (source (plist-get entry :source)) + (name (concat (if user (format "%s@" user)) + host + (if prot (format ":%s" prot)))) + result) + (setq result + (mapcar + (lambda (m) + (cons + m + (cond + ((equal "password" m) + (let ((passwd (read-passwd + (format "Password for %s on %s: " prot host)))) + (cond + ;; Secret Service API. + ((consp source) + (apply + 'secrets-create-item + (auth-get-source entry) name passwd spec)) + (t)) ;; netrc not implemented yes. + passwd)) + ((equal "login" m) + (or user + (read-string + (format "User name for %s on %s (default %s): " prot host + (user-login-name)) + nil nil (user-login-name)))) + (t + "unknownuser")))) + (if (consp mode) mode (list mode)))) + ;; Allow the source to save the data. + (cond + ((consp source) + ;; Secret Service API -- not implemented. + ) + (t + ;; netrc interface. + (when (y-or-n-p (format "Do you want to save this password in %s? " + source)) + ;; the code below is almost same as `netrc-store-data' except + ;; the `epa-file-encrypt-to' hack (see bug#7487). + (with-temp-buffer + (when (file-exists-p source) + (insert-file-contents source)) + (when auth-source-gpg-encrypt-to + ;; making `epa-file-encrypt-to' local to this buffer lets + ;; epa-file skip the key selection query (see the + ;; `local-variable-p' check in `epa-file-write-region'). + (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) + (make-local-variable 'epa-file-encrypt-to)) + (if (listp auth-source-gpg-encrypt-to) + (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert (format "machine %s login %s password %s port %s\n" + host + (or user (cdr (assoc "login" result))) + (cdr (assoc "password" result)) + prot)) + (write-region (point-min) (point-max) source nil 'silent))))) + (if (consp mode) + (mapcar #'cdr result) + (cdar result)))) + +(defun auth-source-delete (entry &rest spec) + "Delete credentials according to SPEC in ENTRY." + (let ((host (plist-get spec :host)) + (user (plist-get spec :user)) + (prot (plist-get spec :protocol)) + (source (plist-get entry :source))) + (cond + ;; Secret Service API. + ((consp source) + (let ((coll (auth-get-source entry))) + ;; Loop over candidates with a matching host attribute. + (dolist (elt (secrets-search-items coll :host host)) + (when (and (or (not user) + (string-equal + user (secrets-get-attribute coll elt :user))) + (or (not prot) + (string-equal + prot (secrets-get-attribute coll elt :protocol)))) + (secrets-delete-item coll elt))))) + (t)))) ;; netrc not implemented yes. + +(defun auth-source-forget-user-or-password + (mode host protocol &optional username) + "Remove cached authentication token." (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing - (remhash (format "%s %s:%s" mode host protocol) auth-source-cache)) + (remhash + (if username + (format "%s %s:%s %s" mode host protocol username) + (format "%s %s:%s" mode host protocol)) + auth-source-cache)) (defun auth-source-forget-all-cached () "Forget all cached auth-source authentication tokens." (interactive) (setq auth-source-cache (make-hash-table :test 'equal))) -(defun auth-source-user-or-password (mode host protocol) +;; (progn +;; (auth-source-forget-all-cached) +;; (list +;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other") +;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz") +;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe"))) + +(defun auth-source-user-or-password + (mode host protocol &optional username create-missing delete-existing) "Find MODE (string or list of strings) matching HOST and PROTOCOL. -MODE can be \"login\" or \"password\" for example." + +USERNAME is optional and will be used as \"login\" in a search +across the Secret Service API (see secrets.el) if the resulting +items don't have a username. This means that if you search for +username \"joe\" and it matches an item but the item doesn't have +a :user attribute, the username \"joe\" will be returned. + +A non nil DELETE-EXISTING means deleting any matching password +entry in the respective sources. This is useful only when +CREATE-MISSING is non nil as well; the intended use case is to +remove wrong password entries. + +If no matching entry is found, and CREATE-MISSING is non nil, +the password will be retrieved interactively, and it will be +stored in the password database which matches best (see +`auth-sources'). + +MODE can be \"login\" or \"password\"." (auth-source-do-debug - "auth-source-user-or-password: get %s for %s (%s)" - mode host protocol) + "auth-source-user-or-password: get %s for %s (%s) + user=%s" + mode host protocol username) (let* ((listy (listp mode)) - (mode (if listy mode (list mode))) - (cname (format "%s %s:%s" mode host protocol)) - (found (gethash cname auth-source-cache))) + (mode (if listy mode (list mode))) + (cname (if username + (format "%s %s:%s %s" mode host protocol username) + (format "%s %s:%s" mode host protocol))) + (search (list :host host :protocol protocol)) + (search (if username (append search (list :user username)) search)) + (found (if (not delete-existing) + (gethash cname auth-source-cache) + (remhash cname auth-source-cache) + nil))) (if found - (progn - (auth-source-do-debug - "auth-source-user-or-password: cached %s=%s for %s (%s)" - mode - ;; don't show the password - (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found) - host protocol) - found) - (dolist (choice (auth-source-pick host protocol)) - (setq found (netrc-machine-user-or-password - mode - (plist-get choice :source) - (list host) - (list (format "%s" protocol)) - (auth-source-protocol-defaults protocol))) - (when found - (auth-source-do-debug - "auth-source-user-or-password: found %s=%s for %s (%s)" - mode - ;; don't show the password - (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found) - host protocol) - (setq found (if listy found (car-safe found))) - (when auth-source-do-cache - (puthash cname found auth-source-cache))) - (return found))))) + (progn + (auth-source-do-debug + "auth-source-user-or-password: cached %s=%s for %s (%s) + %s" + mode + ;; don't show the password + (if (and (member "password" mode) auth-source-hide-passwords) + "SECRET" + found) + host protocol username) + found) ; return the found data + ;; else, if not found + (let ((choices (apply 'auth-source-pick search))) + (dolist (choice choices) + (if delete-existing + (apply 'auth-source-delete choice search) + (setq found (apply 'auth-source-retrieve mode choice search))) + (and found (return found))) + + ;; We haven't found something, so we will create it interactively. + (when (and (not found) create-missing) + (setq found (apply 'auth-source-create + mode (if choices + (car choices) + (car auth-sources)) + search))) + + ;; Cache the result. + (when found + (auth-source-do-debug + "auth-source-user-or-password: found %s=%s for %s (%s) + %s" + mode + ;; don't show the password + (if (and (member "password" mode) auth-source-hide-passwords) + "SECRET" found) + host protocol username) + (setq found (if listy found (car-safe found))) + (when auth-source-do-cache + (puthash cname found auth-source-cache))) + + found)))) (defun auth-source-protocol-defaults (protocol) "Return a list of default ports and names for PROTOCOL." @@ -239,5 +528,4 @@ MODE can be \"login\" or \"password\" for example." (provide 'auth-source) -;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab ;;; auth-source.el ends here diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el index 008ef19cfe..126a59573d 100644 --- a/lisp/gnus/canlock.el +++ b/lisp/gnus/canlock.el @@ -247,5 +247,4 @@ it fails." (provide 'canlock) -;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78 ;;; canlock.el ends here diff --git a/lisp/gnus/compface.el b/lisp/gnus/compface.el index 5a74561ae9..ba99657df0 100644 --- a/lisp/gnus/compface.el +++ b/lisp/gnus/compface.el @@ -58,5 +58,4 @@ or `faces-xface' and `netpbm' or `libgr-progs', for instance." (provide 'compface) -;; arch-tag: f9c78e84-98c0-4142-9682-8ba4cf4c3441 ;;; compface.el ends here diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index d6f1624795..d0b83cde82 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -476,5 +476,4 @@ NODISPLAY is non-nil, don't redisplay the article buffer." ;; coding: iso-8859-1 ;; End: -;; arch-tag: 5f895cc9-51a9-487c-b42e-28844d79eb73 ;;; deuglify.el ends here diff --git a/lisp/gnus/earcon.el b/lisp/gnus/earcon.el deleted file mode 100644 index 3299d167d1..0000000000 --- a/lisp/gnus/earcon.el +++ /dev/null @@ -1,233 +0,0 @@ -;;; earcon.el --- Sound effects for messages - -;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Steven L. Baur <[email protected]> - -;; 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 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; This file provides access to sound effects in Gnus. - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'gnus) -(require 'gnus-audio) -(require 'gnus-art) - -(defgroup earcon nil - "Turn ** sounds ** into noise." - :group 'gnus-visual) - -(defcustom earcon-prefix "**" - "*String denoting the start of an earcon." - :type 'string - :group 'earcon) - -(defcustom earcon-suffix "**" - "String denoting the end of an earcon." - :type 'string - :group 'earcon) - -(defcustom earcon-regexp-alist - '(("boring" 1 "Boring.au") - ("evil[ \t]+laugh" 1 "Evil_Laugh.au") - ("gag\\|puke" 1 "Puke.au") - ("snicker" 1 "Snicker.au") - ("meow" 1 "catmeow.wav") - ("sob\\|boohoo" 1 "cry.wav") - ("drum[ \t]*roll" 1 "drumroll.au") - ("blast" 1 "explosion.au") - ("flush\\|plonk!*" 1 "flush.au") - ("kiss" 1 "kiss.wav") - ("tee[ \t]*hee" 1 "laugh.au") - ("shoot" 1 "shotgun.wav") - ("yawn" 1 "snore.wav") - ("cackle" 1 "witch.au") - ("yell\\|roar" 1 "yell2.au") - ("whoop-de-doo" 1 "whistle.au")) - "*A list of regexps to map earcons to real sounds." - :type '(repeat (list regexp - (integer :tag "Match") - (string :tag "Sound"))) - :group 'earcon) -(defvar earcon-button-marker-list nil) -(make-variable-buffer-local 'earcon-button-marker-list) - -;;; FIXME!! clone of code from gnus-vis.el FIXME!! -(defun earcon-article-push-button (event) - "Check text under the mouse pointer for a callback function. -If the text under the mouse pointer has a `earcon-callback' property, -call it with the value of the `earcon-data' text property." - (interactive "e") - (set-buffer (window-buffer (posn-window (event-start event)))) - (let* ((pos (posn-point (event-start event))) - (data (get-text-property pos 'earcon-data)) - (fun (get-text-property pos 'earcon-callback))) - (if fun (funcall fun data)))) - -(defun earcon-article-press-button () - "Check text at point for a callback function. -If the text at point has a `earcon-callback' property, -call it with the value of the `earcon-data' text property." - (interactive) - (let* ((data (get-text-property (point) 'earcon-data)) - (fun (get-text-property (point) 'earcon-callback))) - (if fun (funcall fun data)))) - -(defun earcon-article-prev-button (n) - "Move point to N buttons backward. -If N is negative, move forward instead." - (interactive "p") - (earcon-article-next-button (- n))) - -(defun earcon-article-next-button (n) - "Move point to N buttons forward. -If N is negative, move backward instead." - (interactive "p") - (let ((function (if (< n 0) 'previous-single-property-change - 'next-single-property-change)) - (inhibit-point-motion-hooks t) - (backward (< n 0)) - (limit (if (< n 0) (point-min) (point-max)))) - (setq n (abs n)) - (while (and (not (= limit (point))) - (> n 0)) - ;; Skip past the current button. - (when (get-text-property (point) 'earcon-callback) - (goto-char (funcall function (point) 'earcon-callback nil limit))) - ;; Go to the next (or previous) button. - (gnus-goto-char (funcall function (point) 'earcon-callback nil limit)) - ;; Put point at the start of the button. - (when (and backward (not (get-text-property (point) 'earcon-callback))) - (goto-char (funcall function (point) 'earcon-callback nil limit))) - ;; Skip past intangible buttons. - (when (get-text-property (point) 'intangible) - (incf n)) - (decf n)) - (unless (zerop n) - (gnus-message 5 "No more buttons")) - n)) - -(defun earcon-article-add-button (from to fun &optional data) - "Create a button between FROM and TO with callback FUN and data DATA." - (and (boundp gnus-article-button-face) - gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay from to) - 'face gnus-article-button-face)) - (gnus-add-text-properties - from to - (nconc (and gnus-article-mouse-face - (list gnus-mouse-face-prop gnus-article-mouse-face)) - (list 'gnus-callback fun) - (and data (list 'gnus-data data))))) - -(defun earcon-button-entry () - ;; Return the first entry in `gnus-button-alist' matching this place. - (let ((alist earcon-regexp-alist) - (case-fold-search t) - (entry nil)) - (while alist - (setq entry (pop alist)) - (if (looking-at (car entry)) - (setq alist nil) - (setq entry nil))) - entry)) - -(defun earcon-button-push (marker) - ;; Push button starting at MARKER. - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char marker) - (let* ((entry (earcon-button-entry)) - (inhibit-point-motion-hooks t) - (fun 'gnus-audio-play) - (args (list (nth 2 entry)))) - (cond - ((fboundp fun) - (apply fun args)) - ((and (boundp fun) - (fboundp (symbol-value fun))) - (apply (symbol-value fun) args)) - (t - (gnus-message 1 "You must define `%S' to use this button" - (cons fun args))))))) - -;;; FIXME!! clone of code from gnus-vis.el FIXME!! - -;;;###interactive -(defun earcon-region (beg end) - "Play Sounds in the region between point and mark." - (interactive "r") - (earcon-buffer (current-buffer) beg end)) - -;;;###interactive -(defun earcon-buffer (&optional buffer st nd) - (interactive) - (save-excursion - ;; clear old markers. - (if (boundp 'earcon-button-marker-list) - (while earcon-button-marker-list - (set-marker (pop earcon-button-marker-list) nil)) - (setq earcon-button-marker-list nil)) - (and buffer (set-buffer buffer)) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist earcon-regexp-alist) - beg entry regexp) - (goto-char (point-min)) - (setq beg (point)) - (while (setq entry (pop alist)) - (setq regexp (concat (regexp-quote earcon-prefix) - ".*\\(" - (car entry) - "\\).*" - (regexp-quote earcon-suffix))) - (goto-char beg) - (while (re-search-forward regexp nil t) - (let* ((start (and entry (match-beginning 1))) - (end (and entry (match-end 1))) - (from (match-beginning 1))) - (earcon-article-add-button - start end 'earcon-button-push - (car (push (set-marker (make-marker) from) - earcon-button-marker-list))) - (gnus-audio-play (caddr entry)))))))) - -;;;###autoload -(defun gnus-earcon-display () - "Play sounds in message buffers." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - ;; Skip headers - (unless (search-forward "\n\n" nil t) - (goto-char (point-max))) - (sit-for 0) - (earcon-buffer (current-buffer) (point)))) - -;;;*** - -(provide 'earcon) - -(run-hooks 'earcon-load-hook) - -;; arch-tag: 844dfeea-980c-4ed0-907f-a30bf139691c -;;; earcon.el ends here diff --git a/lisp/gnus/ecomplete.el b/lisp/gnus/ecomplete.el index 993f136739..e749c47bec 100644 --- a/lisp/gnus/ecomplete.el +++ b/lisp/gnus/ecomplete.el @@ -27,11 +27,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (unless (fboundp 'with-no-warnings) - (defmacro with-no-warnings (&rest body) - `(progn ,@body)))) - (defgroup ecomplete nil "Electric completion of email addresses and the like." :group 'mail) @@ -61,11 +56,10 @@ (defun ecomplete-add-item (type key text) (let ((elems (assq type ecomplete-database)) (now (string-to-number - (format "%.0f" (if (and (fboundp 'float-time) - (subrp (symbol-function 'float-time))) + (format "%.0f" (if (featurep 'emacs) (float-time) - (with-no-warnings - (time-to-seconds (current-time))))))) + (require 'gnus-util) + (gnus-float-time))))) entry) (unless elems (push (setq elems (list type)) ecomplete-database)) @@ -95,7 +89,7 @@ (let* ((elems (cdr (assq type ecomplete-database))) (match (regexp-quote match)) (candidates - (sort + (sort (loop for (key count time text) in elems when (string-match match text) collect (list count time text)) @@ -156,5 +150,4 @@ (provide 'ecomplete) -;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72 ;;; ecomplete.el ends here diff --git a/lisp/gnus/flow-fill.el b/lisp/gnus/flow-fill.el index 2171c0b3ae..40639290f1 100644 --- a/lisp/gnus/flow-fill.el +++ b/lisp/gnus/flow-fill.el @@ -82,23 +82,41 @@ RFC 2646 suggests 66 characters for readability." ;; Go through each paragraph, filling it and adding SPC ;; as the last character on each line. (while (setq end (text-property-any start (point-max) 'hard 't)) - (let ((fill-column (eval fill-flowed-encode-column))) - (fill-region start end t 'nosqueeze 'to-eop)) - (goto-char start) - ;; `fill-region' probably distorted end. - (setq end (text-property-any start (point-max) 'hard 't)) - (while (and (< (point) end) - (re-search-forward "$" (1- end) t)) - (insert " ") - (setq end (1+ end)) - (forward-char)) - (goto-char (setq start (1+ end))))) + (save-restriction + (narrow-to-region start end) + (let ((fill-column (eval fill-flowed-encode-column))) + (fill-flowed-fill-buffer)) + (goto-char (point-min)) + (while (re-search-forward "\n" nil t) + (replace-match " \n" t t)) + (goto-char (setq start (1+ (point-max))))))) t))) +(defun fill-flowed-fill-buffer () + (let ((prefix nil) + (prev-prefix nil) + (start (point-min))) + (goto-char (point-min)) + (while (not (eobp)) + (setq prefix (and (looking-at "[> ]+") + (match-string 0))) + (if (equal prefix prev-prefix) + (forward-line 1) + (save-restriction + (narrow-to-region start (point)) + (let ((fill-prefix prev-prefix)) + (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)) + (goto-char (point-max))) + (setq prev-prefix prefix + start (point)))) + (save-restriction + (narrow-to-region start (point)) + (let ((fill-prefix prev-prefix)) + (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))))) + ;;;###autoload (defun fill-flowed (&optional buffer delete-space) - (save-excursion - (set-buffer (or (current-buffer) buffer)) + (with-current-buffer (or (current-buffer) buffer) (goto-char (point-min)) ;; Remove space stuffing. (while (re-search-forward "^\\( \\|>+ $\\)" nil t) @@ -221,5 +239,4 @@ RFC 2646 suggests 66 characters for readability." (provide 'flow-fill) -;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b ;;; flow-fill.el ends here diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index cb0b6c27bd..b073984892 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -28,8 +28,6 @@ ;;; Code: -(require 'wid-edit) - (defgroup gmm nil "Utility functions for Gnus, Message and MML." :prefix "gmm-" @@ -95,6 +93,10 @@ ARGS are passed to `message'." "Non-nil if SYMBOL is a widget." (get symbol 'widget-type)) +(autoload 'widget-create-child-value "wid-edit") +(autoload 'widget-convert "wid-edit") +(autoload 'widget-default-get "wid-edit") + ;; Copy of the `nnmail-lazy' code from `nnmail.el': (define-widget 'gmm-lazy 'default "Base widget for recursive datastructures. @@ -265,27 +267,16 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." ;; (tool-bar-add-item ICON DEF KEY &rest PROPS) (apply 'tool-bar-add-item icon nil nil :enable nil props))) ((equal fmap t) ;; Not a menu command - (if (fboundp 'tool-bar-local-item) - (apply 'tool-bar-local-item - icon command - (intern icon) ;; reuse icon or fmap here? - tool-bar-map props) - ;; Emacs 21 compatibility: - (apply 'tool-bar-add-item - icon command - (intern icon) - props))) + (apply 'tool-bar-local-item + icon command + (intern icon) ;; reuse icon or fmap here? + tool-bar-map props)) (t ;; A menu command - (if (fboundp 'tool-bar-local-item-from-menu) - (apply 'tool-bar-local-item-from-menu - ;; (apply 'tool-bar-local-item icon def key - ;; tool-bar-map props) - command icon tool-bar-map (symbol-value fmap) - props) - ;; Emacs 21 compatibility: - (apply 'tool-bar-add-item-from-menu - command icon (symbol-value fmap) - props)))) + (apply 'tool-bar-local-item-from-menu + ;; (apply 'tool-bar-local-item icon def key + ;; tool-bar-map props) + command icon tool-bar-map (symbol-value fmap) + props))) t)) (if (symbolp icon-list) (eval icon-list) @@ -420,16 +411,12 @@ If mode is nil, use `major-mode' of the current buffer." In XEmacs, the seventh argument of `write-region' specifies the coding-system." - (if (and mustbenew - (or (featurep 'xemacs) - (= emacs-major-version 20))) + (if (and mustbenew (featurep 'xemacs)) (if (file-exists-p filename) - (signal 'file-already-exists - (list "File exists" filename)) + (signal 'file-already-exists (list "File exists" filename)) (write-region start end filename append visit lockname)) (write-region start end filename append visit lockname mustbenew))) (provide 'gmm-utils) -;; arch-tag: e0b60920-2ce6-40c1-bfc0-cadbbe26b602 ;;; gmm-utils.el ends here diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 9291d8d30c..2c215e8586 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -184,7 +184,7 @@ When found, offer to remove them." :type 'boolean :group 'gnus-agent) -(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) +(defcustom gnus-agent-auto-agentize-methods nil "Initially, all servers from these methods are agentized. The user may remove or add servers using the Server buffer. See Info node `(gnus)Server Buffer'." @@ -305,8 +305,7 @@ buffer. Automatically blocks multiple updates due to recursion." `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) (when (and gnus-agent-need-update-total-fetched-for (not gnus-agent-inhibit-update-total-fetched-for)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq gnus-agent-need-update-total-fetched-for nil) (gnus-group-update-group ,group t))))) @@ -460,10 +459,7 @@ manipulated as follows: (let ((def (or (gnus-group-group-name) gnus-newsgroup-name))) (when def (setq def (gnus-group-decoded-name def))) - (gnus-group-completing-read (if def - (concat "Group Name (" def "): ") - "Group Name: ") - nil nil t nil nil def))) + (gnus-group-completing-read nil nil t nil nil def))) ;;; Fetching setup functions. @@ -474,8 +470,7 @@ manipulated as follows: (defun gnus-agent-stop-fetch () "Save all data structures and clean up." (setq gnus-agent-spam-hashtb nil) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (widen))) (defmacro gnus-agent-with-fetch (&rest forms) @@ -518,8 +513,8 @@ manipulated as follows: ;; Set up the menu. (when (gnus-visual-p 'agent-menu 'menu) (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer)))) - (unless (assq 'gnus-agent-mode minor-mode-alist) - (push gnus-agent-mode-status minor-mode-alist)) + (unless (assq mode minor-mode-alist) + (push (cons mode (cdr gnus-agent-mode-status)) minor-mode-alist)) (unless (assq mode minor-mode-map-alist) (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" buffer)))) @@ -608,16 +603,13 @@ manipulated as follows: (propertize string 'local-map (make-mode-line-mouse-map mouse-button mouse-func) 'mouse-face - (cond ((and (featurep 'xemacs) - ;; XEmacs' `facep' only checks for a face - ;; object, not for a face name, so it's useless - ;; to check with `facep'. - (find-face 'modeline)) - 'modeline) - ((facep 'mode-line-highlight) ;; Emacs 22 - 'mode-line-highlight) - ((facep 'mode-line) ;; Emacs 21 - 'mode-line)) ) + (if (and (featurep 'xemacs) + ;; XEmacs' `facep' only checks for a face + ;; object, not for a face name, so it's useless + ;; to check with `facep'. + (find-face 'modeline)) + 'modeline + 'mode-line-highlight)) string)) (defun gnus-agent-toggle-plugged (set-to) @@ -693,7 +685,6 @@ This will modify the `gnus-setup-news-hook', and minor mode in all Gnus buffers." (interactive) (gnus-open-agent) - (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) (unless gnus-agent-send-mail-function (setq gnus-agent-send-mail-function (or message-send-mail-real-function @@ -703,7 +694,9 @@ minor mode in all Gnus buffers." ;; If the servers file doesn't exist, auto-agentize some servers and ;; save the servers file so this auto-agentizing isn't invoked ;; again. - (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers")) + (when (and (not (file-exists-p (nnheader-concat + gnus-agent-directory "lib/servers"))) + gnus-agent-auto-agentize-methods) (gnus-message 3 "First time agent user, agentizing remote groups...") (mapc (lambda (server-or-method) @@ -809,23 +802,24 @@ be a select method." (setq group (or group gnus-newsgroup-name)) (unless group (error "No group on the current line")) - - (gnus-agent-while-plugged - (let ((gnus-command-method (gnus-find-method-for-group group))) - (gnus-agent-with-fetch - (gnus-agent-fetch-group-1 group gnus-command-method) - (gnus-message 5 "Fetching %s...done" group))))) + (if (not (gnus-agent-group-covered-p group)) + (message "%s isn't covered by the agent" group) + (gnus-agent-while-plugged + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-with-fetch + (gnus-agent-fetch-group-1 group gnus-command-method) + (gnus-message 5 "Fetching %s...done" group)))))) (defun gnus-agent-add-group (category arg) "Add the current group to an agent category." (interactive (list (intern - (completing-read - "Add to category: " - (mapcar (lambda (cat) (list (symbol-name (car cat)))) + (gnus-completing-read + "Add to category" + (mapcar (lambda (cat) (symbol-name (car cat))) gnus-category-alist) - nil t)) + t)) current-prefix-arg)) (let ((cat (assq category gnus-category-alist)) c groups) @@ -1031,7 +1025,7 @@ supported." (unless (member server gnus-agent-covered-methods) (push server gnus-agent-covered-methods) (setq gnus-agent-method-p-cache nil)) - (gnus-message 1 "Ignoring disappeared server `%s'" server)))) + (gnus-message 8 "Ignoring disappeared server `%s'" server)))) (prog1 gnus-agent-covered-methods (setq gnus-agent-covered-methods nil)))) @@ -1519,7 +1513,7 @@ downloaded into the agent." "Fetch ARTICLES from GROUP and put them into the Agent." (when articles (gnus-agent-load-alist group) - (let* ((alist gnus-agent-article-alist) + (let* ((alist gnus-agent-article-alist) (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) (selected-sets (list nil)) (current-set-size 0) @@ -1561,9 +1555,9 @@ downloaded into the agent." ;; 65 char/line. If the line count ;; is missing, arbitrarily assume a ;; size of 1000 characters. - (max (* 65 (mail-header-lines - (car headers))) - 1000) + (max (* 65 (mail-header-lines + (car headers))) + 1000) char-size)) 0)))) (setcar selected-sets (nreverse (car selected-sets))) @@ -1583,7 +1577,8 @@ downloaded into the agent." (setq selected-sets (nreverse selected-sets)) (gnus-make-directory dir) - (gnus-message 7 "Fetching articles for %s..." group) + (gnus-message 7 "Fetching articles for %s..." + (gnus-agent-decoded-group-name group)) (unwind-protect (while (setq articles (pop selected-sets)) @@ -1594,7 +1589,8 @@ downloaded into the agent." (let (article) (while (setq article (pop articles)) (gnus-message 10 "Fetching article %s for %s..." - article group) + article + (gnus-agent-decoded-group-name group)) (when (or (gnus-backlog-request-article group article nntp-server-buffer) @@ -1606,8 +1602,7 @@ downloaded into the agent." nntp-server-buffer (point-min) (point-max)) (setq pos (nreverse pos))))) ;; Then save these articles into the Agent. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (while pos (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) (goto-char (point-min)) @@ -1691,8 +1686,7 @@ downloaded into the agent." (setq date (or date t)) (let (gnus-agent-article-alist group alist beg end) - (save-excursion - (set-buffer gnus-agent-overview-buffer) + (with-current-buffer gnus-agent-overview-buffer (when (nnheader-find-nov-line article) (forward-word 1) (setq beg (point)) @@ -1703,9 +1697,8 @@ downloaded into the agent." (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) - (save-excursion - (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" - group))) + (with-current-buffer (gnus-get-buffer-create + (format " *Gnus agent overview %s*"group)) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors @@ -1786,7 +1779,7 @@ and that there are no duplicates." (while alist (let ((entry (pop alist))) (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry)) - (gnus-agent-flush-group (gnus-info-group entry))))))) + (gnus-agent-flush-group (gnus-info-group entry))))))) (defun gnus-agent-flush-group (group) "Flush the agent's index files such that the GROUP no longer @@ -1937,12 +1930,11 @@ article numbers will be returned." 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" (gnus-compress-sequence articles t)) - (save-excursion - (set-buffer nntp-server-buffer) - + (with-current-buffer nntp-server-buffer (if articles (progn - (gnus-message 7 "Fetching headers for %s..." group) + (gnus-message 7 "Fetching headers for %s..." + (gnus-agent-decoded-group-name group)) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars @@ -2105,13 +2097,15 @@ doesn't exist, to valid the overview buffer." (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." ;; Bind free variable that's used in `gnus-agent-read-agentview'. - (let ((gnus-agent-read-agentview group) - (file-name-coding-system nnmail-pathname-coding-system)) + (let* ((gnus-agent-read-agentview group) + (file-name-coding-system nnmail-pathname-coding-system) + (agentview (gnus-agent-article-name ".agentview" group))) (setq gnus-agent-article-alist - (gnus-cache-file-contents - (gnus-agent-article-name ".agentview" group) - 'gnus-agent-file-loading-cache - 'gnus-agent-read-agentview)))) + (and (file-exists-p agentview) + (gnus-cache-file-contents + agentview + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview))))) (defun gnus-agent-read-agentview (file) "Load FILE and do a `read' there." @@ -2159,13 +2153,13 @@ doesn't exist, to valid the overview buffer." (gnus-agent-save-alist gnus-agent-read-agentview))) alist)) ((end-of-file file-error) - ;; The agentview file is missing. + ;; The agentview file is missing. (condition-case nil ;; If the agent directory exists, attempt to perform a brute-force ;; reconstruction of its contents. (let* (alist (file-name-coding-system nnmail-pathname-coding-system) - (file-attributes (directory-files-and-attributes + (file-attributes (directory-files-and-attributes (gnus-agent-article-name "" gnus-agent-read-agentview) nil "^[0-9]+$" t))) (while file-attributes @@ -2227,23 +2221,28 @@ doesn't exist, to valid the overview buffer." (gnus-agent-update-view-total-fetched-for group nil))) (defvar gnus-agent-article-local nil) +(defvar gnus-agent-article-local-times nil) (defvar gnus-agent-file-loading-local nil) (defun gnus-agent-load-local (&optional method) "Load the METHOD'S local file. The local file contains min/max article counts for each of the method's subscribed groups." (let ((gnus-command-method (or method gnus-command-method))) - (setq gnus-agent-article-local - (gnus-cache-file-contents - (gnus-agent-lib-file "local") - 'gnus-agent-file-loading-local - 'gnus-agent-read-and-cache-local)))) + (when (or (null gnus-agent-article-local-times) + (zerop gnus-agent-article-local-times)) + (setq gnus-agent-article-local + (gnus-cache-file-contents + (gnus-agent-lib-file "local") + 'gnus-agent-file-loading-local + 'gnus-agent-read-and-cache-local)) + (when gnus-agent-article-local-times + (incf gnus-agent-article-local-times))) + gnus-agent-article-local)) (defun gnus-agent-read-and-cache-local (file) "Load and read FILE then bind its contents to gnus-agent-article-local. If that variable had `dirty' (also known as modified) original contents, they are first saved to their own file." - (if (and gnus-agent-article-local (symbol-value (intern "+dirty" gnus-agent-article-local))) (gnus-agent-save-local)) @@ -2350,7 +2349,6 @@ modified) original contents, they are first saved to their own file." (local (or local (gnus-agent-load-local))) (symb (intern gmane local)) (minmax (and (boundp symb) (symbol-value symb)))) - (if (cond ((and minmax (or (not (eq min (car minmax))) (not (eq max (cdr minmax)))) @@ -2375,7 +2373,7 @@ modified) original contents, they are first saved to their own file." (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." - (gnus-message 1 msg) + (gnus-message 1 "%s" msg) t) ;;;###autoload @@ -2641,10 +2639,10 @@ General format specifiers can also be used. See Info node (defvar gnus-agent-predicate 'false "The selection predicate used when no other source is available.") -(defvar gnus-agent-short-article 100 +(defvar gnus-agent-short-article 500 "Articles that have fewer lines than this are short.") -(defvar gnus-agent-long-article 200 +(defvar gnus-agent-long-article 1000 "Articles that have more lines than this are long.") (defvar gnus-agent-low-score 0 @@ -2757,8 +2755,7 @@ The following commands are available: (defun gnus-category-setup-buffer () (unless (get-buffer gnus-category-buffer) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-category-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-category-buffer) (gnus-category-mode)))) (defun gnus-category-prepare () @@ -3122,7 +3119,7 @@ FORCE is equivalent to setting the expiration predicates to true." group overview (gnus-gethash-safe group orig) articles force)))) (kill-buffer overview)))) - (gnus-message 4 (gnus-agent-expire-done-message))))) + (gnus-message 4 "%s" (gnus-agent-expire-done-message))))) (defun gnus-agent-expire-group-1 (group overview active articles force) ;; Internal function - requires caller to have set @@ -3255,7 +3252,7 @@ FORCE is equivalent to setting the expiration predicates to true." (gnus-message 7 "gnus-agent-expire: Loading overview...") (nnheader-insert-file-contents nov-file) (goto-char (point-min)) - + (let (p) (while (< (setq p (point)) (point-max)) (condition-case nil @@ -3547,7 +3544,7 @@ articles in every agentized group? ")) expiring-group overview active articles force)))))))) (kill-buffer overview)) (gnus-agent-expire-unagentized-dirs) - (gnus-message 4 (gnus-agent-expire-done-message)))))) + (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))) (defun gnus-agent-expire-done-message () (if (and (> gnus-verbose 4) @@ -3631,7 +3628,8 @@ articles in every agentized group? ")) deleting them?"))) (while to-remove (let ((dir (pop to-remove))) - (if (gnus-y-or-n-p (format "Delete %s? " dir)) + (if (or gnus-expert-user + (gnus-y-or-n-p (format "Delete %s? " dir))) (let* (delete-recursive files f (delete-recursive @@ -3753,7 +3751,7 @@ has been fetched." (erase-buffer) (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent (gnus-retrieve-headers - uncached-articles group fetch-old)))) + uncached-articles group)))) (nnvirtual-convert-headers)) ((eq 'nntp (car gnus-current-select-method)) ;; The author of gnus-get-newsgroup-headers-xover @@ -3904,7 +3902,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (sit-for 1) t))))) (when group - (gnus-message 5 "Regenerating in %s" group) + (gnus-message 5 "Regenerating in %s" (gnus-agent-decoded-group-name group)) (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) (file (gnus-agent-article-name ".overview" group)) @@ -3981,7 +3979,8 @@ If REREAD is not nil, downloaded articles are marked as unread." (or (not nov-arts) (> (car downloaded) (car nov-arts)))) ;; This entry is missing from the overview file - (gnus-message 3 "Regenerating NOV %s %d..." group + (gnus-message 3 "Regenerating NOV %s %d..." + (gnus-agent-decoded-group-name group) (car downloaded)) (let ((file (concat dir (number-to-string (car downloaded))))) (mm-with-unibyte-buffer @@ -4222,5 +4221,4 @@ modified." (provide 'gnus-agent) -;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e ;;; gnus-agent.el ends here diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index dcf7ab16e6..36944267ad 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile @@ -34,10 +34,7 @@ (defvar w3m-minor-mode-map) (require 'gnus) -;; Avoid the "Recursive load suspected" error in Emacs 21.1. -(eval-and-compile - (let ((recursive-load-depth-limit 100)) - (require 'gnus-sum))) +(require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) (require 'gnus-win) @@ -728,7 +725,7 @@ Each element is a regular expression." :group 'gnus-article-various) (make-obsolete-variable 'gnus-article-hide-pgp-hook nil - "Gnus 5.10 (Emacs-22.1)") + "Gnus 5.10 (Emacs 22.1)") (defface gnus-button '((t (:weight bold))) @@ -919,25 +916,25 @@ image type in XEmacs if it is built with the libcompface library." "Function used to decode addresses.") (defvar gnus-article-dumbquotes-map - '(("\200" "EUR") - ("\202" ",") - ("\203" "f") - ("\204" ",,") - ("\205" "...") - ("\213" "<") - ("\214" "OE") - ("\221" "`") - ("\222" "'") - ("\223" "``") - ("\224" "\"") - ("\225" "*") - ("\226" "-") - ("\227" "--") - ("\230" "~") - ("\231" "(TM)") - ("\233" ">") - ("\234" "oe") - ("\264" "'")) + '((?\200 "EUR") + (?\202 ",") + (?\203 "f") + (?\204 ",,") + (?\205 "...") + (?\213 "<") + (?\214 "OE") + (?\221 "`") + (?\222 "'") + (?\223 "``") + (?\224 "\"") + (?\225 "*") + (?\226 "-") + (?\227 "--") + (?\230 "~") + (?\231 "(TM)") + (?\233 ">") + (?\234 "oe") + (?\264 "'")) "Table for MS-to-Latin1 translation.") (defcustom gnus-ignored-mime-types nil @@ -1415,7 +1412,7 @@ predicate. See Info node `(gnus)Customizing Articles'." :type gnus-article-treat-custom) (make-obsolete-variable 'gnus-treat-display-xface - 'gnus-treat-display-x-face "22.1") + 'gnus-treat-display-x-face "Emacs 22.1") (defcustom gnus-treat-display-x-face (and (not noninteractive) @@ -1532,10 +1529,38 @@ node `(gnus)Picons' for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-newsgroups-picon 'highlight t) +(defcustom gnus-treat-from-gravatar nil + "Display gravatars in the From header. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Gravatars' for details." + :version "24.1" + :group 'gnus-article-treat + :group 'gnus-gravatar + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Gravatars") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-from-gravatar 'highlight t) + +(defcustom gnus-treat-mail-gravatar nil + "Display gravatars in To and Cc headers. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Gravatars' for details." + :version "24.1" + :group 'gnus-article-treat + :group 'gnus-gravatar + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Gravatars") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-mail-gravatar 'highlight t) + (defcustom gnus-treat-body-boundary (if (or gnus-treat-newsgroups-picon gnus-treat-mail-picon - gnus-treat-from-picon) + gnus-treat-from-picon + gnus-treat-from-gravatar + gnus-treat-mail-gravatar) ;; If there's much decoration, the user might prefer a boundery. 'head nil) @@ -1565,28 +1590,11 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) -(defcustom gnus-treat-fill-long-lines nil +(defcustom gnus-treat-fill-long-lines '(typep "text/plain") "Fill long lines. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) - -(defcustom gnus-treat-play-sounds nil - "Play sounds. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :version "21.1" - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) - -(defcustom gnus-treat-translate nil - "Translate articles from one language to another. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :version "21.1" + :version "24.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1614,9 +1622,6 @@ It is a string, such as \"PGP\". If nil, ask user." :type 'string :group 'mime-security) -(defvar gnus-article-wash-function nil - "Function used for converting HTML into text.") - (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) (mm-coding-system-p 'utf-8) (executable-find idna-program)) @@ -1632,6 +1637,21 @@ This requires GNU Libidn, and by default only enabled if it is found." :group 'gnus-article :type 'boolean) +(defcustom gnus-inhibit-images nil + "Non-nil means inhibit displaying of images inline in the article body." + :version "24.1" + :group 'gnus-article + :type 'boolean) + +(defcustom gnus-blocked-images 'gnus-block-private-groups + "Images that have URLs matching this regexp will be blocked. +This can also be a function to be evaluated. If so, it will be +called with the group name as the parameter, and should return a +regexp." + :version "24.1" + :group 'gnus-art + :type 'regexp) + ;;; Internal variables (defvar gnus-english-month-names @@ -1651,7 +1671,7 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-buttonize gnus-article-add-buttons) (gnus-treat-fill-article gnus-article-fill-cited-article) - (gnus-treat-fill-long-lines gnus-article-fill-long-lines) + (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines) (gnus-treat-strip-cr gnus-article-remove-cr) (gnus-treat-unsplit-urls gnus-article-unsplit-urls) (gnus-treat-date-ut gnus-article-date-ut) @@ -1668,10 +1688,12 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-hide-signature gnus-article-hide-signature) (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) - (gnus-treat-strip-pem gnus-article-hide-pem) (gnus-treat-from-picon gnus-treat-from-picon) (gnus-treat-mail-picon gnus-treat-mail-picon) (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) + (gnus-treat-strip-pem gnus-article-hide-pem) + (gnus-treat-from-gravatar gnus-treat-from-gravatar) + (gnus-treat-mail-gravatar gnus-treat-mail-gravatar) (gnus-treat-highlight-headers gnus-article-highlight-headers) (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-strip-trailing-blank-lines @@ -1693,8 +1715,7 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-hide-citation gnus-article-hide-citation) (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) (gnus-treat-highlight-citation gnus-article-highlight-citation) - (gnus-treat-body-boundary gnus-article-treat-body-boundary) - (gnus-treat-play-sounds gnus-earcon-display))) + (gnus-treat-body-boundary gnus-article-treat-body-boundary))) (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) @@ -2100,6 +2121,35 @@ try this wash." (interactive) (article-translate-strings gnus-article-dumbquotes-map)) +(defvar org-entities) + +(defun article-treat-non-ascii () + "Translate many Unicode characters into their ASCII equivalents." + (interactive) + (require 'org-entities) + (let ((table (make-char-table (if (featurep 'xemacs) 'generic)))) + (dolist (elem org-entities) + (when (and (listp elem) + (= (length (nth 6 elem)) 1)) + (if (featurep 'xemacs) + (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table) + (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem))))) + (save-excursion + (when (article-goto-body) + (let ((inhibit-read-only t) + replace props) + (while (not (eobp)) + (if (not (setq replace (if (featurep 'xemacs) + (get-char-table (following-char) table) + (aref table (following-char))))) + (forward-char 1) + (if (prog1 + (setq props (text-properties-at (point))) + (delete-char 1)) + (add-text-properties (point) (progn (insert replace) (point)) + props) + (insert replace))))))))) + (defun article-translate-characters (from to) "Translate all characters in the body of the article according to FROM and TO. FROM is a string of characters to translate from; to is a string of @@ -2124,9 +2174,18 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (when (article-goto-body) (let ((inhibit-read-only t)) (dolist (elem map) - (save-excursion - (while (search-forward (car elem) nil t) - (replace-match (cadr elem))))))))) + (let ((from (car elem)) + (to (cadr elem))) + (save-excursion + (if (stringp from) + (while (search-forward from nil t) + (replace-match to)) + (while (not (eobp)) + (if (eq (following-char) from) + (progn + (delete-char 1) + (insert to)) + (forward-char 1))))))))))) (defun article-treat-overstrike () "Translate overstrikes into bold text." @@ -2219,6 +2278,17 @@ unfolded." (dolist (elem gnus-article-image-alist) (gnus-delete-images (car elem))))) +(defun gnus-article-show-images () + "Show any images that are in the HTML-rendered article buffer. +This only works if the article in question is HTML." + (interactive) + (gnus-with-article-buffer + (dolist (region (gnus-find-text-property-region (point-min) (point-max) + 'image-displayer)) + (destructuring-bind (start end function) region + (funcall function (get-text-property start 'image-url) + start end))))) + (defun gnus-article-treat-fold-newsgroups () "Unfold folded message headers. Only the headers that fit into the current window width will be @@ -2277,9 +2347,9 @@ long lines if and only if arg is positive." (insert "X-Boundary: ") (gnus-add-text-properties start (point) '(invisible t intangible t)) (insert (let (str) - (while (>= (1- (window-width)) (length str)) + (while (>= (window-width) (length str)) (setq str (concat str gnus-body-boundary-delimiter))) - (substring str 0 (1- (window-width)))) + (substring str 0 (window-width))) "\n") (gnus-put-text-property start (point) 'gnus-decoration 'header))))) @@ -2671,118 +2741,16 @@ If READ-CHARSET, ask for a coding system." (when (interactive-p) (gnus-treat-article nil)))) - -(defun article-wash-html (&optional read-charset) - "Format an HTML article. -If READ-CHARSET, ask for a coding system. If it is a number, the -charset defined in `gnus-summary-show-article-charset-alist' is used." - (interactive "P") - (save-excursion - (let ((inhibit-read-only t) - charset) - (if read-charset - (if (or (and (numberp read-charset) - (setq charset - (cdr - (assq read-charset - gnus-summary-show-article-charset-alist)))) - (setq charset (mm-read-coding-system "Charset: "))) - (let ((gnus-summary-show-article-charset-alist - (list (cons 1 charset)))) - (with-current-buffer gnus-summary-buffer - (gnus-summary-show-article 1))) - (error "No charset is given")) - (when (gnus-buffer-live-p gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct (mail-header-parse-content-type ct)))) - (setq charset (and ctl - (mail-content-type-get ctl 'charset))) - (when (stringp charset) - (setq charset (intern (downcase charset))))))) - (unless charset - (setq charset gnus-newsgroup-charset))) - (article-goto-body) - (save-window-excursion - (save-restriction - (narrow-to-region (point) (point-max)) - (let* ((func (or gnus-article-wash-function mm-text-html-renderer)) - (entry (assq func mm-text-html-washer-alist))) - (when entry - (setq func (cdr entry))) - (cond - ((functionp func) - (funcall func)) - (t - (apply (car func) (cdr func)))))))))) - -;; External. -(declare-function w3-region "ext:w3-display" (st nd)) - -(defun gnus-article-wash-html-with-w3 () - "Wash the current buffer with w3." - (mm-setup-w3) - (let ((w3-strict-width (window-width)) - (url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil)) - (condition-case () - (w3-region (point-min) (point-max)) - (error)))) - -;; External. -(declare-function w3m-region "ext:w3m" (start end &optional url charset)) - -(defun gnus-article-wash-html-with-w3m () - "Wash the current buffer with emacs-w3m." - (mm-setup-w3m) - (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) - w3m-force-redisplay) - (w3m-region (point-min) (point-max))) - ;; Put the mark meaning this part was rendered by emacs-w3m. - (put-text-property (point-min) (point-max) 'mm-inline-text-html-with-w3m t) - (when (and mm-inline-text-html-with-w3m-keymap - (boundp 'w3m-minor-mode-map) - w3m-minor-mode-map) - (if (and (boundp 'w3m-link-map) - w3m-link-map) - (let* ((start (point-min)) - (end (point-max)) - (on (get-text-property start 'w3m-href-anchor)) - (map (copy-keymap w3m-link-map)) - next) - (set-keymap-parent map w3m-minor-mode-map) - (while (< start end) - (if on - (progn - (setq next (or (text-property-any start end - 'w3m-href-anchor nil) - end)) - (put-text-property start next 'keymap map)) - (setq next (or (text-property-not-all start end - 'w3m-href-anchor nil) - end)) - (put-text-property start next 'keymap w3m-minor-mode-map)) - (setq start next - on (not on)))) - (put-text-property (point-min) (point-max) 'keymap w3m-minor-mode-map)))) - -(defvar charset) ;; Bound by `article-wash-html'. - -(defun gnus-article-wash-html-with-w3m-standalone () - "Wash the current buffer with w3m." - (if (mm-w3m-standalone-supports-m17n-p) - (progn - (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'. - ;; The default. - (setq charset 'iso-8859-1)) - (let ((coding-system-for-write charset) - (coding-system-for-read charset)) - (call-process-region - (point-min) (point-max) - "w3m" t t nil "-dump" "-T" "text/html" - "-I" (symbol-name charset) "-O" (symbol-name charset)))) - (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html"))) +(defun article-wash-html () + "Format an HTML article." + (interactive) + (let ((handles nil) + (buffer-read-only nil)) + (when (gnus-buffer-live-p gnus-original-article-buffer) + (setq handles (mm-dissect-buffer t t))) + (article-goto-body) + (delete-region (point) (point-max)) + (mm-inline-text-html handles))) (defvar gnus-article-browse-html-temp-list nil "List of temporary files created by `gnus-article-browse-html-parts'. @@ -2806,31 +2774,66 @@ summary buffer." (defun gnus-article-browse-delete-temp-files (&optional how) "Delete temp-files created by `gnus-article-browse-html-parts'." (when (and gnus-article-browse-html-temp-list - (or how - (setq how gnus-article-browse-delete-temp))) - (when (and (eq how 'ask) - (gnus-y-or-n-p (format - "Delete all %s temporary HTML file(s)? " - (length gnus-article-browse-html-temp-list))) - (setq how t))) + (progn + (or how (setq how gnus-article-browse-delete-temp)) + (if (eq how 'ask) + (let ((files (length gnus-article-browse-html-temp-list))) + (gnus-y-or-n-p (format + "Delete all %s temporary HTML file%s? " + files + (if (> files 1) "s" "")))) + how))) (dolist (file gnus-article-browse-html-temp-list) - (when (and (file-exists-p file) - (or (eq how t) - ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'): - (gnus-y-or-n-p - (format "Delete temporary HTML file `%s'? " file)))) - (delete-file file))) + (cond ((file-directory-p file) + (when (or (not (eq how 'file)) + (gnus-y-or-n-p + (format + "Delete temporary HTML file(s) in directory `%s'? " + (file-name-as-directory file)))) + (gnus-delete-directory file))) + ((file-exists-p file) + (when (or (not (eq how 'file)) + (gnus-y-or-n-p + (format "Delete temporary HTML file `%s'? " file))) + (delete-file file))))) ;; Also remove file from the list when not deleted or if file doesn't ;; exist anymore. (setq gnus-article-browse-html-temp-list nil)) gnus-article-browse-html-temp-list) +(defun gnus-article-browse-html-save-cid-content (cid handles directory) + "Find CID content in HANDLES and save it in a file in DIRECTORY. +Return file name." + (save-match-data + (let (file type) + (catch 'found + (dolist (handle handles) + (cond + ((not (listp handle))) + ((equal (mm-handle-media-supertype handle) "multipart") + (when (setq file (gnus-article-browse-html-save-cid-content + cid handle directory)) + (throw 'found file))) + ((equal (concat "<" cid ">") (mm-handle-id handle)) + (setq file + (expand-file-name + (or (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (setq type (mm-handle-type handle)) 'name) + (concat + (make-temp-name "cid") + (car (rassoc (car type) mailcap-mime-extensions)))) + directory)) + (mm-save-part-to-file handle file) + (throw 'found file)))))))) + (defun gnus-article-browse-html-parts (list &optional header) "View all \"text/html\" parts from LIST. Recurse into multiparts. The optional HEADER that should be a decoded message header will be added to the bodies of the \"text/html\" parts." ;; Internal function used by `gnus-article-browse-html-article'. - (let (type file charset tmp-file showed) + (let (type file charset content cid-dir tmp-file showed) ;; Find and show the html-parts. (dolist (handle list) ;; If HTML, show it: @@ -2853,16 +2856,42 @@ message header will be added to the bodies of the \"text/html\" parts." (setq handle (mm-handle-cache handle) type (mm-handle-type handle)) (equal (car type) "text/html")))) - (when (or (setq charset (mail-content-type-get type 'charset)) - header - (not file)) + (setq charset (mail-content-type-get type 'charset) + content (mm-get-part handle)) + (with-temp-buffer + (if (eq charset 'gnus-decoded) + (mm-enable-multibyte) + (mm-disable-multibyte)) + (insert content) + ;; resolve cid contents + (let ((case-fold-search t) + cid-file) + (goto-char (point-min)) + (while (re-search-forward "\ +<img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\"" + nil t) + (unless cid-dir + (setq cid-dir (mm-make-temp-file "cid" t)) + (add-to-list 'gnus-article-browse-html-temp-list cid-dir)) + (setq file nil + content nil) + (when (setq cid-file + (gnus-article-browse-html-save-cid-content + (match-string 2) + (with-current-buffer gnus-article-buffer + gnus-article-mime-handles) + cid-dir)) + (replace-match (concat "file://" cid-file) + nil nil nil 1)))) + (unless content (setq content (buffer-string)))) + (when (or charset header (not file)) (setq tmp-file (mm-make-temp-file ;; Do we need to care for 8.3 filenames? "mm-" nil ".html"))) ;; Add a meta html tag to specify charset and a header. (cond (header - (let (title eheader body hcharset coding) + (let (title eheader body hcharset coding force-charset) (with-temp-buffer (mm-enable-multibyte) (setq case-fold-search t) @@ -2885,8 +2914,8 @@ message header will be added to the bodies of the \"text/html\" parts." charset) title (when title (mm-encode-coding-string title charset)) - body (mm-encode-coding-string (mm-get-part handle) - charset)) + body (mm-encode-coding-string content charset) + force-charset t) (setq hcharset (mm-find-mime-charset-region (point-min) (point-max))) (cond ((= (length hcharset) 1) @@ -2907,7 +2936,7 @@ message header will be added to the bodies of the \"text/html\" parts." title (when title (mm-encode-coding-string title coding)) - body (mm-get-part handle)) + body content) (setq charset 'utf-8 eheader (mm-encode-coding-string (buffer-string) charset) @@ -2916,22 +2945,23 @@ message header will be added to the bodies of the \"text/html\" parts." title charset)) body (mm-encode-coding-string (mm-decode-coding-string - (mm-get-part handle) body) - charset)))) + content body) + charset) + force-charset t))) (setq charset hcharset eheader (mm-encode-coding-string (buffer-string) coding) title (when title (mm-encode-coding-string title coding)) - body (mm-get-part handle))) + body content)) (setq eheader (mm-string-as-unibyte (buffer-string)) - body (mm-get-part handle)))) + body content))) (erase-buffer) (mm-disable-multibyte) (insert body) (when charset - (mm-add-meta-html-tag handle charset)) + (mm-add-meta-html-tag handle charset force-charset)) (when title (goto-char (point-min)) (unless (search-forward "<title>" nil t) @@ -2948,10 +2978,9 @@ message header will be added to the bodies of the \"text/html\" parts." (charset (mm-with-unibyte-buffer (insert (if (eq charset 'gnus-decoded) - (mm-encode-coding-string - (mm-get-part handle) - (setq charset 'utf-8)) - (mm-get-part handle))) + (mm-encode-coding-string content + (setq charset 'utf-8)) + content)) (if (or (mm-add-meta-html-tag handle charset) (not file)) (mm-write-region (point-min) (point-max) @@ -2998,17 +3027,23 @@ message header will be added to the bodies of the \"text/html\" parts." (defun gnus-article-browse-html-article (&optional arg) "View \"text/html\" parts of the current article with a WWW browser. +Inline images embedded in a message using the cid scheme, as they are +generally considered to be safe, will be processed properly. The message header is added to the beginning of every html part unless the prefix argument ARG is given. -Warning: Spammers use links to images in HTML articles to verify -whether you have read the message. As +Warning: Spammers use links to images (using the http scheme) in HTML +articles to verify whether you have read the message. As `gnus-article-browse-html-article' passes the HTML content to the browser without eliminating these \"web bugs\" you should only use it for mails from trusted senders. If you always want to display HTML parts in the browser, set -`mm-text-html-renderer' to nil." +`mm-text-html-renderer' to nil. + +This command creates temporary files to pass HTML contents including +images if any to the browser, and deletes them when exiting the group +\(if you want)." ;; Cf. `mm-w3m-safe-url-regexp' (interactive "P") (if arg @@ -3883,7 +3918,7 @@ Directory to save to is default to `gnus-article-save-directory'." "Save %s in rmail file" filename gnus-rmail-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-rmail)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) @@ -3901,7 +3936,7 @@ Directory to save to is default to `gnus-article-save-directory'." "Save %s in Unix mail file" filename gnus-mail-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-mail)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) @@ -3922,7 +3957,7 @@ Directory to save to is default to `gnus-article-save-directory'." "Save %s in file" filename gnus-file-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-file)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) @@ -3954,7 +3989,7 @@ The directory to save in defaults to `gnus-article-save-directory'." "Save %s body in file" filename gnus-file-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-file)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) @@ -4033,7 +4068,7 @@ and the raw article including all headers will be piped." (if default (setq command default) (error "A command is required"))) - (gnus-eval-in-buffer-window save-buffer + (with-current-buffer save-buffer (save-restriction (widen) (shell-command-on-region (point-min) (point-max) command nil))) @@ -4192,6 +4227,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (put-text-property (match-end 0) (point-max) 'face eface))))))))) +(autoload 'canlock-verify "canlock" nil t) ;; for XEmacs. + (defun article-verify-cancel-lock () "Verify Cancel-Lock header." (interactive) @@ -4258,6 +4295,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-date-lapsed article-emphasize article-treat-dumbquotes + article-treat-non-ascii article-normalize-headers ;;(article-show-all . gnus-article-show-all-headers) ))) @@ -4310,7 +4348,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) (gnus-summary-make-menu-bar)) - (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define gnus-article-article-menu gnus-article-mode-map "" @@ -4345,6 +4382,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (gnus-run-hooks 'gnus-article-menu-hook))) +(defvar bookmark-make-record-function) + (defun gnus-article-mode () "Major mode for displaying an article. @@ -4383,11 +4422,12 @@ commands: (make-local-variable 'gnus-article-image-alist) (make-local-variable 'gnus-article-charset) (make-local-variable 'gnus-article-ignored-charsets) + (set (make-local-variable 'bookmark-make-record-function) + 'gnus-summary-bookmark-make-record) ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space' ;; face. (set (make-local-variable 'nobreak-char-display) nil) (setq cursor-in-non-selected-windows nil) - (setq truncate-lines gnus-article-truncate-lines) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t @@ -4447,9 +4487,11 @@ Internal variable.") (setq gnus-button-marker-list nil) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) + (setq truncate-lines gnus-article-truncate-lines) (current-buffer)) (with-current-buffer (gnus-get-buffer-create name) (gnus-article-mode) + (setq truncate-lines gnus-article-truncate-lines) (make-local-variable 'gnus-summary-buffer) (setq gnus-summary-buffer (gnus-summary-buffer-name gnus-newsgroup-name)) @@ -4750,6 +4792,22 @@ General format specifiers can also be used. See Info node (vector (caddr c) (car c) :active t)) gnus-mime-button-commands))) +(defvar gnus-url-button-commands + '((gnus-article-copy-string "u" "Copy URL to kill ring"))) + +(defvar gnus-url-button-map + (let ((map (make-sparse-keymap))) + (dolist (c gnus-url-button-commands) + (define-key map (cadr c) (car c))) + map)) + +(easy-menu-define + gnus-url-button-menu gnus-url-button-map "URL button menu." + `("Url Button" + ,@(mapcar (lambda (c) + (vector (caddr c) (car c) :active t)) + gnus-url-button-commands))) + (defmacro gnus-bind-safe-url-regexp (&rest body) "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'." `(let ((mm-w3m-safe-url-regexp @@ -4759,7 +4817,11 @@ General format specifiers can also be used. See Info node (with-current-buffer gnus-article-current-summary gnus-newsgroup-name) gnus-newsgroup-name))) - (if (cond ((stringp gnus-safe-html-newsgroups) + (if (cond ((not group) + ;; Maybe we're in a mml-preview buffer + ;; and no group is selected. + t) + ((stringp gnus-safe-html-newsgroups) (string-match gnus-safe-html-newsgroups group)) ((consp gnus-safe-html-newsgroups) (member group gnus-safe-html-newsgroups))) @@ -4797,14 +4859,17 @@ General format specifiers can also be used. See Info node (defun gnus-article-jump-to-part (n) "Jump to MIME part N." (interactive "P") - (pop-to-buffer gnus-article-buffer) - ;; FIXME: why is it necessary? - (sit-for 0) - (let ((parts (length gnus-article-mime-handle-alist))) - (or n (setq n - (string-to-number - (read-string ;; Emacs 21 doesn't have `read-number'. - (format "Jump to part (2..%s): " parts))))) + (let ((parts (with-current-buffer gnus-article-buffer + (length gnus-article-mime-handle-alist)))) + (when (zerop parts) + (error "No such part")) + (pop-to-buffer gnus-article-buffer) + ;; FIXME: why is it necessary? + (sit-for 0) + (or n + (setq n (if (= parts 1) + 1 + (read-number (format "Jump to part (1..%s): " parts))))) (unless (and (integerp n) (<= n parts) (>= n 1)) (setq n (progn @@ -4823,6 +4888,10 @@ General format specifiers can also be used. See Info node (t (gnus-article-goto-part n))))) +(defvar gnus-mime-buttonized-part-id nil + "ID of a mime part that should be buttonized. +`gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.") + (eval-when-compile (defsubst gnus-article-edit-part (handles &optional current-id) "Edit an article in order to delete a mime part. @@ -4865,10 +4934,15 @@ and `gnus-mime-delete-part', and not provided at run-time normally." ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)) t) - (gnus-article-edit-done) + ;; Force buttonizing this part. + (let ((gnus-mime-buttonized-part-id current-id)) + (gnus-article-edit-done)) (gnus-configure-windows 'article) (when (and current-id (integerp gnus-auto-select-part)) - (gnus-article-jump-to-part (+ current-id gnus-auto-select-part))))) + (gnus-article-jump-to-part + (min (max (+ current-id gnus-auto-select-part) 1) + (with-current-buffer gnus-article-buffer + (length gnus-article-mime-handle-alist))))))) (defun gnus-mime-replace-part (file) "Replace MIME part under point with an external body." @@ -4949,7 +5023,7 @@ Deleting parts may malfunction or destroy the article; continue? ")) (unless data (error "No MIME part under point")) (with-current-buffer (mm-handle-buffer data) - (let ((bsize (format "%s" (buffer-size)))) + (let ((bsize (buffer-size))) (erase-buffer) (insert (concat @@ -4958,7 +5032,10 @@ Deleting parts may malfunction or destroy the article; continue? ")) "|\n" "| Type: " type "\n" "| Filename: " filename "\n" - "| Size (encoded): " bsize " Byte\n" + "| Size (encoded): " (format "%s byte%s\n" + bsize (if (= bsize 1) + "" + "s")) (when description (concat "| Description: " description "\n")) "`----\n")) @@ -4978,13 +5055,14 @@ Deleting parts may malfunction or destroy the article; continue? ")) (when data (mm-save-part data)))) -(defun gnus-mime-pipe-part () - "Pipe the MIME part under point to a process." +(defun gnus-mime-pipe-part (&optional cmd) + "Pipe the MIME part under point to a process. +Use CMD as the process." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (when data - (mm-pipe-part data)))) + (mm-pipe-part data cmd)))) (defun gnus-mime-view-part () "Interactively choose a viewing method for the MIME part under point." @@ -5020,11 +5098,12 @@ available media-types." (unless mime-type (setq mime-type (let ((default (gnus-mime-view-part-as-type-internal))) - (completing-read - (format "View as MIME type (default %s): " - (car default)) - (mapcar #'list (mailcap-mime-types)) - pred nil nil nil + (gnus-completing-read + "View as MIME type" + (if pred + (gnus-remove-if-not pred (mailcap-mime-types)) + (mailcap-mime-types)) + nil nil nil (car default))))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) @@ -5090,7 +5169,7 @@ are decompressed." (if (or coding-system (and charset (setq coding-system (mm-charset-to-coding-system charset)) - (not (eq charset 'ascii)))) + (not (eq coding-system 'ascii)))) (progn (mm-enable-multibyte) (insert (mm-decode-coding-string contents coding-system)) @@ -5263,11 +5342,9 @@ specified charset." (mm-enable-external t)) (if (not (stringp method)) (gnus-mime-view-part-as-type - nil (lambda (types) (stringp (mailcap-mime-info (car types))))) + nil (lambda (type) (stringp (mailcap-mime-info type)))) (when handle - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (mm-display-part handle)))))) + (mm-display-part handle nil t))))) (defun gnus-mime-view-part-internally (&optional handle) "View the MIME part under point with an internal viewer. @@ -5284,16 +5361,14 @@ If no internal viewer is available, use an external viewer." (inhibit-read-only t)) (if (not (mm-inlinable-p handle)) (gnus-mime-view-part-as-type - nil (lambda (types) (mm-inlinable-p handle (car types)))) + nil (lambda (type) (mm-inlinable-p handle type))) (when handle - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (gnus-bind-safe-url-regexp (mm-display-part handle))))))) + (gnus-bind-safe-url-regexp (mm-display-part handle)))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." (interactive - (list (completing-read "Action: " gnus-mime-action-alist nil t))) + (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t))) (gnus-article-check-buffer) (let ((action-pair (assoc action gnus-mime-action-alist))) (if action-pair @@ -5351,6 +5426,10 @@ If INTERACTIVE, call FUNCTION interactivly." (when (gnus-article-goto-part n) ;; We point the cursor and the arrow at the MIME button ;; when the `function' prompt the user for something. + (unless (and (pos-visible-in-window-p) + (> (count-lines (point) (window-end)) + (/ (1- (window-height)) 3))) + (recenter (/ (1- (window-height)) 3))) (let ((cursor-in-non-selected-windows t) (overlay-arrow-string "=>") (overlay-arrow-position (point-marker))) @@ -5362,11 +5441,10 @@ If INTERACTIVE, call FUNCTION interactivly." (funcall function)) (interactive (call-interactively - function - (cdr (assq n gnus-article-mime-handle-alist)))) + function (get-text-property (point) 'gnus-data))) (t (funcall function - (cdr (assq n gnus-article-mime-handle-alist))))) + (get-text-property (point) 'gnus-data)))) (set-marker overlay-arrow-position nil) (unless gnus-auto-select-part (gnus-select-frame-set-input-focus frame) @@ -5462,7 +5540,9 @@ N is the numerical prefix." 1)) (defun gnus-article-view-part (&optional n) - "View MIME part N, which is the numerical prefix." + "View MIME part N, which is the numerical prefix. +If the part is already shown, hide the part. If N is nil, view +all parts." (interactive "P") (with-current-buffer gnus-article-buffer (or (numberp n) (setq n (gnus-article-mime-match-handle-first @@ -5529,7 +5609,41 @@ N is the numerical prefix." (defun gnus-article-goto-part (n) "Go to MIME part N." - (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) + (when gnus-break-pages + (widen)) + (prog1 + (let ((start (text-property-any (point-min) (point-max) 'gnus-part n)) + part handle end next handles) + (when start + (goto-char start) + (if (setq handle (get-text-property start 'gnus-data)) + start + ;; Go to the displayed subpart, assuming this is + ;; multipart/alternative. + (setq part start + end (point-at-eol)) + (while (and (not handle) + part + (< part end) + (setq next (text-property-not-all part end + 'gnus-data nil))) + (setq part next + handle (get-text-property part 'gnus-data)) + (push (cons handle part) handles) + (unless (mm-handle-displayed-p handle) + (setq handle nil + part (text-property-any part end 'gnus-data nil)))) + (unless handle + ;; No subpart is displayed, so we find preferred one. + (setq part + (cdr (assq (mm-preferred-alternative + (nreverse (mapcar 'car handles))) + handles)))) + (if part + (goto-char (1+ part)) + start)))) + (when gnus-break-pages + (gnus-narrow-to-page)))) (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) (let ((gnus-tmp-name @@ -5576,7 +5690,7 @@ N is the numerical prefix." :action 'gnus-widget-press-button :button-keymap gnus-mime-button-map :help-echo - (lambda (widget/window &optional overlay pos) + (lambda (widget) ;; Needed to properly clear the message due to a bug in ;; wid-edit (XEmacs only). (if (boundp 'help-echo-owns-message) @@ -5584,14 +5698,7 @@ N is the numerical prefix." (format "%S: %s the MIME part; %S: more options" (aref gnus-mouse-2 0) - ;; XEmacs will get a single widget arg; Emacs 21 will get - ;; window, overlay, position. - (if (mm-handle-displayed-p - (if overlay - (with-current-buffer (gnus-overlay-buffer overlay) - (widget-get (widget-at (gnus-overlay-start overlay)) - :mime-handle)) - (widget-get widget/window :mime-handle))) + (if (mm-handle-displayed-p (widget-get widget :mime-handle)) "hide" "show") (aref gnus-down-mouse-3 0)))))) @@ -5645,7 +5752,7 @@ N is the numerical prefix." (save-restriction (article-goto-body) (narrow-to-region (point) (point-max)) - (gnus-treat-article nil 1 1) + (gnus-treat-article nil 1 1 "text/plain") (widen))) (unless ihandles ;; Highlight the headers. @@ -5745,7 +5852,12 @@ If displaying \"text/html\" is discouraged \(see (while ignored (when (string-match (pop ignored) type) (throw 'ignored nil))) - (if (and (setq not-attachment + (if (and (not (and (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-inhibit-images) + gnus-inhibit-images) + (string-match "\\`image/" type))) + (setq not-attachment (and (not (mm-inline-override-p handle)) (or (not (mm-handle-disposition handle)) (equal (car (mm-handle-disposition handle)) @@ -5770,7 +5882,8 @@ If displaying \"text/html\" is discouraged \(see ((or (bobp) (eq (char-before (1- (point))) ?\n)) 0) (t 1)))) (when (or (not display) - (not (gnus-unbuttonized-mime-type-p type))) + (not (gnus-unbuttonized-mime-type-p type)) + (eq id gnus-mime-buttonized-part-id)) (gnus-insert-mime-button handle id (list (or display (and not-attachment text)))) (gnus-article-insert-newline) @@ -5932,7 +6045,7 @@ If displaying \"text/html\" is discouraged \(see (gnus-treat-article nil (length gnus-article-mime-handle-alist) (gnus-article-mime-total-parts) - (mm-handle-media-type handle)))))) + (mm-handle-media-type preferred)))))) (goto-char (point-max)) (setcdr begend (point-marker))))) (when ibegend @@ -6195,29 +6308,24 @@ Argument LINES specifies lines to be scrolled up." (gnus-article-next-page-1 lines) nil)) -(defmacro gnus-article-beginning-of-window () +(defun gnus-article-beginning-of-window () "Move point to the beginning of the window. In Emacs, the point is placed at the line number which `scroll-margin' specifies." (if (featurep 'xemacs) - '(move-to-window-line 0) - '(move-to-window-line - (min (max 0 scroll-margin) - (max 1 (- (window-height) - (if mode-line-format 1 0) - (if header-line-format 1 0) - 2)))))) + (move-to-window-line 0) + ;; There is an obscure bug in Emacs that makes it impossible to + ;; scroll past big pictures in the article buffer. Try to fix + ;; this by adding a sanity check by counting the lines visible. + (when (> (count-lines (window-start) (window-end)) 30) + (move-to-window-line + (min (max 0 scroll-margin) + (max 1 (- (window-height) + (if mode-line-format 1 0) + (if header-line-format 1 0) + 2))))))) (defun gnus-article-next-page-1 (lines) - (unless (featurep 'xemacs) - ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for - ;; too many number of lines if `scroll-margin' is set as two or greater. - (when (and (numberp lines) - (> lines 0) - (> scroll-margin 0)) - (setq lines (min lines - (max 0 (- (count-lines (window-start) (point-max)) - scroll-margin)))))) (condition-case () (let ((scroll-in-place nil)) (scroll-up lines)) @@ -6296,7 +6404,7 @@ not have a face in `gnus-article-boring-faces'." (defun gnus-article-describe-briefly () "Describe article mode commands briefly." (interactive) - (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) (defun gnus-article-check-buffer () "Beep if not in an article buffer." @@ -6471,6 +6579,9 @@ KEY is a string or a vector." (defvar gnus-draft-mode) ;; Calling help-buffer will autoload help-mode. (defvar help-xref-stack-item) +;; Emacs 22 doesn't load it in the batch mode. +(eval-when-compile + (autoload 'help-buffer "help-mode")) (defun gnus-article-describe-bindings (&optional prefix) "Show a list of all defined keys, and their definitions. @@ -6521,9 +6632,7 @@ then we display only bindings that start with that prefix." (with-current-buffer ,(current-buffer) (gnus-article-describe-bindings prefix))) ,prefix))) - (with-current-buffer (if (fboundp 'help-buffer) - (let (help-xref-following) (help-buffer)) - "*Help*") ;; Emacs 21 + (with-current-buffer (let (help-xref-following) (help-buffer)) (setq help-xref-stack-item item))))) (defun gnus-article-reply-with-original (&optional wide) @@ -6777,6 +6886,18 @@ If given a prefix, show the hidden text instead." (point)) (set-buffer buf)))))) +(defun gnus-block-private-groups (group) + (if (gnus-news-group-p group) + ;; Block nothing in news groups. + nil + ;; Block everything anywhere else. + ".")) + +(defun gnus-blocked-images () + (if (functionp gnus-blocked-images) + (funcall gnus-blocked-images gnus-newsgroup-name) + gnus-blocked-images)) + ;;; ;;; Article editing ;;; @@ -6920,9 +7041,7 @@ groups." (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) ;; Flush original article as well. - (when (get-buffer gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (setq gnus-original-article nil))) + (gnus-flush-original-article-buffer) (when gnus-use-cache (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current))) @@ -6936,6 +7055,11 @@ groups." (set-window-point (get-buffer-window buf) (point))) (gnus-summary-show-article)) +(defun gnus-flush-original-article-buffer () + (when (get-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (setq gnus-original-article nil)))) + (defun gnus-article-edit-exit () "Exit the article editing without updating." (interactive) @@ -7024,46 +7148,6 @@ man page." (function :tag "Other")) :group 'gnus-article-buttons) -(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/" - "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive. -If the default site is too slow, try to find a CTAN mirror, see -<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also -the variable `gnus-button-handle-ctan'." - :version "22.1" - :group 'gnus-article-buttons - :link '(custom-manual "(gnus)Group Parameters") - :type '(choice (const "http://www.tex.ac.uk/tex-archive/") - (const "http://tug.ctan.org/tex-archive/") - (const "http://www.dante.de/CTAN/") - (string :tag "Other"))) - -(defcustom gnus-button-ctan-handler 'browse-url - "Function to use for displaying CTAN links. -The function must take one argument, the string naming the URL." - :version "22.1" - :type '(choice (function-item :tag "Browse Url" browse-url) - (function :tag "Other")) - :group 'gnus-article-buttons) - -(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/" - "Bogus strings removed from CTAN URLs." - :version "22.1" - :group 'gnus-article-buttons - :type '(choice (const "^/?tex-archive/\\|/") - (regexp :tag "Other"))) - -(defcustom gnus-button-ctan-directory-regexp - (regexp-opt - (list "archive-tools" "biblio" "bibliography" "digests" "documentation" - "dviware" "fonts" "graphics" "help" "indexing" "info" "language" - "languages" "macros" "nonfree" "obsolete" "support" "systems" - "tds" "tools" "usergrps" "web") t) - "Regular expression for ctan directories. -It should match all directories in the top level of `gnus-ctan-url'." - :version "22.1" - :group 'gnus-article-buttons - :type 'regexp) - (defcustom gnus-button-mid-or-mail-regexp (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@" gnus-button-valid-fqdn-regexp @@ -7321,26 +7405,6 @@ Calls `describe-variable' or `describe-function'." (gnus-message 1 "Cannot locale library `%s'." url) (find-file-read-only file)))) -(defun gnus-button-handle-ctan (url) - "Call `browse-url' when pushing a CTAN URL button." - (funcall - gnus-button-ctan-handler - (concat - gnus-ctan-url - (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp "")))) - -(defcustom gnus-button-tex-level 5 - "*Integer that says how many TeX-related buttons Gnus will show. -The higher the number, the more buttons will appear and the more false -positives are possible. Note that you can set this variable local to -specific groups. Setting it higher in TeX groups is probably a good idea. -See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on -how to set variables in specific groups." - :version "22.1" - :group 'gnus-article-buttons - :link '(custom-manual "(gnus)Group Parameters") - :type 'integer) - (defcustom gnus-button-man-level 5 "*Integer that says how many man-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false @@ -7407,20 +7471,6 @@ positives are possible." 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) - ;; CTAN - ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" - gnus-button-ctan-directory-regexp - "[^][>)!;:,'\n\t ]+\\)") - 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) - ((concat "\\btex-archive/\\(" - gnus-button-ctan-directory-regexp - "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)") - 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1) - ((concat - "\\b\\(" - gnus-button-ctan-directory-regexp - "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") - 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) ;; Info Konqueror style <info:/foo/bar baz>. ;; Must come before " Gnus home-grown style". ("\\binfo://?\\([^'\">\n\t]+\\)" @@ -7719,7 +7769,11 @@ specified by `gnus-button-alist'." (unless (and (eq (car entry) 'gnus-button-url-regexp) (gnus-article-extend-url-button from start end)) (gnus-article-add-button start end - 'gnus-button-push from))))))))) + 'gnus-button-push from) + (gnus-put-text-property + start end + 'gnus-string (buffer-substring-no-properties + start end)))))))))) (defun gnus-article-extend-url-button (beg start end) "Extend url button if url is folded into two or more lines. @@ -7811,7 +7865,7 @@ url is put as the `gnus-button-url' overlay property on the button." ;;; External functions: -(defun gnus-article-add-button (from to fun &optional data) +(defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." (when gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to nil t) @@ -7823,8 +7877,21 @@ url is put as the `gnus-button-url' overlay property on the button." (list 'gnus-callback fun) (and data (list 'gnus-data data)))) (widget-convert-button 'link from to :action 'gnus-widget-press-button + :help-echo (or text "Follow the link") + :keymap gnus-url-button-map :button-keymap gnus-widget-button-keymap)) +(defun gnus-article-copy-string () + "Copy the string in the button to the kill ring." + (interactive) + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-string))) + (when data + (with-temp-buffer + (insert data) + (copy-region-as-kill (point-min) (point-max)) + (message "Copied %s" data))))) + ;;; Internal functions: (defun gnus-article-set-globals () @@ -8020,6 +8087,7 @@ url is put as the `gnus-button-url' overlay property on the button." (Info-index-next 1))) nil))) +(autoload 'pgg-snarf-keys-region "pgg") ;; Called after pgg-snarf-keys-region, which autoloads pgg.el. (declare-function pgg-display-output-buffer "pgg" (start end status)) @@ -8080,6 +8148,7 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-url-mailto (url) ;; Send mail to someone + (setq url (replace-regexp-in-string "\n" " " url)) (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) (let (to args subject func) @@ -8089,8 +8158,7 @@ url is put as the `gnus-button-url' overlay property on the button." (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) (concat "to=" (match-string 1 url) "&" (match-string 2 url)) - (concat "to=" url))) - t) + (concat "to=" url)))) subject (cdr-safe (assoc "subject" args))) (gnus-msg-mail) (while args @@ -8123,9 +8191,6 @@ url is put as the `gnus-button-url' overlay property on the button." (defvar gnus-next-page-map (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-button-next-page) (define-key map "\r" 'gnus-button-next-page) map)) @@ -8244,16 +8309,19 @@ For example: ;;; Treatment top-level handling. ;;; -(defun gnus-treat-article (condition &optional part-number total-parts type) - (let ((length (- (point-max) (point-min))) +(defvar gnus-inhibit-article-treatments nil) + +(defun gnus-treat-article (gnus-treat-condition + &optional part-number total-parts gnus-treat-type) + (let ((gnus-treat-length (- (point-max) (point-min))) (alist gnus-treatment-function-alist) (article-goto-body-goes-to-point-min-p t) (treated-type - (or (not type) + (or (not gnus-treat-type) (catch 'found (let ((list gnus-article-treat-types)) (while list - (when (string-match (pop list) type) + (when (string-match (pop list) gnus-treat-type) (throw 'found t))))))) (highlightp (gnus-visual-p 'article-highlight 'highlight)) val elem) @@ -8266,6 +8334,8 @@ For example: (symbol-value (car elem)))) (when (and (or (consp val) treated-type) + (or (not gnus-inhibit-article-treatments) + (eq gnus-treat-condition 'head)) (gnus-treat-predicate val) (or (not (get (car elem) 'highlight)) highlightp)) @@ -8275,16 +8345,16 @@ For example: ;; Dynamic variables. (defvar part-number) (defvar total-parts) -(defvar type) -(defvar condition) -(defvar length) +(defvar gnus-treat-type) +(defvar gnus-treat-condition) +(defvar gnus-treat-length) (defun gnus-treat-predicate (val) (cond ((null val) nil) - (condition - (eq condition val)) + (gnus-treat-condition + (eq gnus-treat-condition val)) ((and (listp val) (stringp (car val))) (apply 'gnus-or (mapcar `(lambda (s) @@ -8300,7 +8370,7 @@ For example: ((eq pred 'not) (not (gnus-treat-predicate (car val)))) ((eq pred 'typep) - (equal (car val) type)) + (equal (car val) gnus-treat-type)) (t (error "%S is not a valid predicate" pred))))) ((eq val t) @@ -8312,7 +8382,7 @@ For example: ((eq val 'last) (eq part-number total-parts)) ((numberp val) - (< length val)) + (< gnus-treat-length val)) (t (error "%S is not a valid value" val)))) @@ -8321,9 +8391,9 @@ For example: (interactive (list (or gnus-article-encrypt-protocol - (completing-read "Encrypt protocol: " - gnus-article-encrypt-protocol-alist - nil t)) + (gnus-completing-read "Encrypt protocol" + (mapcar 'car gnus-article-encrypt-protocol-alist) + t)) current-prefix-arg)) ;; User might hit `K E' instead of `K e', so prompt once. (when (and gnus-article-encrypt-protocol @@ -8385,9 +8455,7 @@ For example: (when gnus-keep-backlog (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) - (when (get-buffer gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (setq gnus-original-article nil))) + (gnus-flush-original-article-buffer) (when gnus-use-cache (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current)))))))) @@ -8575,7 +8643,7 @@ For example: :action 'gnus-widget-press-button :button-keymap gnus-mime-security-button-map :help-echo - (lambda (widget/window &optional overlay pos) + (lambda (widget) ;; Needed to properly clear the message due to a bug in ;; wid-edit (XEmacs only). (when (boundp 'help-echo-owns-message) @@ -8637,5 +8705,4 @@ For example: (run-hooks 'gnus-art-load-hook) -;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33 ;;; gnus-art.el ends here diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 4a3c6f36e3..9f20048c37 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -71,6 +71,13 @@ It should return non-nil if the article is to be prefetched." :group 'gnus-asynchronous :type 'function) +(defcustom gnus-async-post-fetch-function nil + "Function called after an article has been prefetched. +The function will be called narrowed to the region of the article +that was fetched." + :group 'gnus-asynchronous + :type 'function) + ;;; Internal variables. (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") @@ -138,8 +145,7 @@ It should return non-nil if the article is to be prefetched." (when (and (gnus-buffer-live-p summary) gnus-asynchronous (gnus-group-asynchronous-p group)) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let ((next (caadr (gnus-data-find-list article)))) (when next (if (not (fboundp 'run-with-idle-timer)) @@ -198,8 +204,7 @@ It should return non-nil if the article is to be prefetched." (when (and do-fetch article) ;; We want to fetch some more articles. - (save-excursion - (set-buffer summary) + (with-current-buffer summary (let (mark) (gnus-async-set-buffer) (goto-char (point-max)) @@ -221,12 +226,23 @@ It should return non-nil if the article is to be prefetched." `(lambda (arg) (gnus-async-article-callback arg ,group ,article ,mark ,summary ,next))) +(eval-when-compile + (autoload 'gnus-html-prefetch-images "gnus-html")) + (defun gnus-async-article-callback (arg group article mark summary next) "Function called when an async article is done being fetched." (save-excursion (setq gnus-async-current-prefetch-article nil) (when arg (gnus-async-set-buffer) + (save-excursion + (save-restriction + (narrow-to-region mark (point-max)) + ;; Prefetch images for the groups that want that. + (when (fboundp 'gnus-html-prefetch-images) + (gnus-html-prefetch-images summary)) + (when gnus-async-post-fetch-function + (funcall gnus-async-post-fetch-function summary)))) (gnus-async-with-semaphore (setq gnus-async-article-alist @@ -300,7 +316,8 @@ It should return non-nil if the article is to be prefetched." (set-marker (caddr entry) nil)) (gnus-async-with-semaphore (setq gnus-async-article-alist - (delq entry gnus-async-article-alist)))) + (delq entry gnus-async-article-alist)) + (unintern (car entry) gnus-async-hashtb))) (defun gnus-async-prefetch-remove-group (group) "Remove all articles belonging to GROUP from the prefetch buffer." @@ -316,8 +333,8 @@ It should return non-nil if the article is to be prefetched." "Return the entry for ARTICLE in GROUP if it has been prefetched." (let ((entry (save-excursion (gnus-async-set-buffer) - (assq (intern (format "%s-%d" group article) - gnus-async-hashtb) + (assq (intern-soft (format "%s-%d" group article) + gnus-async-hashtb) gnus-async-article-alist)))) ;; Perhaps something has emptied the buffer? (if (and entry @@ -372,5 +389,4 @@ It should return non-nil if the article is to be prefetched." (provide 'gnus-async) -;; arch-tag: fee61de5-3ea2-4de6-8578-2f90ce89391d ;;; gnus-async.el ends here diff --git a/lisp/gnus/gnus-audio.el b/lisp/gnus/gnus-audio.el deleted file mode 100644 index ede7a716f4..0000000000 --- a/lisp/gnus/gnus-audio.el +++ /dev/null @@ -1,150 +0,0 @@ -;;; gnus-audio.el --- Sound effects for Gnus - -;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Steven L. Baur <[email protected]> -;; Keywords: news, mail, multimedia - -;; 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 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This file provides access to sound effects in Gnus. -;; This file is partially stripped to support earcons.el. - -;;; Code: - -(require 'nnheader) - -(defgroup gnus-audio nil - "Playing sound in Gnus." - :version "21.1" - :group 'gnus-visual - :group 'multimedia) - -(defvar gnus-audio-inline-sound - (or (if (fboundp 'device-sound-enabled-p) - (device-sound-enabled-p)) ; XEmacs - (fboundp 'play-sound)) ; Emacs 21 - "Non-nil means try to play sounds without using an external program.") - -(defcustom gnus-audio-directory (nnheader-find-etc-directory "sounds") - "The directory containing the Sound Files." - :type '(choice directory (const nil)) - :group 'gnus-audio) - -(defcustom gnus-audio-au-player (executable-find "play") - "Executable program for playing sun AU format sound files." - :group 'gnus-audio - :type '(choice file (const nil))) - -(defcustom gnus-audio-wav-player (executable-find "play") - "Executable program for playing WAV files." - :group 'gnus-audio - :type '(choice file (const nil))) - -;;; The following isn't implemented yet. Wait for Millennium Gnus. -;;(defvar gnus-audio-effects-enabled t -;; "When t, Gnus will use sound effects.") -;;(defvar gnus-audio-enable-hooks nil -;; "Functions run when enabling sound effects.") -;;(defvar gnus-audio-disable-hooks nil -;; "Functions run when disabling sound effects.") -;;(defvar gnus-audio-theme-song nil -;; "Theme song for Gnus.") -;;(defvar gnus-audio-enter-group nil -;; "Sound effect played when selecting a group.") -;;(defvar gnus-audio-exit-group nil -;; "Sound effect played when exiting a group.") -;;(defvar gnus-audio-score-group nil -;; "Sound effect played when scoring a group.") -;;(defvar gnus-audio-busy-sound nil -;; "Sound effect played when going into a ... sequence.") - - -;;;###autoload -;;(defun gnus-audio-enable-sound () -;; "Enable Sound Effects for Gnus." -;; (interactive) -;; (setq gnus-audio-effects-enabled t) -;; (gnus-run-hooks gnus-audio-enable-hooks)) - -;;;###autoload - ;(defun gnus-audio-disable-sound () -;; "Disable Sound Effects for Gnus." -;; (interactive) -;; (setq gnus-audio-effects-enabled nil) -;; (gnus-run-hooks gnus-audio-disable-hooks)) - -;;;###autoload -(defun gnus-audio-play (file) - "Play a sound FILE through the speaker." - (interactive "fSound file name: ") - (let ((sound-file (if (file-exists-p file) - file - (expand-file-name file gnus-audio-directory)))) - (when (file-exists-p sound-file) - (cond ((and gnus-audio-inline-sound - (condition-case nil - ;; Even if we have audio, we may fail with the - ;; wrong sort of sound file. - (progn (play-sound-file sound-file) - t) - (error nil)))) - ;; If we don't have built-in sound, or playing it failed, - ;; try with external program. - ((equal "wav" (file-name-extension sound-file)) - (call-process gnus-audio-wav-player - sound-file - 0 - nil - sound-file)) - ((equal "au" (file-name-extension sound-file)) - (call-process gnus-audio-au-player - sound-file - 0 - nil - sound-file)))))) - - -;;; The following isn't implemented yet, wait for Red Gnus -;;(defun gnus-audio-startrek-sounds () -;; "Enable sounds from Star Trek the original series." -;; (interactive) -;; (setq gnus-audio-busy-sound "working.au") -;; (setq gnus-audio-enter-group "bulkhead_door.au") -;; (setq gnus-audio-exit-group "bulkhead_door.au") -;; (setq gnus-audio-score-group "ST_laser.au") -;; (setq gnus-audio-theme-song "startrek.au") -;; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group) -;; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group)) -;;;*** - -(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au" - "Name of the Gnus startup jingle file.") - -(defun gnus-play-jingle () - "Play the Gnus startup jingle, unless that's inhibited." - (interactive) - (gnus-audio-play gnus-startup-jingle)) - -(provide 'gnus-audio) - -(run-hooks 'gnus-audio-load-hook) - -;; arch-tag: 6f129e78-3416-4fc9-973f-6cf5ac8d654b -;;; gnus-audio.el ends here diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index 52a5c559bf..66576b7777 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el @@ -40,8 +40,7 @@ (defun gnus-backlog-buffer () "Return the backlog buffer." (or (get-buffer gnus-backlog-buffer) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-backlog-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-backlog-buffer) (buffer-disable-undo) (setq buffer-read-only t) (get-buffer gnus-backlog-buffer)))) @@ -76,8 +75,7 @@ (gnus-backlog-remove-oldest-article)) (push ident gnus-backlog-articles) ;; Insert the new article. - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (let (buffer-read-only) (goto-char (point-max)) (unless (bolp) @@ -90,8 +88,7 @@ (gnus-error 3 "Article %d is blank" number)))))))) (defun gnus-backlog-remove-oldest-article () - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (goto-char (point-min)) (if (zerop (buffer-size)) () ; The buffer is empty. @@ -114,8 +111,7 @@ beg end) (when (memq ident gnus-backlog-articles) ;; It was in the backlog. - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (let (buffer-read-only) (when (setq beg (text-property-any (point-min) (point-max) 'gnus-backlog @@ -138,8 +134,7 @@ beg end) (when (memq ident gnus-backlog-articles) ;; It was in the backlog. - (save-excursion - (set-buffer (gnus-backlog-buffer)) + (with-current-buffer (gnus-backlog-buffer) (if (not (setq beg (text-property-any (point-min) (point-max) 'gnus-backlog ident))) @@ -150,8 +145,7 @@ (setq end (next-single-property-change (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) - (save-excursion - (and buffer (set-buffer buffer)) + (with-current-buffer (or (current-buffer) buffer) (let ((buffer-read-only nil)) (erase-buffer) (insert-buffer-substring gnus-backlog-buffer beg end))) @@ -159,5 +153,4 @@ (provide 'gnus-bcklg) -;; arch-tag: 66259e56-505a-4bba-8a0d-3552c5b94e39 ;;; gnus-bcklg.el ends here diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 39f583a83a..a72b0c4fb7 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -156,9 +156,6 @@ The default value is \(author subject date group annotation\)." "The current version of the format used by bookmark files. You should never need to change this.") -(defvar gnus-bookmark-after-jump-hook nil - "Hook run after `gnus-bookmark-jump' jumps to a Gnus bookmark.") - (defvar gnus-bookmark-alist () "Association list of Gnus bookmarks and their records. The format of the alist is @@ -292,8 +289,8 @@ So the cdr of each bookmark is an alist too.") (interactive) (gnus-bookmark-maybe-load-default-file) (let* ((bookmark (or bmk-name - (completing-read "Jump to bookmarked article: " - gnus-bookmark-alist))) + (gnus-completing-read "Jump to bookmarked article" + (mapcar 'car gnus-bookmark-alist)))) (bmk-record (cadr (assoc bookmark gnus-bookmark-alist))) (group (cdr (assoc 'group bmk-record))) (message-id (cdr (assoc 'message-id bmk-record)))) @@ -541,7 +538,7 @@ Optional argument SHOW means show them unconditionally." (let ((bmrk (gnus-bookmark-bmenu-bookmark))) (setq gnus-bookmark-bmenu-hidden-bookmarks (cons bmrk gnus-bookmark-bmenu-hidden-bookmarks)) - (let ((start (save-excursion (end-of-line) (point)))) + (let ((start (point-at-eol))) (move-to-column gnus-bookmark-bmenu-file-column t) ;; Strip off `mouse-face' from the white spaces region. (if (gnus-bookmark-mouse-available-p) @@ -575,10 +572,9 @@ Optional argument SHOW means show them unconditionally." "Kill from point to end of line. If optional arg NEWLINE-TOO is non-nil, delete the newline too. Does not affect the kill ring." - (let ((eol (save-excursion (end-of-line) (point)))) - (delete-region (point) eol) - (if (and newline-too (looking-at "\n")) - (delete-char 1)))) + (delete-region (point) (point-at-eol)) + (if (and newline-too (looking-at "\n")) + (delete-char 1))) (defun gnus-bookmark-get-details (bmk-name details-list) "Get details for a Gnus BMK-NAME depending on DETAILS-LIST." @@ -828,5 +824,4 @@ probably because we were called from there." (provide 'gnus-bookmark) -;; arch-tag: 779df694-366f-46e8-84b2-1d0340e6f525 ;;; gnus-bookmark.el ends here diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 272140f359..85f5f46e6c 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -180,8 +180,7 @@ it's not cached." ;; Save the article in the cache. (if (file-exists-p file) t ; The article already is saved. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (require 'gnus-art) (let ((gnus-use-cache nil) (gnus-article-decode-hook nil)) @@ -384,9 +383,14 @@ Returns the list of articles removed." "Insert all the articles cached for this group into the current buffer." (interactive) (let ((gnus-verbose (max 6 gnus-verbose))) - (if (not gnus-newsgroup-cached) - (gnus-message 3 "No cached articles for this group") - (gnus-summary-goto-subjects gnus-newsgroup-cached)))) + (cond + ((not gnus-newsgroup-cached) + (gnus-message 3 "No cached articles for this group")) + ;; This is faster if there are few articles to insert. + ((< (length gnus-newsgroup-cached) 20) + (gnus-summary-goto-subjects gnus-newsgroup-cached)) + (t + (gnus-summary-include-articles gnus-newsgroup-cached))))) (defun gnus-summary-limit-include-cached () "Limit the summary buffer to articles that are cached." @@ -554,8 +558,7 @@ system for example was used.") (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) beg end) (gnus-cache-save-buffers) - (save-excursion - (set-buffer cache-buf) + (with-current-buffer cache-buf (erase-buffer) (let ((coding-system-for-read gnus-cache-overview-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) @@ -605,7 +608,7 @@ system for example was used.") (insert-file-contents (gnus-cache-file-name group entry))) (goto-char (point-min)) (insert "220 ") - (princ (car cached) (current-buffer)) + (princ (pop cached) (current-buffer)) (insert " Article retrieved.\n") (search-forward "\n\n" nil 'move) (delete-region (point) (point-max)) @@ -844,8 +847,7 @@ supported." ,@body) (when (and gnus-cache-need-update-total-fetched-for (not gnus-cache-inhibit-update-total-fetched-for)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq gnus-cache-need-update-total-fetched-for nil) (gnus-group-update-group ,group t))))) @@ -868,7 +870,7 @@ supported." (while (setq file (pop files)) (setq attrs (file-attributes file)) (unless (nth 0 attrs) - (incf size (float (nth 7 attrs))))))) + (incf size (float (nth 7 attrs))))))) (setq gnus-cache-need-update-total-fetched-for t) @@ -879,10 +881,10 @@ supported." (gnus-cache-with-refreshed-group group (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) - (gnus-sethash group (make-list 2 0) + (gnus-sethash group (make-list 2 0) gnus-cache-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system) - (size (or (nth 7 (file-attributes + (size (or (nth 7 (file-attributes (or file (gnus-cache-file-name group ".overview")))) 0))) @@ -911,11 +913,10 @@ supported." (if entry (apply '+ entry) (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) - (+ + (+ (gnus-cache-update-overview-total-fetched-for group nil) (gnus-cache-update-file-total-fetched-for group nil))))))) (provide 'gnus-cache) -;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a ;;; gnus-cache.el ends here diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index a33f3eab41..b44ff78600 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -407,9 +407,7 @@ lines matches `message-cite-prefix-regexp' with the same prefix. Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." (interactive (list 'force)) - (save-excursion - (unless same-buffer - (set-buffer gnus-article-buffer)) + (with-current-buffer (if same-buffer (current-buffer) gnus-article-buffer) (gnus-cite-parse-maybe force) (let ((buffer-read-only nil) (alist gnus-cite-prefix-alist) @@ -462,8 +460,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (defun gnus-dissect-cited-text () "Dissect the article buffer looking for cited text." - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-cite-parse-maybe nil t) (let ((alist gnus-cite-prefix-alist) prefix numbers number marks m) @@ -519,12 +516,16 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (setq m (cdr m)))) marks)))) -(defun gnus-article-fill-cited-article (&optional force width) +(defun gnus-article-fill-cited-long-lines () + (gnus-article-fill-cited-article nil t)) + +(defun gnus-article-fill-cited-article (&optional width long-lines) "Do word wrapping in the current article. -If WIDTH (the numerical prefix), use that text width when filling." - (interactive (list t current-prefix-arg)) - (save-excursion - (set-buffer gnus-article-buffer) +If WIDTH (the numerical prefix), use that text width when +filling. If LONG-LINES, only fill sections that have lines +longer than the frame width." + (interactive "P") + (with-current-buffer gnus-article-buffer (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) @@ -539,8 +540,24 @@ If WIDTH (the numerical prefix), use that text width when filling." (fill-prefix (if (string= (cdar marks) "") "" (concat (cdar marks) " "))) + (do-fill (not long-lines)) use-hard-newlines) - (fill-region (point-min) (point-max))) + (unless do-fill + (setq do-fill (gnus-article-foldable-buffer (cdar marks)))) + ;; Note: the XEmacs version of `fill-region' inserts a newline + ;; unless the region ends with a newline. + (when do-fill + (if (not long-lines) + (fill-region (point-min) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (when (prog1 + (> (current-column) (window-width)) + (forward-line 1)) + (save-restriction + (narrow-to-region (line-beginning-position 0) (point)) + (fill-region (point-min) (point-max)))))))) (set-marker (caar marks) nil) (setq marks (cdr marks))) (when marks @@ -552,6 +569,29 @@ If WIDTH (the numerical prefix), use that text width when filling." gnus-cite-loose-attribution-alist nil gnus-cite-article nil))))) +(defun gnus-article-foldable-buffer (prefix) + (let ((do-fill nil) + columns) + (goto-char (point-min)) + (while (not (eobp)) + (unless (> (length prefix) (- (point-max) (point))) + (forward-char (length prefix))) + (skip-chars-forward " \t") + (unless (eolp) + (let ((elem (assq (current-column) columns))) + (unless elem + (setq elem (cons (current-column) 0)) + (push elem columns)) + (setcdr elem (1+ (cdr elem))))) + (end-of-line) + (when (> (current-column) (window-width)) + (setq do-fill t)) + (forward-line 1)) + (and do-fill + ;; We know know that there are long lines here, but does this look + ;; like code? Check for ragged edges on the left. + (< (length columns) 3)))) + (defun gnus-article-hide-citation (&optional arg force) "Toggle hiding of all cited text except attribution lines. See the documentation for `gnus-article-highlight-citation'. @@ -560,67 +600,66 @@ always hide." (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-set-format 'cited-opened-text-button t) (gnus-set-format 'cited-closed-text-button t) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - marks - (inhibit-point-motion-hooks t) - (props (nconc (list 'article-type 'cite) - gnus-hidden-properties)) - (point (point-min)) - found beg end start) - (while (setq point - (text-property-any point (point-max) - 'gnus-callback - 'gnus-article-toggle-cited-text)) - (setq found t) - (goto-char point) - (gnus-article-toggle-cited-text - (get-text-property point 'gnus-data) arg) - (forward-line 1) - (setq point (point))) - (unless found - (setq marks (gnus-dissect-cited-text)) - (while marks - (setq beg nil - end nil) - (while (and marks (string= (cdar marks) "")) - (setq marks (cdr marks))) - (when marks - (setq beg (caar marks))) - (while (and marks (not (string= (cdar marks) ""))) - (setq marks (cdr marks))) - (when marks + (with-current-buffer gnus-article-buffer + (let ((buffer-read-only nil) + marks + (inhibit-point-motion-hooks t) + (props (nconc (list 'article-type 'cite) + gnus-hidden-properties)) + (point (point-min)) + found beg end start) + (while (setq point + (text-property-any point (point-max) + 'gnus-callback + 'gnus-article-toggle-cited-text)) + (setq found t) + (goto-char point) + (gnus-article-toggle-cited-text + (get-text-property point 'gnus-data) arg) + (forward-line 1) + (setq point (point))) + (unless found + (setq marks (gnus-dissect-cited-text)) + (while marks + (setq beg nil + end nil) + (while (and marks (string= (cdar marks) "")) + (setq marks (cdr marks))) + (when marks + (setq beg (caar marks))) + (while (and marks (not (string= (cdar marks) ""))) + (setq marks (cdr marks))) + (when marks (setq end (caar marks))) - ;; Skip past lines we want to leave visible. - (when (and beg end gnus-cited-lines-visible) - (goto-char beg) - (forward-line (if (consp gnus-cited-lines-visible) - (car gnus-cited-lines-visible) - gnus-cited-lines-visible)) - (if (>= (point) end) - (setq beg nil) - (setq beg (point-marker)) - (when (consp gnus-cited-lines-visible) - (goto-char end) - (forward-line (- (cdr gnus-cited-lines-visible))) - (if (<= (point) beg) - (setq beg nil) + ;; Skip past lines we want to leave visible. + (when (and beg end gnus-cited-lines-visible) + (goto-char beg) + (forward-line (if (consp gnus-cited-lines-visible) + (car gnus-cited-lines-visible) + gnus-cited-lines-visible)) + (if (>= (point) end) + (setq beg nil) + (setq beg (point-marker)) + (when (consp gnus-cited-lines-visible) + (goto-char end) + (forward-line (- (cdr gnus-cited-lines-visible))) + (if (<= (point) beg) + (setq beg nil) (setq end (point-marker)))))) - (when (and beg end) - (gnus-add-wash-type 'cite) - ;; We use markers for the end-points to facilitate later - ;; wrapping and mangling of text. - (setq beg (set-marker (make-marker) beg) - end (set-marker (make-marker) end)) - (gnus-add-text-properties-when 'article-type nil beg end props) - (goto-char beg) - (when (and gnus-cite-blank-line-after-header - (not (save-excursion (search-backward "\n\n" nil t)))) - (insert "\n")) - (put-text-property - (setq start (point-marker)) - (progn + (when (and beg end) + (gnus-add-wash-type 'cite) + ;; We use markers for the end-points to facilitate later + ;; wrapping and mangling of text. + (setq beg (set-marker (make-marker) beg) + end (set-marker (make-marker) end)) + (gnus-add-text-properties-when 'article-type nil beg end props) + (goto-char beg) + (when (and gnus-cite-blank-line-after-header + (not (save-excursion (search-backward "\n\n" nil t)))) + (insert "\n")) + (put-text-property + (setq start (point-marker)) + (progn (gnus-article-add-button (point) (progn (eval gnus-cited-closed-text-button-line-format-spec) @@ -628,8 +667,8 @@ always hide." `gnus-article-toggle-cited-text (list (cons beg end) start)) (point)) - 'article-type 'annotation) - (set-marker beg (point)))))))) + 'article-type 'annotation) + (set-marker beg (point)))))))) (defun gnus-article-toggle-cited-text (args &optional arg) "Toggle hiding the text in REGION. @@ -732,11 +771,9 @@ See also the documentation for `gnus-article-highlight-citation'." (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((article (cdr gnus-article-current))) - (unless (save-excursion - (set-buffer gnus-summary-buffer) + (unless (with-current-buffer gnus-summary-buffer (gnus-article-displayed-root-p article)) (gnus-article-hide-citation))))) @@ -1079,8 +1116,7 @@ See also the documentation for `gnus-article-highlight-citation'." (gnus-overlay-put overlay 'face face)))))) (defun gnus-cite-toggle (prefix) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-cite-parse-maybe nil t) (let ((buffer-read-only nil) (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) @@ -1248,5 +1284,4 @@ is turned on." ;; coding: iso-8859-1 ;; End: -;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a ;;; gnus-cite.el ends here diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 855a1ea0a6..0d349077a5 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -50,7 +50,7 @@ if that value is non-nil." (setq major-mode 'gnus-custom-mode mode-name "Gnus Customize") (use-local-map widget-keymap) - ;; Emacs 21 stuff: + ;; Emacs stuff: (when (and (facep 'custom-button-face) (facep 'custom-button-pressed-face)) (set (make-local-variable 'widget-button-face) @@ -865,11 +865,6 @@ This can be changed using the `\\[gnus-score-change-score-file]' command." Check the [ ] for the entries you want to apply to this score file, then edit the value to suit your taste. Don't forget to mark the checkbox, if you do all your changes will be lost. ") - (widget-create 'push-button - :action (lambda (&rest ignore) - (require 'gnus-audio) - (gnus-audio-play "Evil_Laugh.au")) - "Bhahahah!") (widget-insert "\n\n") (make-local-variable 'gnus-custom-scores) (setq gnus-custom-scores @@ -1118,5 +1113,4 @@ articles in the thread. (provide 'gnus-cus) -;; arch-tag: a37c285a-49bc-4235-8244-804536effeaf ;;; gnus-cus.el ends here diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index cd9c21f63a..130a44ce8d 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -133,8 +133,7 @@ DELAY is a string, giving the length of the time. Possible values are: (message-add-header (format "%s: %s" gnus-delay-header deadline))) (set-buffer-modified-p t) ;; If group does not exist, create it. - (let ((group (format "nndraft:%s" gnus-delay-group))) - (gnus-agent-queue-setup gnus-delay-group)) + (gnus-agent-queue-setup gnus-delay-group) (message-disassociate-draft) (nndraft-request-associate-buffer gnus-delay-group) (save-buffer 0) @@ -192,5 +191,4 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil." ;; coding: iso-8859-1 ;; End: -;; arch-tag: fb2ad634-a897-4142-a503-f5991ec2349d ;;; gnus-delay.el ends here diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 447e7d6e30..0b265d52a1 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -32,9 +32,6 @@ (require 'nnheader) (require 'nntp) (require 'nnmail) -(require 'gnus-util) - -(autoload 'parse-time-string "parse-time" nil nil) (defgroup gnus-demon nil "Demonic behavior." @@ -46,14 +43,16 @@ Each handler is a list on the form \(FUNCTION TIME IDLE) -FUNCTION is the function to be called. -TIME is the number of `gnus-demon-timestep's between each call. -If nil, never call. If t, call each `gnus-demon-timestep'. -If IDLE is t, only call if Emacs has been idle for a while. If IDLE -is a number, only call when Emacs has been idle more than this number -of `gnus-demon-timestep's. If IDLE is nil, don't care about -idleness. If IDLE is a number and TIME is nil, then call once each -time Emacs has been idle for IDLE `gnus-demon-timestep's." +FUNCTION is the function to be called. TIME is the number of +`gnus-demon-timestep's between each call. +If nil, never call. If t, call each `gnus-demon-timestep'. + +If IDLE is t, only call each time Emacs has been idle for TIME. +If IDLE is a number, only call when Emacs has been idle more than +this number of `gnus-demon-timestep's. +If IDLE is nil, don't care about idleness. +If IDLE is a number and TIME is nil, then call once each time +Emacs has been idle for IDLE `gnus-demon-timestep's." :group 'gnus-demon :type '(repeat (list function (choice :tag "Time" @@ -66,19 +65,16 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (integer :tag "steps" 1))))) (defcustom gnus-demon-timestep 60 - "*Number of seconds in each demon timestep." + "Number of seconds in each demon timestep." :group 'gnus-demon :type 'integer) ;;; Internal variables. -(defvar gnus-demon-timer nil) -(defvar gnus-demon-idle-has-been-called nil) -(defvar gnus-demon-idle-time 0) -(defvar gnus-demon-handler-state nil) -(defvar gnus-demon-last-keys nil) +(defvar gnus-demon-timers nil + "List of idle timers which are running.") (defvar gnus-inhibit-demon nil - "*If non-nil, no daemonic function will be run.") + "If non-nil, no daemonic function will be run.") ;;; Functions. @@ -92,162 +88,71 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's." (defun gnus-demon-remove-handler (function &optional no-init) "Remove the handler FUNCTION from the list of handlers." - (gnus-pull function gnus-demon-handlers) + (gnus-alist-pull function gnus-demon-handlers) (unless no-init (gnus-demon-init))) +(defun gnus-demon-idle-since () + "Return the number of seconds since when Emacs is idle." + (if (featurep 'xemacs) + (itimer-time-difference (current-time) last-command-event-time) + (float-time (or (current-idle-time) + '(0 0 0))))) + +(defun gnus-demon-run-callback (func &optional idle) + "Run FUNC if Emacs has been idle for longer than IDLE seconds." + (unless gnus-inhibit-demon + (when (or (not idle) + (<= idle (gnus-demon-idle-since))) + (with-local-quit + (ignore-errors + (funcall func)))))) + (defun gnus-demon-init () "Initialize the Gnus daemon." (interactive) (gnus-demon-cancel) - (when gnus-demon-handlers + (dolist (handler gnus-demon-handlers) ;; Set up the timer. - (setq gnus-demon-timer - (run-at-time - gnus-demon-timestep gnus-demon-timestep 'gnus-demon)) - ;; Reset control variables. - (setq gnus-demon-handler-state - (mapcar - (lambda (handler) - (list (car handler) (gnus-demon-time-to-step (nth 1 handler)) - (nth 2 handler))) - gnus-demon-handlers)) - (setq gnus-demon-idle-time 0) - (setq gnus-demon-idle-has-been-called nil))) + (let* ((func (nth 0 handler)) + (time (nth 1 handler)) + (idle (nth 2 handler)) + ;; Compute time according with timestep. + ;; If t, replace by 1 + (time (cond ((eq time t) + gnus-demon-timestep) + ((null time) nil) + (t (* time gnus-demon-timestep)))) + (timer + (cond + ;; (func number t) + ;; Call when Emacs has been idle for `time' + ((and (numberp time) (eq idle t)) + (run-with-timer time time 'gnus-demon-run-callback func time)) + ;; (func number number) + ;; Call every `time' when Emacs has been idle for `idle' + ((and (numberp time) (numberp idle)) + (run-with-timer time time 'gnus-demon-run-callback func idle)) + ;; (func nil number) + ;; Only call when Emacs has been idle for `idle' + ((and (null time) (numberp idle)) + (run-with-idle-timer (* idle gnus-demon-timestep) t + 'gnus-demon-run-callback func)) + ;; (func number nil) + ;; Call every `time' + ((and (numberp time) (null idle)) + (run-with-timer t time 'gnus-demon-run-callback func))))) + (when timer + (add-to-list 'gnus-demon-timers timer))))) (gnus-add-shutdown 'gnus-demon-cancel 'gnus) (defun gnus-demon-cancel () "Cancel any Gnus daemons." (interactive) - (when gnus-demon-timer - (nnheader-cancel-timer gnus-demon-timer)) - (setq gnus-demon-timer nil - gnus-demon-idle-has-been-called nil) - (condition-case () - (nnheader-cancel-function-timers 'gnus-demon) - (error t))) - -(defun gnus-demon-is-idle-p () - "Whether Emacs is idle or not." - ;; We do this simply by comparing the 100 most recent keystrokes - ;; with the ones we had last time. If they are the same, one might - ;; guess that Emacs is indeed idle. This only makes sense if one - ;; calls this function seldom -- like once a minute, which is what - ;; we do here. - (let ((keys (recent-keys))) - (or (equal keys gnus-demon-last-keys) - (progn - (setq gnus-demon-last-keys keys) - nil)))) - -(defun gnus-demon-time-to-step (time) - "Find out how many seconds to TIME, which is on the form \"17:43\"." - (if (not (stringp time)) - time - (let* ((now (current-time)) - ;; obtain NOW as discrete components -- make a vector for speed - (nowParts (decode-time now)) - ;; obtain THEN as discrete components - (thenParts (parse-time-string time)) - (thenHour (elt thenParts 2)) - (thenMin (elt thenParts 1)) - ;; convert time as elements into number of seconds since EPOCH. - (then (encode-time 0 - thenMin - thenHour - ;; If THEN is earlier than NOW, make it - ;; same time tomorrow. Doc for encode-time - ;; says that this is OK. - (+ (elt nowParts 3) - (if (or (< thenHour (elt nowParts 2)) - (and (= thenHour (elt nowParts 2)) - (<= thenMin (elt nowParts 1)))) - 1 0)) - (elt nowParts 4) - (elt nowParts 5) - (elt nowParts 6) - (elt nowParts 7) - (elt nowParts 8))) - ;; calculate number of seconds between NOW and THEN - (diff (+ (* 65536 (- (car then) (car now))) - (- (cadr then) (cadr now))))) - ;; return number of timesteps in the number of seconds - (round (/ diff gnus-demon-timestep))))) - -(defun gnus-demon () - "The Gnus daemon that takes care of running all Gnus handlers." - ;; Increase or reset the time Emacs has been idle. - (if (gnus-demon-is-idle-p) - (incf gnus-demon-idle-time) - (setq gnus-demon-idle-time 0) - (setq gnus-demon-idle-has-been-called nil)) - ;; Disable all daemonic stuff if we're in the minibuffer - (when (and (not (window-minibuffer-p (selected-window))) - (not gnus-inhibit-demon)) - ;; Then we go through all the handler and call those that are - ;; sufficiently ripe. - (let ((handlers gnus-demon-handler-state) - (gnus-inhibit-demon t) - ;; Try to avoid dialog boxes, e.g. by Mailcrypt. - ;; Unfortunately, Emacs 20's `message-or-box...' doesn't - ;; obey `use-dialog-box'. - use-dialog-box (last-nonmenu-event 10) - handler time idle) - (while handlers - (setq handler (pop handlers)) - (cond - ((numberp (setq time (nth 1 handler))) - ;; These handlers use a regular timeout mechanism. We decrease - ;; the timer if it hasn't reached zero yet. - (unless (zerop time) - (setcar (nthcdr 1 handler) (decf time))) - (and (zerop time) ; If the timer now is zero... - ;; Test for appropriate idleness - (progn - (setq idle (nth 2 handler)) - (cond - ((null idle) t) ; Don't care about idle. - ((numberp idle) ; Numerical idle... - (< idle gnus-demon-idle-time)) ; Idle timed out. - (t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle. - ;; So we call the handler. - (gnus-with-local-quit - (ignore-errors (funcall (car handler))) - ;; And reset the timer. - (setcar (nthcdr 1 handler) - (gnus-demon-time-to-step - (nth 1 (assq (car handler) gnus-demon-handlers))))))) - ;; These are only supposed to be called when Emacs is idle. - ((null (setq idle (nth 2 handler))) - ;; We do nothing. - ) - ((and (not (numberp idle)) - (gnus-demon-is-idle-p)) - ;; We want to call this handler each and every time that - ;; Emacs is idle. - (gnus-with-local-quit - (ignore-errors (funcall (car handler))))) - (t - ;; We want to call this handler only if Emacs has been idle - ;; for a specified number of timesteps. - (and (not (memq (car handler) gnus-demon-idle-has-been-called)) - (< idle gnus-demon-idle-time) - (gnus-demon-is-idle-p) - (gnus-with-local-quit - (ignore-errors (funcall (car handler))) - ;; Make sure the handler won't be called once more in - ;; this idle-cycle. - (push (car handler) gnus-demon-idle-has-been-called))))))))) - -(defun gnus-demon-add-nocem () - "Add daemonic NoCeM handling to Gnus." - (gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30)) - -(defun gnus-demon-scan-nocem () - "Scan NoCeM groups for NoCeM messages." - (save-window-excursion - (gnus-nocem-scan-groups))) + (dolist (timer gnus-demon-timers) + (nnheader-cancel-timer timer)) + (setq gnus-demon-timers nil)) (defun gnus-demon-add-disconnection () "Add daemonic server disconnection to Gnus." @@ -291,11 +196,9 @@ minutes, the connection is closed." (let ((win (current-window-configuration))) (unwind-protect (save-window-excursion - (save-excursion - (when (gnus-alive-p) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-get-new-news))))) + (when (gnus-alive-p) + (with-current-buffer gnus-group-buffer + (gnus-group-get-new-news)))) (set-window-configuration win)))) (defun gnus-demon-add-scan-timestamps () @@ -319,5 +222,4 @@ minutes, the connection is closed." (provide 'gnus-demon) -;; arch-tag: 8dd5cd3d-6ae4-46b4-9b15-f5fca09fd392 ;;; gnus-demon.el ends here diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el index 103f98d69d..5a9184a44a 100644 --- a/lisp/gnus/gnus-diary.el +++ b/lisp/gnus/gnus-diary.el @@ -368,11 +368,11 @@ If ARG (or prefix) is non-nil, force prompting for all fields." header ": "))) (setq value (if (listp (nth 1 head)) - (completing-read prompt (cons '("*" nil) (nth 1 head)) - nil t value - gnus-diary-header-value-history) + (gnus-completing-read prompt (cons "*" (mapcar 'car (nth 1 head))) + t value + 'gnus-diary-header-value-history) (read-string prompt value - gnus-diary-header-value-history)))) + 'gnus-diary-header-value-history)))) (setq ask nil) (setq invalid nil) (condition-case () @@ -401,5 +401,4 @@ If ARG (or prefix) is non-nil, force prompting for all fields." (provide 'gnus-diary) -;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b ;;; gnus-diary.el ends here diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index 2efb050eb1..951e3683dc 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -39,6 +39,9 @@ ;;; Code: +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' (require 'dired) (autoload 'mml-attach-file "mml") (autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'? @@ -55,17 +58,12 @@ (autoload 'message-buffers "message") (autoload 'gnus-print-buffer "gnus-sum") -(defvar gnus-dired-mode nil - "Minor mode for intersections of MIME mail composition and dired.") - -(defvar gnus-dired-mode-map nil) - -(unless gnus-dired-mode-map - (setq gnus-dired-mode-map (make-sparse-keymap)) - - (define-key gnus-dired-mode-map "\C-c\C-m\C-a" 'gnus-dired-attach) - (define-key gnus-dired-mode-map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) - (define-key gnus-dired-mode-map "\C-c\C-m\C-p" 'gnus-dired-print)) +(defvar gnus-dired-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-m\C-a" 'gnus-dired-attach) + (define-key map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) + (define-key map "\C-c\C-m\C-p" 'gnus-dired-print) + map)) ;; FIXME: Make it customizable, change the default to `mail-user-agent' when ;; this file is renamed (e.g. to `dired-mime.el'). @@ -89,19 +87,19 @@ See `mail-user-agent' for more information." gnus-user-agent) (function :tag "Other"))) -(defun gnus-dired-mode (&optional arg) +(eval-when-compile + (when (featurep 'xemacs) + (defvar gnus-dired-mode-hook) + (defvar gnus-dired-mode-on-hook) + (defvar gnus-dired-mode-off-hook))) + +(define-minor-mode gnus-dired-mode "Minor mode for intersections of gnus and dired. \\{gnus-dired-mode-map}" - (interactive "P") - (when (eq major-mode 'dired-mode) - (set (make-local-variable 'gnus-dired-mode) - (if (null arg) (not gnus-dired-mode) - (> (prefix-numeric-value arg) 0))) - (when gnus-dired-mode - (add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map) - (save-current-buffer - (run-hooks 'gnus-dired-mode-hook))))) + :keymap gnus-dired-mode-map + (unless (derived-mode-p 'dired-mode) + (setq gnus-dired-mode nil))) ;;;###autoload (defun turn-on-gnus-dired-mode () @@ -124,6 +122,8 @@ See `mail-user-agent' for more information." (push (buffer-name buffer) buffers)))) (nreverse buffers)))) +(autoload 'gnus-completing-read "gnus-util") + ;; Method to attach files to a mail composition. (defun gnus-dired-attach (files-to-attach) "Attach dired's marked files to a gnus message composition. @@ -135,7 +135,9 @@ filenames." (mapcar ;; don't attach directories (lambda (f) (if (file-directory-p f) nil f)) - (nreverse (dired-map-over-marks (dired-get-filename) nil)))))) + (nreverse + (let ((arg nil)) ;; Silence XEmacs 21.5 when compiling. + (dired-map-over-marks (dired-get-filename) arg))))))) (let ((destination nil) (files-str nil) (bufs nil)) @@ -154,12 +156,8 @@ filenames." (setq destination (if (= (length bufs) 1) (get-buffer (car bufs)) - (completing-read "Attach to which mail composition buffer: " - (mapcar - (lambda (b) - (cons b (get-buffer b))) - bufs) - nil t))) + (gnus-completing-read "Attach to which mail composition buffer" + bufs t))) ;; setup a new mail composition buffer (let ((mail-user-agent gnus-dired-mail-mode) ;; A workaround to prevent Gnus from displaying the Gnus @@ -206,7 +204,7 @@ If ARG is non-nil, open it in a new buffer." (setq method (cdr (assoc 'viewer (car (mailcap-mime-info mime-type - 'all + 'all 'no-decode))))))) (let ((view-command (mm-mailcap-command method file-name nil))) (message "viewing via %s" view-command) @@ -263,5 +261,4 @@ file to save in." (provide 'gnus-dired) -;; arch-tag: 44737731-e445-4638-a31e-713c7590ec76 ;;; gnus-dired.el ends here diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 1c1d5bdfcb..c13018f1d4 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -32,23 +32,21 @@ (require 'nndraft) (require 'gnus-agent) (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' ;;; Draft minor mode -(defvar gnus-draft-mode nil - "Minor mode for providing a draft summary buffers.") - -(defvar gnus-draft-mode-map nil) - -(unless gnus-draft-mode-map - (setq gnus-draft-mode-map (make-sparse-keymap)) - - (gnus-define-keys gnus-draft-mode-map - "Dt" gnus-draft-toggle-sending - "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' - "De" gnus-draft-edit-message - "Ds" gnus-draft-send-message - "DS" gnus-draft-send-all-messages)) +(defvar gnus-draft-mode-map + (let ((map (make-sparse-keymap))) + (gnus-define-keys map + "Dt" gnus-draft-toggle-sending + "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' + "De" gnus-draft-edit-message + "Ds" gnus-draft-send-message + "DS" gnus-draft-send-all-messages) + map)) (defun gnus-draft-make-menu-bar () (unless (boundp 'gnus-draft-menu) @@ -61,20 +59,17 @@ ["Send all messages" gnus-draft-send-all-messages t] ["Delete draft" gnus-summary-delete-article t])))) -(defun gnus-draft-mode (&optional arg) +(define-minor-mode gnus-draft-mode "Minor mode for providing a draft summary buffers. \\{gnus-draft-mode-map}" - (interactive "P") - (when (eq major-mode 'gnus-summary-mode) - (when (set (make-local-variable 'gnus-draft-mode) - (if (null arg) (not gnus-draft-mode) - (> (prefix-numeric-value arg) 0))) - ;; Set up the menu. - (when (gnus-visual-p 'draft-menu 'menu) - (gnus-draft-make-menu-bar)) - (add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map) - (gnus-run-hooks 'gnus-draft-mode-hook)))) + :lighter " Draft" :keymap gnus-draft-mode-map + (cond + ((not (derived-mode-p 'gnus-summary-mode)) (setq gnus-draft-mode nil)) + (gnus-draft-mode + ;; Set up the menu. + (when (gnus-visual-p 'draft-menu 'menu) + (gnus-draft-make-menu-bar))))) ;;; Commands @@ -315,6 +310,8 @@ Obeys the standard process/prefix convention." (while buffs (set-buffer (setq buff (pop buffs))) (if (and buffer-file-name + (equal (file-remote-p file) + (file-remote-p buffer-file-name)) (string-equal (file-truename buffer-file-name) (file-truename file)) (buffer-modified-p)) @@ -330,5 +327,4 @@ Obeys the standard process/prefix convention." (provide 'gnus-draft) -;; arch-tag: 3d92af58-8c97-4a5c-9db4-a98e85198022 ;;; gnus-draft.el ends here diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index 662414a6a4..6b90d6bfac 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -159,5 +159,4 @@ seen in the same session." (provide 'gnus-dup) -;; arch-tag: 903e94db-7b00-4d19-83ee-cf34a81fa5fb ;;; gnus-dup.el ends here diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index a7ec2dd947..3a5dca6b50 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -130,5 +130,4 @@ The optional LAYOUT overrides the `edit-form' window layout." (provide 'gnus-eform) -;; arch-tag: ef50678c-2c28-49ef-affc-e53b3b2c0bf6 ;;; gnus-eform.el ends here diff --git a/lisp/gnus/gnus-ems.el b/lisp/gnus/gnus-ems.el index 6448818615..6425d094ba 100644 --- a/lisp/gnus/gnus-ems.el +++ b/lisp/gnus/gnus-ems.el @@ -162,102 +162,6 @@ (autoload 'gnus-alive-p "gnus-util") (autoload 'mm-disable-multibyte "mm-util") -(defun gnus-x-splash () - "Show a splash screen using a pixmap in the current buffer." - (interactive) - (unless window-system - (error "`gnus-x-splash' requires running on the window system")) - (switch-to-buffer (gnus-get-buffer-create (if (or (gnus-alive-p) - (interactive-p)) - "*gnus-x-splash*" - gnus-group-buffer))) - (let ((inhibit-read-only t) - (file (nnheader-find-etc-directory "images/gnus/x-splash" t)) - pixmap fcw fch width height fringes sbars left yoffset top ls) - (erase-buffer) - (sit-for 0) ;; Necessary for measuring the window size correctly. - (when (and file - (ignore-errors - (let ((coding-system-for-read 'raw-text)) - (with-temp-buffer - (mm-disable-multibyte) - (insert-file-contents file) - (goto-char (point-min)) - (setq pixmap (read (current-buffer))))))) - (setq fcw (float (frame-char-width)) - fch (float (frame-char-height)) - width (/ (car pixmap) fcw) - height (/ (cadr pixmap) fch) - fringes (if (fboundp 'window-fringes) - (eval '(window-fringes)) - '(10 11 nil)) - sbars (frame-parameter nil 'vertical-scroll-bars)) - (cond ((eq sbars 'right) - (setq sbars - (cons 0 (/ (or (frame-parameter nil 'scroll-bar-width) 14) - fcw)))) - (sbars - (setq sbars - (cons (/ (or (frame-parameter nil 'scroll-bar-width) 14) - fcw) - 0))) - (t - (setq sbars '(0 . 0)))) - (setq left (- (* (round (/ (1- (/ (+ (window-width) - (car sbars) (cdr sbars) - (/ (+ (or (car fringes) 0) - (or (cadr fringes) 0)) - fcw)) - width)) - 2)) - width) - (car sbars) - (/ (or (car fringes) 0) fcw)) - yoffset (cadr (window-edges)) - top (max 0 (- (* (max (if (and (boundp 'tool-bar-mode) - tool-bar-mode - (not (featurep 'gtk)) - (eq (frame-first-window) - (selected-window))) - 1 0) - (round (/ (1- (/ (+ (1- (window-height)) - (* 2 yoffset)) - height)) - 2))) - height) - yoffset)) - ls (/ (or line-spacing 0) fch) - height (max 0 (- height ls))) - (cond ((>= (- top ls) 1) - (insert - (propertize - " " - 'display `(space :width 0 :ascent 100)) - "\n" - (propertize - " " - 'display `(space :width 0 :height ,(- top ls 1) :ascent 100)) - "\n")) - ((> (- top ls) 0) - (insert - (propertize - " " - 'display `(space :width 0 :height ,(- top ls) :ascent 100)) - "\n"))) - (if (and (> width 0) (> left 0)) - (insert (propertize - " " - 'display `(space :width ,left :height ,height :ascent 0))) - (setq width (+ width left))) - (when (> width 0) - (insert (propertize - " " - 'display `(space :width ,width :height ,height :ascent 0) - 'face `(gnus-splash :stipple ,pixmap)))) - (goto-char (if (<= (- top ls) 0) (1- (point)) (point-min))) - (redraw-frame (selected-frame)) - (sit-for 0)))) - ;;; Image functions. (defun gnus-image-type-available-p (type) @@ -272,7 +176,8 @@ (when face (setq props (plist-put props :foreground (face-foreground face))) (setq props (plist-put props :background (face-background face)))) - (apply 'create-image file type data-p props))) + (ignore-errors + (apply 'create-image file type data-p props)))) (defun gnus-put-image (glyph &optional string category) (let ((point (point))) @@ -305,7 +210,53 @@ (setq start end end nil)))))) +(eval-and-compile + ;; XEmacs does not have window-inside-pixel-edges + (defalias 'gnus-window-inside-pixel-edges + (if (fboundp 'window-inside-pixel-edges) + 'window-inside-pixel-edges + 'window-pixel-edges)) + + (if (fboundp 'set-process-plist) + (progn + (defalias 'gnus-set-process-plist 'set-process-plist) + (defalias 'gnus-process-plist 'process-plist) + (defalias 'gnus-process-get 'process-get) + (defalias 'gnus-process-put 'process-put)) + (defun gnus-set-process-plist (process plist) + "Replace the plist of PROCESS with PLIST. Returns PLIST." + (put 'gnus-process-plist-internal process plist)) + + (defun gnus-process-plist (process) + "Return the plist of PROCESS." + ;; This form works but can't prevent the plist data from + ;; growing infinitely. + ;;(get 'gnus-process-plist-internal process) + (let* ((plist (symbol-plist 'gnus-process-plist-internal)) + (tem (memq process plist))) + (prog1 + (cadr tem) + ;; Remove it from the plist data. + (when tem + (if (eq plist tem) + (progn + (setcar plist (caddr plist)) + (setcdr plist (or (cdddr plist) '(nil)))) + (setcdr (nthcdr (- (length plist) (length tem) 1) plist) + (cddr tem))))))) + + (defun gnus-process-get (process propname) + "Return the value of PROCESS' PROPNAME property. +This is the last value stored with `(gnus-process-put PROCESS PROPNAME VALUE)'." + (plist-get (gnus-process-plist process) propname)) + + (defun gnus-process-put (process propname value) + "Change PROCESS' PROPNAME property to VALUE. +It can be retrieved with `(gnus-process-get PROCESS PROPNAME)'." + (gnus-set-process-plist process + (plist-put (gnus-process-plist process) + propname value))))) + (provide 'gnus-ems) -;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb ;;; gnus-ems.el ends here diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 22fd0637b9..920293d6f5 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -24,7 +24,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -290,5 +290,4 @@ colors of the displayed X-Faces." (provide 'gnus-fun) -;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1 ;;; gnus-fun.el ends here diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el new file mode 100644 index 0000000000..e46460e726 --- /dev/null +++ b/lisp/gnus/gnus-gravatar.el @@ -0,0 +1,138 @@ +;;; gnus-gravatar.el --- Gnus Gravatar support + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Julien Danjou <[email protected]> +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(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 nil + "How big should gravatars be displayed. +If nil, default to `gravatar-size'." + :type 'integer + :version "24.1" + :group 'gnus-gravatar) + +(defcustom gnus-gravatar-properties '(:ascent center :relief 1) + "List of image properties applied to Gravatar images." + :type 'list + :version "24.1" + :group 'gnus-gravatar) + +(defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly + "Regexp matching posters whose avatar shouldn't be shown automatically." + :type '(choice regexp (const nil)) + :version "24.1" + :group 'gnus-gravatar) + +(defun gnus-gravatar-transform-address (header category &optional force) + (gnus-with-article-headers + (let* ((mail-extr-disable-voodoo t) + (mail-extr-ignore-realname-equals-mailbox-name nil) + (addresses (mail-extract-address-components + (or (mail-fetch-field header) "") t)) + (gravatar-size (or gnus-gravatar-size gravatar-size)) + name) + (dolist (address addresses) + (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 + (or (cadr address) "")) + (and name + (string-match gnus-gravatar-too-ugly + name)))))) + (ignore-errors + (gravatar-retrieve + (cadr address) + 'gnus-gravatar-insert + (list header address category)))))))) + +(defun gnus-gravatar-insert (gravatar header address category) + "Insert GRAVATAR for ADDRESS in HEADER in current article buffer. +Set image category to CATEGORY." + (unless (eq gravatar 'error) + (gnus-with-article-headers + ;; The buffer can be gone at this time + (when (buffer-live-p (current-buffer)) + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (let ((real-name (car address)) + (mail-address (cadr address))) + (when (if real-name + (re-search-forward + (concat (gnus-replace-in-string + (regexp-quote real-name) "[\t ]+" "[\t\n ]+") + "\\|" + (regexp-quote mail-address)) + nil t) + (search-forward mail-address nil t)) + (goto-char (1- (match-beginning 0))) + ;; If we're on the " quoting the name, go backward + (when (looking-at "[\"<]") + (goto-char (1- (point)))) + ;; Do not do anything if there's already a gravatar. This can + ;; happens if the buffer has been regenerated in the mean time, for + ;; 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 ((point (point))) + (unless (featurep 'xemacs) + (setq gravatar (append gravatar gnus-gravatar-properties))) + (gnus-put-image gravatar nil category) + (put-text-property point (point) 'gnus-gravatar address) + (gnus-add-wash-type category) + (gnus-add-image category gravatar))))))))) + +;;;###autoload +(defun gnus-treat-from-gravatar (&optional force) + "Display gravatar in the From header. +If gravatar is already displayed, remove it." + (interactive (list t)) ;; When type `W D g' + (gnus-with-article-buffer + (if (memq 'from-gravatar gnus-article-wash-types) + (gnus-delete-images 'from-gravatar) + (gnus-gravatar-transform-address "from" 'from-gravatar force)))) + +;;;###autoload +(defun gnus-treat-mail-gravatar (&optional force) + "Display gravatars in the Cc and To headers. +If gravatars are already displayed, remove them." + (interactive (list t)) ;; When type `W D h' + (gnus-with-article-buffer + (if (memq 'mail-gravatar gnus-article-wash-types) + (gnus-delete-images 'mail-gravatar) + (gnus-gravatar-transform-address "cc" 'mail-gravatar force) + (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) + +(provide 'gnus-gravatar) + +;;; gnus-gravatar.el ends here diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 6849f6e103..2044d5714b 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1,7 +1,8 @@ ;;; gnus-group.el --- group mode commands for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software +;; Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <[email protected]> ;; Keywords: news @@ -25,7 +26,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -55,17 +56,7 @@ (autoload 'gnus-agent-total-fetched-for "gnus-agent") (autoload 'gnus-cache-total-fetched-for "gnus-cache") -(defcustom gnus-group-archive-directory - "/[email protected]:/pub/emacs/ding-list/" - "*The address of the (ding) archives." - :group 'gnus-group-foreign - :type 'directory) - -(defcustom gnus-group-recent-archive-directory - "/[email protected]:/pub/emacs/ding-list-recent/" - "*The address of the most recent (ding) articles." - :group 'gnus-group-foreign - :type 'directory) +(autoload 'gnus-group-make-nnir-group "nnir") (defcustom gnus-no-groups-message "No Gnus is good news" "*Message displayed by Gnus when no groups are available." @@ -129,10 +120,11 @@ If nil, only list groups that have unread articles." :type 'boolean) (defcustom gnus-group-default-list-level gnus-level-subscribed - "*Default listing level. + "Default listing level. Ignored if `gnus-group-use-permanent-levels' is non-nil." :group 'gnus-group-listing - :type 'integer) + :type '(choice (integer :tag "Level") + (function :tag "Function returning level"))) (defcustom gnus-group-list-inactive-groups t "*If non-nil, inactive groups will be listed." @@ -169,7 +161,7 @@ list." (function-item gnus-group-sort-by-rank) (function :tag "other" nil)))) -(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n" +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)\n" "*Format of group lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -292,14 +284,10 @@ If you want to modify the group buffer, you can use this hook." :group 'gnus-exit :type 'hook) -(defcustom gnus-group-update-hook '(gnus-group-highlight-line) - "Hook called when a group line is changed. -The hook will not be called if `gnus-visual' is nil. - -The default function `gnus-group-highlight-line' will -highlight the line according to the `gnus-group-highlight' -variable." +(defcustom gnus-group-update-hook nil + "Hook called when a group line is changed." :group 'gnus-group-visual + :version "24.1" :type 'hook) (defcustom gnus-useful-groups @@ -428,7 +416,6 @@ group: The name of the group. unread: The number of unread articles in the group. method: The select method used. mailp: Whether it's a mail group or not. -newsp: Whether it's a news group or not level: The level of the group. score: The score of the group. ticked: The number of ticked articles." @@ -509,7 +496,10 @@ simple manner.") (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) (t number)) ?s) (?R gnus-tmp-number-of-read ?s) - (?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d) + (?U (if (gnus-active gnus-tmp-group) + (gnus-number-of-unseen-articles-in-group gnus-tmp-group) + "*") + ?s) (?t gnus-tmp-number-total ?d) (?y gnus-tmp-number-of-unread ?s) (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) @@ -562,8 +552,6 @@ simple manner.") (defvar gnus-group-list-mode nil) -(defvar gnus-group-icon-cache nil) - (defvar gnus-group-listed-groups nil) (defvar gnus-group-list-option nil) @@ -659,8 +647,6 @@ simple manner.") "d" gnus-group-make-directory-group "h" gnus-group-make-help-group "u" gnus-group-make-useful-group - "a" gnus-group-make-archive-group - "k" gnus-group-make-kiboze-group "l" gnus-group-nnimap-edit-acl "m" gnus-group-make-group "E" gnus-group-edit-group @@ -671,22 +657,16 @@ simple manner.") "D" gnus-group-enter-directory "f" gnus-group-make-doc-group "w" gnus-group-make-web-group + "G" gnus-group-make-nnir-group "M" gnus-group-read-ephemeral-group "r" gnus-group-rename-group "R" gnus-group-make-rss-group "c" gnus-group-customize "z" gnus-group-compact-group - "x" gnus-group-nnimap-expunge + "x" gnus-group-expunge-group "\177" gnus-group-delete-group [delete] gnus-group-delete-group) -(gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map) - "b" gnus-group-brew-soup - "w" gnus-soup-save-areas - "s" gnus-soup-send-replies - "p" gnus-soup-pack-packet - "r" nnsoup-pack-replies) - (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) "s" gnus-group-sort-groups "a" gnus-group-sort-groups-by-alphabet @@ -762,10 +742,7 @@ simple manner.") "e" gnus-score-edit-all-score) (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) - "c" gnus-group-fetch-charter - "C" gnus-group-fetch-control "d" gnus-group-describe-group - "f" gnus-group-fetch-faq "v" gnus-version) (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) @@ -784,7 +761,6 @@ simple manner.") (symbol-value 'gnus-topic-mode))) (defun gnus-group-make-menu-bar () - (gnus-turn-off-edit-menu 'group) (unless (boundp 'gnus-group-reading-menu) (easy-menu-define @@ -831,15 +807,6 @@ simple manner.") ["Describe" gnus-group-describe-group :active (gnus-group-group-name) ,@(if (featurep 'xemacs) nil '(:help "Display description of the current group"))] - ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] - ["Fetch charter" gnus-group-fetch-charter - :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Display the charter of the current group"))] - ["Fetch control message" gnus-group-fetch-control - :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Display the archived control message for the current group"))] ;; Actually one should check, if any of the marked groups gives t for ;; (gnus-check-backend-function 'request-expire-articles ...) ["Expire articles" gnus-group-expire-articles @@ -935,10 +902,9 @@ simple manner.") ["Make a foreign group..." gnus-group-make-group t] ["Add a directory group..." gnus-group-make-directory-group t] ["Add the help group" gnus-group-make-help-group t] - ["Add the archive group" gnus-group-make-archive-group t] ["Make a doc group..." gnus-group-make-doc-group t] ["Make a web group..." gnus-group-make-web-group t] - ["Make a kiboze group..." gnus-group-make-kiboze-group t] + ["Make a search group..." gnus-group-make-nnir-group t] ["Make a virtual group..." gnus-group-make-empty-virtual t] ["Add a group to a virtual..." gnus-group-add-to-virtual t] ["Make an ephemeral group..." gnus-group-read-ephemeral-group t] @@ -972,13 +938,6 @@ simple manner.") (easy-menu-define gnus-group-misc-menu gnus-group-mode-map "" `("Gnus" - ("SOUP" - ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] - ["Send replies" gnus-soup-send-replies - (fboundp 'gnus-soup-pack-packet)] - ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] - ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] - ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) ["Send a mail" gnus-group-mail t] ["Send a message (mail or news)" gnus-group-post-news t] ["Create a local message" gnus-group-news t] @@ -996,7 +955,6 @@ simple manner.") ["Browse foreign server..." gnus-group-browse-foreign-server t] ["Enter server buffer" gnus-group-enter-server-mode t] ["Expire all expirable articles" gnus-group-expire-all-groups t] - ["Generate any kiboze groups" nnkiboze-generate-groups t] ["Gnus version" gnus-version t] ["Save .newsrc files" gnus-group-save-newsrc t] ["Suspend Gnus" gnus-group-suspend t] @@ -1128,8 +1086,7 @@ When FORCE, rebuild the tool bar." (when (and (not (featurep 'xemacs)) (boundp 'tool-bar-mode) tool-bar-mode - ;; The Gnus 5.10.6 code checked (default-value 'tool-bar-mode). - ;; Why? --rsteib + (display-graphic-p) (or (not gnus-group-tool-bar-map) force)) (let* ((load-path (gmm-image-load-path-for-library "gnus" @@ -1208,6 +1165,12 @@ The following commands are available: (mouse-set-point e) (gnus-group-read-group nil)) +(defun gnus-group-default-list-level () + "Return the real value for `gnus-group-default-list-level'." + (if (functionp gnus-group-default-list-level) + (funcall gnus-group-default-list-level) + gnus-group-default-list-level)) + ;; Look at LEVEL and find out what the level is really supposed to be. ;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens ;; will depend on whether `gnus-group-use-permanent-levels' is used. @@ -1217,20 +1180,18 @@ The following commands are available: (or (setq gnus-group-use-permanent-levels (or level (if (numberp gnus-group-use-permanent-levels) gnus-group-use-permanent-levels - (or gnus-group-default-list-level + (or (gnus-group-default-list-level) gnus-level-subscribed)))) - gnus-group-default-list-level gnus-level-subscribed)) + (gnus-group-default-list-level) gnus-level-subscribed)) (number-or-nil level) (t - (or level gnus-group-default-list-level gnus-level-subscribed)))) + (or level (gnus-group-default-list-level) gnus-level-subscribed)))) (defun gnus-group-setup-buffer () (set-buffer (gnus-get-buffer-create gnus-group-buffer)) (unless (eq major-mode 'gnus-group-mode) - (gnus-group-mode) - (when gnus-carpal - (gnus-carpal-setup-buffer 'group)))) + (gnus-group-mode))) (defun gnus-group-name-charset (method group) (if (null method) @@ -1271,7 +1232,7 @@ Also see the `gnus-group-use-permanent-levels' variable." (prefix-numeric-value current-prefix-arg) (or (gnus-group-default-level nil t) - gnus-group-default-list-level + (gnus-group-default-list-level) gnus-level-subscribed)))) (unless level (setq level (car gnus-group-list-mode) @@ -1290,7 +1251,7 @@ Also see the `gnus-group-use-permanent-levels' variable." (zerop number)) (zerop (buffer-size))) ;; No groups in the buffer. - (gnus-message 5 gnus-no-groups-message)) + (gnus-message 5 "%s" gnus-no-groups-message)) ;; We have some groups displayed. (goto-char (point-max)) (when (or (not gnus-group-goto-next-group-function) @@ -1534,7 +1495,7 @@ if it is a string, only list groups matching REGEXP." (and (not (featurep 'xemacs)) (boundp 'tool-bar-mode) tool-bar-mode - ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs 21 might + ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might ;; be confusing, so maybe we shouldn't call it by default. (fboundp 'force-window-update)) "Force updating the group buffer tool bar." @@ -1592,7 +1553,7 @@ if it is a string, only list groups matching REGEXP." ?m ? )) (gnus-tmp-moderated-string (if (eq gnus-tmp-moderated ?m) "(m)" "")) - (gnus-tmp-group-icon "==&&==") + (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group)) (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) (gnus-tmp-news-method (or (car gnus-tmp-method) "")) (gnus-tmp-news-method-string @@ -1639,138 +1600,148 @@ if it is a string, only list groups matching REGEXP." 'gnus-tool-bar-update)) (forward-line -1) (when (inline (gnus-visual-p 'group-highlight 'highlight)) - (gnus-run-hooks 'gnus-group-update-hook)) - (forward-line) - ;; Allow XEmacs to remove front-sticky text properties. - (gnus-group-remove-excess-properties))) - -(defun gnus-group-highlight-line () - "Highlight the current line according to `gnus-group-highlight'." - (let* ((list gnus-group-highlight) - (p (point)) - (end (point-at-eol)) - ;; now find out where the line starts and leave point there. - (beg (progn (beginning-of-line) (point))) - (group (gnus-group-group-name)) - (entry (gnus-group-entry group)) - (unread (if (numberp (car entry)) (car entry) 0)) - (active (gnus-active group)) - (total (if active (1+ (- (cdr active) (car active))) 0)) - (info (nth 2 entry)) - (method (inline (gnus-server-get-method group (gnus-info-method info)))) - (marked (gnus-info-marks info)) - (mailp (apply 'append - (mapcar - (lambda (x) - (memq x (assoc (symbol-name - (car (or method gnus-select-method))) - gnus-valid-select-methods))) - '(mail post-mail)))) - (level (or (gnus-info-level info) gnus-level-killed)) - (score (or (gnus-info-score info) 0)) - (ticked (gnus-range-length (cdr (assq 'tick marked)))) - (group-age (gnus-group-timestamp-delta group)) - (inhibit-read-only t)) - ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465 - ;; ====================================================================== - ;; From: Richard Stallman - ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...]) - ;; Cc: [email protected] - ;; Date: Sat, 27 Oct 2007 19:41:20 -0400 - ;; Message-ID: <[email protected]> - ;; - ;; [...] - ;; The kludge is that the alist elements contain expressions that refer - ;; to local variables with short names. Perhaps write your own tiny - ;; evaluator that handles just `and', `or', and numeric comparisons - ;; and just a few specific variables. - ;; ====================================================================== - ;; - ;; Similar for other evaluated variables. Grep for risky-local-variable - ;; to find them! -- rsteib - ;; - ;; Eval the cars of the lists until we find a match. - (while (and list - (not (eval (caar list)))) - (setq list (cdr list))) - (let ((face (cdar list))) - (unless (eq face (get-text-property beg 'face)) - (gnus-put-text-property-excluding-characters-with-faces - beg end 'face - (setq face (if (boundp face) (symbol-value face) face))) - (gnus-extent-start-open beg))) - (goto-char p))) + (gnus-group-highlight-line gnus-tmp-group beg end)) + (gnus-run-hooks 'gnus-group-update-hook) + (forward-line))) + +(defun gnus-group-update-eval-form (group list) + "Eval `car' of each element of LIST, and return the first that return t. +Some value are bound so the form can use them." + (when list + (let* ((entry (gnus-group-entry group)) + (unread (if (numberp (car entry)) (car entry) 0)) + (active (gnus-active group)) + (total (if active (1+ (- (cdr active) (car active))) 0)) + (info (nth 2 entry)) + (method (inline (gnus-server-get-method group (gnus-info-method info)))) + (marked (gnus-info-marks info)) + (mailp (apply 'append + (mapcar + (lambda (x) + (memq x (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + '(mail post-mail)))) + (level (or (gnus-info-level info) gnus-level-killed)) + (score (or (gnus-info-score info) 0)) + (ticked (gnus-range-length (cdr (assq 'tick marked)))) + (group-age (gnus-group-timestamp-delta group))) + ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465 + ;; ====================================================================== + ;; From: Richard Stallman + ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...]) + ;; Cc: [email protected] + ;; Date: Sat, 27 Oct 2007 19:41:20 -0400 + ;; Message-ID: <[email protected]> + ;; + ;; [...] + ;; The kludge is that the alist elements contain expressions that refer + ;; to local variables with short names. Perhaps write your own tiny + ;; evaluator that handles just `and', `or', and numeric comparisons + ;; and just a few specific variables. + ;; ====================================================================== + ;; + ;; Similar for other evaluated variables. Grep for risky-local-variable + ;; to find them! -- rsteib + ;; + ;; Eval the cars of the lists until we find a match. + (while (and list + (not (eval (caar list)))) + (setq list (cdr list))) + list))) + +(defun gnus-group-highlight-line (group beg end) + "Highlight the current line according to `gnus-group-highlight'. +GROUP is current group, and the line to highlight starts at BEG +and ends at END." + (let ((face (cdar (gnus-group-update-eval-form + group + gnus-group-highlight)))) + (unless (eq face (get-text-property beg 'face)) + (let ((inhibit-read-only t)) + (gnus-put-text-property-excluding-characters-with-faces + beg end 'face + (if (boundp face) (symbol-value face) face))) + (gnus-extent-start-open beg)))) + +(defun gnus-group-get-icon (group) + "Return an icon for GROUP according to `gnus-group-icon-list'." + (if gnus-group-icon-list + (let ((image-path + (cdar (gnus-group-update-eval-form group gnus-group-icon-list)))) + (if image-path + (propertize " " + 'display + (append + (gnus-create-image (expand-file-name image-path)) + '(:ascent center))) + " ")) + " ")) (defun gnus-group-update-group (group &optional visible-only) "Update all lines where GROUP appear. If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't already." - ;; Can't use `save-excursion' here, so we do it manually. - (let ((buf (current-buffer)) - mark) - (set-buffer gnus-group-buffer) - (setq mark (point-marker)) - ;; The buffer may be narrowed. - (save-restriction - (widen) - (let ((ident (gnus-intern-safe group gnus-active-hashtb)) - (loc (point-min)) - found buffer-read-only) - ;; Enter the current status into the dribble buffer. - (let ((entry (gnus-group-entry group))) - (when (and entry - (not (gnus-ephemeral-group-p group))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string (nth 2 entry)) - ")")))) - ;; Find all group instances. If topics are in use, each group - ;; may be listed in more than once. - (while (setq loc (text-property-any - loc (point-max) 'gnus-group ident)) - (setq found t) - (goto-char loc) - (let ((gnus-group-indentation (gnus-group-group-indentation))) - (gnus-delete-line) - (gnus-group-insert-group-line-info group) - (save-excursion - (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook))) - (setq loc (1+ loc))) - (unless (or found visible-only) - ;; No such line in the buffer, find out where it's supposed to - ;; go, and insert it there (or at the end of the buffer). - (if gnus-goto-missing-group-function - (funcall gnus-goto-missing-group-function group) - (let ((entry (cddr (gnus-group-entry group)))) - (while (and entry (car entry) - (not - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe - (caar entry) gnus-active-hashtb))))) - (setq entry (cdr entry))) - (or entry (goto-char (point-max))))) - ;; Finally insert the line. - (let ((gnus-group-indentation (gnus-group-group-indentation))) - (gnus-group-insert-group-line-info group) - (save-excursion - (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook)))) - (when gnus-group-update-group-function - (funcall gnus-group-update-group-function group)) - (gnus-group-set-mode-line))) - (goto-char mark) - (set-marker mark nil) - (set-buffer buf))) + (with-current-buffer gnus-group-buffer + (save-excursion + ;; The buffer may be narrowed. + (save-restriction + (widen) + (let ((ident (gnus-intern-safe group gnus-active-hashtb)) + (loc (point-min)) + found buffer-read-only) + ;; Enter the current status into the dribble buffer. + (let ((entry (gnus-group-entry group))) + (when (and entry + (not (gnus-ephemeral-group-p group))) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (nth 2 entry)) + ")")))) + ;; Find all group instances. If topics are in use, each group + ;; may be listed in more than once. + (while (setq loc (text-property-any + loc (point-max) 'gnus-group ident)) + (setq found t) + (goto-char loc) + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-delete-line) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (gnus-run-hooks 'gnus-group-update-group-hook))) + (setq loc (1+ loc))) + (unless (or found visible-only) + ;; No such line in the buffer, find out where it's supposed to + ;; go, and insert it there (or at the end of the buffer). + (if gnus-goto-missing-group-function + (funcall gnus-goto-missing-group-function group) + (let ((entry (cddr (gnus-group-entry group)))) + (while (and entry (car entry) + (not + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe + (caar entry) + gnus-active-hashtb))))) + (setq entry (cdr entry))) + (or entry (goto-char (point-max))))) + ;; Finally insert the line. + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (gnus-run-hooks 'gnus-group-update-group-hook)))) + (when gnus-group-update-group-function + (funcall gnus-group-update-group-function group)) + (gnus-group-set-mode-line)))))) (defun gnus-group-set-mode-line () "Update the mode line in the group buffer." (when (memq 'group gnus-updated-mode-lines) ;; Yes, we want to keep this mode line updated. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (let* ((gformat (or gnus-group-mode-line-format-spec (gnus-set-format 'group-mode))) (gnus-tmp-news-server (cadr gnus-select-method)) @@ -1783,8 +1754,7 @@ already." (and gnus-dribble-buffer (buffer-name gnus-dribble-buffer) (buffer-modified-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (not (zerop (buffer-size)))))) (mode-string (eval gformat))) ;; Say whether the dribble buffer has been modified. @@ -1921,7 +1891,7 @@ If FIRST-TOO, the current line is also eligible as a target." (unless no-advance (gnus-group-next-group 1)) (decf n)) - (gnus-summary-position-point) + (gnus-group-position-point) n)) (defun gnus-group-unmark-group (n) @@ -2195,41 +2165,49 @@ be permanent." group))) (goto-char start))))) -(defun gnus-group-completing-read (prompt &optional collection predicate - require-match initial-input hist def - &rest args) +(defun gnus-group-completing-read (&optional prompt collection + require-match initial-input hist + def) "Read a group name with completion. Non-ASCII group names are allowed. The arguments are the same as `completing-read' except that COLLECTION and HIST default to `gnus-active-hashtb' and `gnus-group-history' -respectively if they are omitted." - (let (group) - (mapatoms (lambda (symbol) - (setq group (symbol-name symbol)) - (set (intern (if (string-match "[^\000-\177]" group) - (gnus-group-decoded-name group) - group) - collection) - group)) - (prog1 - (or collection - (setq collection (or gnus-active-hashtb [0]))) - (setq collection (gnus-make-hashtable (length collection))))) - (setq group (apply 'completing-read prompt collection predicate - require-match initial-input - (or hist 'gnus-group-history) - def args)) - (or (prog1 - (symbol-value (intern-soft group collection)) - (setq collection nil)) - (mm-encode-coding-string group (gnus-group-name-charset nil group))))) +respectively if they are omitted. Regards COLLECTION as a hash table +if it is not a list." + (or collection (setq collection gnus-active-hashtb)) + (let (choices group) + (if (listp collection) + (dolist (symbol collection) + (setq group (symbol-name symbol)) + (push (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group) + choices)) + (mapatoms (lambda (symbol) + (setq group (symbol-name symbol)) + (push (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group) + choices)) + collection)) + (setq group (gnus-completing-read (or prompt "Group") (nreverse choices) + require-match initial-input + (or hist 'gnus-group-history) + def)) + (unless (if (listp collection) + (member group (mapcar 'symbol-name collection)) + (symbol-value (intern-soft group collection))) + (setq group + (mm-encode-coding-string + group (gnus-group-name-charset nil group)))) + (gnus-replace-in-string group "\n" ""))) ;;;###autoload (defun gnus-fetch-group (group &optional articles) "Start Gnus if necessary and enter GROUP. If ARTICLES, display those articles. Returns whether the fetching was successful or not." - (interactive (list (gnus-group-completing-read "Group name: " - nil nil nil + (interactive (list (gnus-group-completing-read nil + nil nil (gnus-group-name-at-point)))) (unless (gnus-alive-p) (gnus-no-server)) @@ -2248,8 +2226,6 @@ Returns whether the fetching was successful or not." (other-frame 1)))) (gnus-fetch-group group)) -(defvar gnus-ephemeral-group-server 0) - (defcustom gnus-large-ephemeral-newsgroup 200 "The number of articles which indicates a large ephemeral newsgroup. Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups. @@ -2291,8 +2267,8 @@ Return the name of the group if selection was successful." (interactive (list ;; (gnus-read-group "Group name: ") - (gnus-group-completing-read "Group: ") - (gnus-read-method "From method: "))) + (gnus-group-completing-read) + (gnus-read-method "From method"))) ;; Transform the select method into a unique server. (when (stringp method) (setq method (gnus-server-to-method method))) @@ -2358,13 +2334,13 @@ specified by `gnus-gmane-group-download-format'." ;; See <http://gmane.org/export.php> for more information. (interactive (list - (gnus-group-completing-read "Gmane group: ") + (gnus-group-completing-read "Gmane group") (read-number "Start article number: ") (read-number "How many articles: "))) (unless range (setq range 500)) (when (< range 1) (error "Invalid range: %s" range)) - (let ((tmpfile (make-temp-file + (let ((tmpfile (mm-make-temp-file (format "%s.start-%s.range-%s." group start range))) (gnus-thread-sort-functions '(gnus-thread-sort-by-number))) (with-temp-file tmpfile @@ -2392,7 +2368,7 @@ Valid input formats include: ;; prompt the user to decide: "View via `browse-url' or in Gnus? " ;; (`gnus-read-ephemeral-gmane-group-url') (interactive - (list (gnus-group-completing-read "Gmane URL: "))) + (list (gnus-group-completing-read "Gmane URL"))) (let (group start range) (cond ;; URLs providing `group', `start' and `range': @@ -2445,9 +2421,17 @@ the bug number, and browsing the URL must return mbox output." (cdr (assoc 'emacs gnus-bug-group-download-format-alist)))) (when (stringp number) (setq number (string-to-number number))) - (let ((tmpfile (make-temp-file "gnus-temp-group-"))) + (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) (with-temp-file tmpfile (url-insert-file-contents (format mbox-url number)) + (goto-char (point-min)) + ;; Add the debbugs address so that we can respond to reports easily. + (while (re-search-forward "^To: " nil t) + (end-of-line) + (insert (format ", %s@%s" number + (gnus-replace-in-string + (gnus-replace-in-string mbox-url "^http://" "") + "/.*$" "")))) (write-region (point-min) (point-max) tmpfile) (gnus-group-read-ephemeral-group "gnus-read-ephemeral-bug" @@ -2478,13 +2462,13 @@ If PROMPT (the prefix) is a number, use the prompt specified in `gnus-group-jump-to-group-prompt'." (interactive (list (gnus-group-completing-read - "Group: " nil nil (gnus-read-active-file-p) - (if current-prefix-arg - (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt)) - (or (and (stringp gnus-group-jump-to-group-prompt) - gnus-group-jump-to-group-prompt) - (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt)))) - (and (stringp p) p))))))) + nil nil (gnus-read-active-file-p) + (if current-prefix-arg + (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt)) + (or (and (stringp gnus-group-jump-to-group-prompt) + gnus-group-jump-to-group-prompt) + (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt)))) + (and (stringp p) p))))))) (when (equal group "") (error "Empty group name")) @@ -2675,7 +2659,7 @@ If EXCLUDE-GROUP, do not go to that group." (defun gnus-group-make-group-simple (&optional group) "Add a new newsgroup. The user will be prompted for GROUP." - (interactive (list (gnus-group-completing-read "Group: "))) + (interactive (list (gnus-group-completing-read))) (gnus-group-make-group (gnus-group-real-name group) (gnus-group-server group) nil nil t)) @@ -2684,11 +2668,14 @@ The user will be prompted for GROUP." "Add a new newsgroup. The user will be prompted for a NAME, for a select METHOD, and an ADDRESS. NAME should be a human-readable string (i.e., not be encoded -even if it contains non-ASCII characters) unless ENCODED is non-nil." +even if it contains non-ASCII characters) unless ENCODED is non-nil. + +If the backend supports it, the group will also be created on the +server." (interactive (list (gnus-read-group "Group name: ") - (gnus-read-method "From method: "))) + (gnus-read-method "From method"))) (when (stringp method) (setq method (or (gnus-server-to-method method) method))) @@ -2748,6 +2735,15 @@ even if it contains non-ASCII characters) unless ENCODED is non-nil." (lambda (group) (gnus-group-delete-group group nil t)))))) +(defun gnus-group-delete-articles (group) + "Delete all articles in the current group." + (interactive (list (gnus-group-group-name))) + (let ((articles (gnus-uncompress-range (gnus-active group)))) + (when (gnus-yes-or-no-p + (format "Do you really want to delete these %d articles forever? " + (length articles))) + (gnus-request-expire-articles articles group 'force)))) + (defun gnus-group-delete-group (group &optional force no-prompt) "Delete the current group. Only meaningful with editable groups. If FORCE (the prefix) is non-nil, all the articles in the group will @@ -2934,8 +2930,9 @@ and NEW-NAME will be prompted for." (defun gnus-group-make-useful-group (group method) "Create one of the groups described in `gnus-useful-groups'." (interactive - (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups - nil t) + (let ((entry (assoc (gnus-completing-read "Create group" + (mapcar 'car gnus-useful-groups) + t) gnus-useful-groups))) (list (cadr entry) ;; Don't use `caddr' here since macros within the `interactive' @@ -3027,11 +3024,11 @@ If SOLID (the prefix), create a solid group." (symbol-name (caar nnweb-type-definition)))) (type (gnus-string-or - (completing-read - (format "Search engine type (default %s): " default-type) - (mapcar (lambda (elem) (list (symbol-name (car elem)))) + (gnus-completing-read + "Search engine type" + (mapcar (lambda (elem) (symbol-name (car elem))) nnweb-type-definition) - nil t nil 'gnus-group-web-type-history) + t nil 'gnus-group-web-type-history) default-type)) (search (read-string @@ -3044,7 +3041,7 @@ If SOLID (the prefix), create a solid group." (nnweb-ephemeral-p t)))) (if solid (progn - (gnus-pull 'nnweb-ephemeral-p method) + (gnus-alist-pull 'nnweb-ephemeral-p method) (gnus-group-make-group group method)) (gnus-group-read-ephemeral-group group method t @@ -3094,58 +3091,6 @@ If there is, use Gnus to create an nnrss group" (nnrss-save-server-data nil)) (error "No feeds found for %s" url)))) -(defvar nnwarchive-type-definition) -(defvar gnus-group-warchive-type-history nil) -(defvar gnus-group-warchive-login-history nil) -(defvar gnus-group-warchive-address-history nil) - -(defun gnus-group-make-warchive-group () - "Create a nnwarchive group." - (interactive) - (require 'nnwarchive) - (let* ((group (gnus-read-group "Group name: ")) - (default-type (or (car gnus-group-warchive-type-history) - (symbol-name (caar nnwarchive-type-definition)))) - (type - (gnus-string-or - (completing-read - (format "Warchive type (default %s): " default-type) - (mapcar (lambda (elem) (list (symbol-name (car elem)))) - nnwarchive-type-definition) - nil t nil 'gnus-group-warchive-type-history) - default-type)) - (address (read-string "Warchive address: " - nil 'gnus-group-warchive-address-history)) - (default-login (or (car gnus-group-warchive-login-history) - user-mail-address)) - (login - (gnus-string-or - (read-string - (format "Warchive login (default %s): " user-mail-address) - default-login 'gnus-group-warchive-login-history) - user-mail-address)) - (method - `(nnwarchive ,address - (nnwarchive-type ,(intern type)) - (nnwarchive-login ,login)))) - (gnus-group-make-group group method))) - -(defun gnus-group-make-archive-group (&optional all) - "Create the (ding) Gnus archive group of the most recent articles. -Given a prefix, create a full group." - (interactive "P") - (let ((group (gnus-group-prefixed-name - (if all "ding.archives" "ding.recent") '(nndir "")))) - (when (gnus-group-entry group) - (error "Archive group already exists")) - (gnus-group-make-group - (gnus-group-real-name group) - (list 'nndir (if all "hpc" "edu") - (list 'nndir-directory - (if all gnus-group-archive-directory - gnus-group-recent-archive-directory)))) - (gnus-group-add-parameter group (cons 'to-address "[email protected]")))) - (defun gnus-group-make-directory-group (dir) "Create an nndir group. The user will be prompted for a directory. The contents of this @@ -3170,47 +3115,12 @@ mail messages or news articles in files that have numeric names." (gnus-group-real-name group) (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) -(defvar nnkiboze-score-file) -(declare-function nnkiboze-score-file "nnkiboze" (group)) - -(defun gnus-group-make-kiboze-group (group address scores) - "Create an nnkiboze group. -The user will be prompted for a name, a regexp to match groups, and -score file entries for articles to include in the group." - (interactive - (list - (read-string "nnkiboze group name: ") - (read-string "Source groups (regexp): ") - (let ((headers (mapcar 'list - '("subject" "from" "number" "date" "message-id" - "references" "chars" "lines" "xref" - "followup" "all" "body" "head"))) - scores header regexp regexps) - (while (not (equal "" (setq header (completing-read - "Match on header: " headers nil t)))) - (setq regexps nil) - (while (not (equal "" (setq regexp (read-string - (format "Match on %s (regexp): " - header))))) - (push (list regexp nil nil 'r) regexps)) - (push (cons header regexps) scores)) - scores))) - (gnus-group-make-group group "nnkiboze" address) - (let* ((nnkiboze-current-group group) - (score-file (car (nnkiboze-score-file ""))) - (score-dir (file-name-directory score-file))) - (unless (file-exists-p score-dir) - (make-directory score-dir)) - (with-temp-file score-file - (let (emacs-lisp-mode-hook) - (gnus-pp scores))))) - (defun gnus-group-add-to-virtual (n vgroup) "Add the current group to a virtual group." (interactive (list current-prefix-arg - (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t - "nnvirtual:"))) + (gnus-group-completing-read "Add to virtual group" + nil t "nnvirtual:"))) (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual) (error "%s is not an nnvirtual group" vgroup)) (gnus-close-group vgroup) @@ -3255,21 +3165,17 @@ score file entries for articles to include in the group." 'summary 'group))) (error "Couldn't enter %s" dir)))) -(autoload 'nnimap-expunge "nnimap") -(autoload 'nnimap-acl-get "nnimap") -(autoload 'nnimap-acl-edit "nnimap") - -(defun gnus-group-nnimap-expunge (group) +(defun gnus-group-expunge-group (group) "Expunge deleted articles in current nnimap GROUP." (interactive (list (gnus-group-group-name))) - (let ((mailbox (gnus-group-real-name group)) method) - (unless group - (error "No group on current line")) - (unless (gnus-get-info group) - (error "Killed group; can't be edited")) - (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group)))) - (error "%s is not an nnimap group" group)) - (nnimap-expunge mailbox (cadr method)))) + (let ((method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-expunge-group (car method))) + (error "%s does not support expunging" (car method)) + (gnus-request-expunge-group group method)))) + +(autoload 'nnimap-acl-get "nnimap") +(autoload 'nnimap-acl-edit "nnimap") (defun gnus-group-nnimap-edit-acl (group) "Edit the Access Control List of current nnimap GROUP." @@ -3785,7 +3691,7 @@ If given numerical prefix, toggle the N next groups." Killed newsgroups are subscribed. If SILENT, don't try to update the group line." (interactive (list (gnus-group-completing-read - "Group: " nil nil (gnus-read-active-file-p)))) + nil nil (gnus-read-active-file-p)))) (let ((newsrc (gnus-group-entry group))) (cond ((string-match "^[ \t]*$" group) @@ -3885,6 +3791,8 @@ of groups killed." gnus-list-of-killed-groups)) (gnus-group-change-level (if entry entry group) gnus-level-killed (if entry nil level)) + (when (numberp (gnus-group-unread group)) + (gnus-request-update-group-status group 'unsubscribe)) (message "Killed group %s" (gnus-group-decoded-name group))) ;; If there are lots and lots of groups to be killed, we use ;; this thing instead. @@ -3907,7 +3815,9 @@ of groups killed." (setq gnus-zombie-list (delete group gnus-zombie-list)))) ;; There may be more than one instance displayed. (while (gnus-group-goto-group group) - (gnus-delete-line))) + (gnus-delete-line)) + (when (numberp (gnus-group-unread group)) + (gnus-request-update-group-status group 'unsubscribe))) (gnus-make-hashtable-from-newsrc-alist)) (gnus-group-position-point) @@ -3935,6 +3845,7 @@ yanked) a list of yanked groups is returned." (and prev (gnus-group-entry prev)) t) (gnus-group-insert-group-line-info group) + (gnus-request-update-group-status group 'subscribe) (gnus-undo-register `(when (gnus-group-goto-group ,group) (gnus-group-kill-group 1)))) @@ -4067,30 +3978,12 @@ re-scanning. If ARG is non-nil and not a number, this will force (unless gnus-slave (gnus-master-read-slave-newsrc)) - ;; We might read in new NoCeM messages here. - (when (and gnus-use-nocem - (or (and (numberp gnus-use-nocem) - (numberp arg) - (>= arg gnus-use-nocem)) - (not arg))) - (gnus-nocem-scan-groups)) - ;; If ARG is not a number, then we read the active file. - (when (and arg (not (numberp arg))) - (let ((gnus-read-active-file t)) - (gnus-read-active-file)) - (setq arg nil) - - ;; If the user wants it, we scan for new groups. - (when (eq gnus-check-new-newsgroups 'always) - (gnus-find-new-newsgroups))) - - (setq arg (gnus-group-default-level arg t)) - (if (and gnus-read-active-file (not arg)) - (progn - (gnus-read-active-file) - (gnus-get-unread-articles arg)) - (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) - (gnus-get-unread-articles arg))) + (gnus-get-unread-articles arg) + + ;; If the user wants it, we scan for new groups. + (when (eq gnus-check-new-newsgroups 'always) + (gnus-find-new-newsgroups)) + (gnus-check-reasonable-setup) (gnus-run-hooks 'gnus-after-getting-new-news-hook) (gnus-group-list-groups (and (numberp arg) @@ -4105,7 +3998,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (let* ((groups (gnus-group-process-prefix n)) (ret (if (numberp n) (- n (length groups)) 0)) (beg (unless n - (point))) + (point-marker))) group method (gnus-inhibit-demon t) ;; Binding this variable will inhibit multiple fetchings @@ -4136,91 +4029,9 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (goto-char beg)) (when gnus-goto-next-group-when-activating (gnus-group-next-unread-group 1 t)) - (gnus-summary-position-point) + (gnus-group-position-point) ret)) -(defun gnus-group-fetch-faq (group &optional faq-dir) - "Fetch the FAQ for the current group. -If given a prefix argument, prompt for the FAQ dir -to use." - (interactive - (list - (gnus-group-group-name) - (when current-prefix-arg - (completing-read - "FAQ dir: " (and (listp gnus-group-faq-directory) - (mapcar #'list - gnus-group-faq-directory)))))) - (unless group - (error "No group name given")) - (let ((dirs (or faq-dir gnus-group-faq-directory)) - dir found file) - (unless (listp dirs) - (setq dirs (list dirs))) - (while (and (not found) - (setq dir (pop dirs))) - (let ((name (gnus-group-real-name group))) - (setq file (expand-file-name name dir))) - (if (not (file-exists-p file)) - (gnus-message 1 "No such file: %s" file) - (let ((enable-local-variables nil)) - (find-file file) - (setq found t)))))) - -(defun gnus-group-fetch-charter (group) - "Fetch the charter for the current group. -If given a prefix argument, prompt for a group." - (interactive - (list (or (when current-prefix-arg - (gnus-group-completing-read "Group: ")) - (gnus-group-group-name) - gnus-newsgroup-name))) - (unless group - (error "No group name given")) - (require 'mm-url) - (condition-case nil (require 'url-http) (error nil)) - (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group))) - url hierarchy) - (when (string-match "\\(^[^\\.]+\\)\\..*" name) - (setq hierarchy (match-string 1 name)) - (if (and (setq url (cdr (assoc hierarchy gnus-group-charter-alist))) - (if (fboundp 'url-http-file-exists-p) - (url-http-file-exists-p (eval url)) - t)) - (browse-url (eval url)) - (setq url (concat "http://" hierarchy - ".news-admin.org/charters/" name)) - (if (and (fboundp 'url-http-file-exists-p) - (url-http-file-exists-p url)) - (browse-url url) - (gnus-group-fetch-control group)))))) - -(defun gnus-group-fetch-control (group) - "Fetch the archived control messages for the current group. -If given a prefix argument, prompt for a group." - (interactive - (list (or (when current-prefix-arg - (gnus-group-completing-read "Group: ")) - (gnus-group-group-name) - gnus-newsgroup-name))) - (unless group - (error "No group name given")) - (let ((name (gnus-group-real-name group)) - hierarchy) - (when (string-match "\\(^[^\\.]+\\)\\..*" name) - (setq hierarchy (match-string 1 name)) - (if gnus-group-fetch-control-use-browse-url - (browse-url (concat "ftp://ftp.isc.org/usenet/control/" - hierarchy "/" name ".gz")) - (let ((enable-local-variables nil)) - (gnus-group-read-ephemeral-group - group - `(nndoc ,group (nndoc-address - ,(find-file-noselect - (concat "/[email protected]:/usenet/control/" - hierarchy "/" name ".gz"))) - (nndoc-article-type mbox)) t nil nil)))))) - (defun gnus-group-describe-group (force &optional group) "Display a description of the current newsgroup." (interactive (list current-prefix-arg (gnus-group-group-name))) @@ -4238,7 +4049,7 @@ If given a prefix argument, prompt for a group." (gnus-gethash mname gnus-description-hashtb)) (setq desc (gnus-group-get-description group)) (gnus-read-descriptions-file method)) - (gnus-message 1 + (gnus-message 1 "%s" (or desc (gnus-gethash group gnus-description-hashtb) "No description available"))))) @@ -4390,8 +4201,14 @@ groups. With 2 C-u's, use most complete method possible to query the server for new groups, and subscribe the new groups as zombies." (interactive "p") - (gnus-find-new-newsgroups (or arg 1)) - (gnus-group-list-groups)) + (let ((new-groups (gnus-find-new-newsgroups (or arg 1))) + current-group) + (gnus-group-list-groups) + (setq current-group (gnus-group-group-name)) + (dolist (group new-groups) + (gnus-group-jump-to-group group)) + (when current-group + (gnus-group-jump-to-group current-group)))) (defun gnus-group-edit-global-kill (&optional article group) "Edit the global kill file. @@ -4399,11 +4216,9 @@ If GROUP, edit that local kill file instead." (interactive "P") (setq gnus-current-kill-article article) (gnus-kill-file-edit-file group) - (gnus-message - 6 - (substitute-command-keys - (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)" - (if group "local" "global"))))) + (gnus-message 6 "Editing a %s kill file (Type %s to exit)" + (if group "local" "global") + (substitute-command-keys "\\[gnus-kill-file-exit]"))) (defun gnus-group-edit-local-kill (article group) "Edit a local kill file." @@ -4480,8 +4295,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (gnus-run-hooks 'gnus-exit-gnus-hook) (gnus-configure-windows 'group t) (when (and (gnus-buffer-live-p gnus-dribble-buffer) - (not (zerop (save-excursion - (set-buffer gnus-dribble-buffer) + (not (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-dribble-enter ";;; Gnus was exited on purpose without saving the .newsrc files.")) @@ -4495,7 +4309,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (defun gnus-group-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 7 (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help"))) + (gnus-message 7 "%s" (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help"))) (defun gnus-group-browse-foreign-server (method) "Browse a foreign news server. @@ -4504,18 +4318,19 @@ If called interactively, this function will ask for a select method If not, METHOD should be a list where the first element is the method and the second element is the address." (interactive - (list (let ((how (completing-read - "Which back end: " - (append gnus-valid-select-methods gnus-server-alist) - nil t (cons "nntp" 0) 'gnus-method-history))) + (list (let ((how (gnus-completing-read + "Which back end" + (mapcar 'car (append gnus-valid-select-methods + gnus-server-alist)) + t (cons "nntp" 0) 'gnus-method-history))) ;; We either got a back end name or a virtual server name. ;; If the first, we also need an address. (if (assoc how gnus-valid-select-methods) (list (intern how) ;; Suggested by [email protected]. - (completing-read - "Address: " - (mapcar 'list gnus-secondary-servers))) + (gnus-completing-read + "Address" + gnus-secondary-servers)) ;; We got a server name. how)))) (gnus-browse-foreign-server method)) @@ -4542,13 +4357,11 @@ and the second element is the address." (setcar (nthcdr (1- total) info) part-info))) (unless entry ;; This is a new group, so we just create it. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq method (gnus-info-method info)) (when (gnus-server-equal method "native") (setq method nil)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (if method ;; It's a foreign group... (gnus-group-make-group @@ -4612,8 +4425,7 @@ and the second element is the address." "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." (let ((buffer (gnus-summary-buffer-name group))) (if (gnus-buffer-live-p buffer) - (save-excursion - (set-buffer (get-buffer buffer)) + (with-current-buffer (get-buffer buffer) (gnus-summary-add-mark article mark)) (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) (list article))))) @@ -4813,5 +4625,4 @@ Compacting group %s... (this may take a long time)" (provide 'gnus-group) -;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6 ;;; gnus-group.el ends here diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el new file mode 100644 index 0000000000..deeb3565bc --- /dev/null +++ b/lisp/gnus/gnus-html.el @@ -0,0 +1,530 @@ +;;; gnus-html.el --- Render HTML in a buffer. + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <[email protected]> +;; Keywords: html, web + +;; 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 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The idea is to provide a simple, fast and pretty minimal way to +;; render HTML (including links and images) in a buffer, based on an +;; external HTML renderer (i.e., w3m). + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus-art) +(eval-when-compile (require 'mm-decode)) + +(require 'mm-url) +(require 'url) +(require 'url-cache) +(require 'xml) +(require 'browse-url) +(eval-and-compile (unless (featurep 'xemacs) (require 'help-fns))) + +(defcustom gnus-html-image-cache-ttl (days-to-time 7) + "Time used to determine if we should use images from the cache." + :version "24.1" + :group 'gnus-art + :type 'integer) + +(defcustom gnus-html-image-automatic-caching t + "Whether automatically cache retrieve images." + :version "24.1" + :group 'gnus-art + :type 'boolean) + +(defcustom gnus-html-frame-width 70 + "What width to use when rendering HTML." + :version "24.1" + :group 'gnus-art + :type 'integer) + +(defcustom gnus-max-image-proportion 0.9 + "How big pictures displayed are in relation to the window they're in. +A value of 0.7 means that they are allowed to take up 70% of the +width and height of the window. If they are larger than this, +and Emacs supports it, then the images will be rescaled down to +fit these criteria." + :version "24.1" + :group 'gnus-art + :type 'float) + +(defvar gnus-html-image-map + (let ((map (make-sparse-keymap))) + (define-key map "u" 'gnus-article-copy-string) + (define-key map "i" 'gnus-html-insert-image) + (define-key map "v" 'gnus-html-browse-url) + map)) + +(defvar gnus-html-displayed-image-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'gnus-html-show-alt-text) + (define-key map "i" 'gnus-html-browse-image) + (define-key map "\r" 'gnus-html-browse-url) + (define-key map "u" 'gnus-article-copy-string) + (define-key map [tab] 'widget-forward) + map)) + +(eval-and-compile + (defalias 'gnus-html-encode-url-chars + (if (fboundp 'browse-url-url-encode-chars) + 'browse-url-url-encode-chars + (lambda (text chars) + "URL-encode the chars in TEXT that match CHARS. +CHARS is a regexp-like character alternative (e.g., \"[)$]\")." + (let ((encoded-text (copy-sequence text)) + (s 0)) + (while (setq s (string-match chars encoded-text s)) + (setq encoded-text + (replace-match (format "%%%x" + (string-to-char + (match-string 0 encoded-text))) + t t encoded-text) + s (1+ s))) + encoded-text))))) + +(defun gnus-html-encode-url (url) + "Encode URL." + (gnus-html-encode-url-chars url "[)$ ]")) + +(defun gnus-html-cache-expired (url ttl) + "Check if URL is cached for more than TTL." + (cond (url-standalone-mode + (not (file-exists-p (url-cache-create-filename url)))) + (t (let ((cache-time (url-is-cached url))) + (if cache-time + (time-less-p + (time-add + cache-time + ttl) + (current-time)) + t))))) + +;;;###autoload +(defun gnus-article-html (&optional handle) + (let ((article-buffer (current-buffer))) + (unless handle + (setq handle (mm-dissect-buffer t))) + (save-restriction + (narrow-to-region (point) (point)) + (save-excursion + (mm-with-part handle + (let* ((coding-system-for-read 'utf-8) + (coding-system-for-write 'utf-8) + (default-process-coding-system + (cons coding-system-for-read coding-system-for-write)) + (charset (mail-content-type-get (mm-handle-type handle) + 'charset))) + (when (and charset + (setq charset (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii))) + (insert (prog1 + (mm-decode-coding-string (buffer-string) charset) + (erase-buffer) + (mm-enable-multibyte)))) + (call-process-region (point-min) (point-max) + "w3m" + nil article-buffer nil + "-halfdump" + "-no-cookie" + "-I" "UTF-8" + "-O" "UTF-8" + "-o" "ext_halfdump=1" + "-o" "display_ins_del=2" + "-o" "pre_conv=1" + "-t" (format "%s" tab-width) + "-cols" (format "%s" gnus-html-frame-width) + "-o" "display_image=on" + "-T" "text/html")))) + (gnus-html-wash-tags)))) + +(defvar gnus-article-mouse-face) + +(defun gnus-html-pre-wash () + (goto-char (point-min)) + (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (while (re-search-forward "<a name[^\n>]+>" nil t) + (replace-match "" t t))) + +(defun gnus-html-wash-images () + "Run through current buffer and replace img tags by images." + (let (tag parameters string start end images url alt-text + inhibit-images blocked-images) + (if (buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + (setq inhibit-images gnus-inhibit-images + blocked-images (gnus-blocked-images))) + (setq inhibit-images gnus-inhibit-images + blocked-images (gnus-blocked-images))) + (goto-char (point-min)) + ;; Search for all the images first. + (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t) + (setq parameters (match-string 1) + start (match-beginning 0)) + (delete-region start (point)) + (when (search-forward "</img_alt>" (line-end-position) t) + (delete-region (match-beginning 0) (match-end 0))) + (setq end (point)) + (when (string-match "src=\"\\([^\"]+\\)" parameters) + (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) + (setq url (gnus-html-encode-url (match-string 1 parameters)) + alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" + parameters) + (xml-substitute-special (match-string 2 parameters)))) + (gnus-add-text-properties + start end + (list 'image-url url + 'image-displayer `(lambda (url start end) + (gnus-html-display-image url start end + ,alt-text)) + 'gnus-image (list url start end alt-text))) + (widget-convert-button + 'url-link start (point) + :help-echo alt-text + :keymap gnus-html-image-map + url) + (if (string-match "\\`cid:" url) + ;; URLs with cid: have their content stashed in other + ;; parts of the MIME structure, so just insert them + ;; immediately. + (let* ((handle (mm-get-content-id (substring url (match-end 0)))) + (image (when (and handle + (not inhibit-images)) + (gnus-create-image + (mm-with-part handle (buffer-string)) + nil t)))) + (if image + (progn + (gnus-put-image + (gnus-rescale-image + image (gnus-html-maximum-image-size)) + (gnus-string-or (prog1 + (buffer-substring start end) + (delete-region start end)) + "*") + 'cid) + (gnus-add-image 'cid image)) + (widget-convert-button + 'link start end + :action 'gnus-html-insert-image + :help-echo url + :keymap gnus-html-image-map + :button-keymap gnus-html-image-map))) + ;; Normal, external URL. + (if (or inhibit-images + (gnus-html-image-url-blocked-p url blocked-images)) + (widget-convert-button + 'link start end + :action 'gnus-html-insert-image + :help-echo url + :keymap gnus-html-image-map + :button-keymap gnus-html-image-map) + ;; Non-blocked url + (let ((width + (when (string-match "width=\"?\\([0-9]+\\)" parameters) + (string-to-number (match-string 1 parameters)))) + (height + (when (string-match "height=\"?\\([0-9]+\\)" parameters) + (string-to-number (match-string 1 parameters))))) + ;; Don't fetch images that are really small. They're + ;; probably tracking pictures. + (when (and (or (null height) + (> height 4)) + (or (null width) + (> width 4))) + (gnus-html-display-image url start end alt-text))))))))) + +(defun gnus-html-display-image (url start end &optional alt-text) + "Display image at URL on text from START to END. +Use ALT-TEXT for the image string." + (or alt-text (setq alt-text "*")) + (if (string-match "\\`cid:" url) + (let ((handle (mm-get-content-id (substring url (match-end 0))))) + (when handle + (gnus-html-put-image (mm-with-part handle (buffer-string)) + url alt-text))) + (if (gnus-html-cache-expired url gnus-html-image-cache-ttl) + ;; We don't have it, so schedule it for fetching + ;; asynchronously. + (gnus-html-schedule-image-fetching + (current-buffer) + (list url alt-text)) + ;; It's already cached, so just insert it. + (gnus-html-put-image (gnus-html-get-image-data url) url alt-text)))) + +(defun gnus-html-wash-tags () + (let (tag parameters string start end images url) + (gnus-html-pre-wash) + (gnus-html-wash-images) + + (goto-char (point-min)) + ;; Then do the other tags. + (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t) + (setq tag (match-string 1) + parameters (match-string 2) + start (match-beginning 0)) + (when (> (length parameters) 0) + (set-text-properties 0 (1- (length parameters)) nil parameters)) + (delete-region start (point)) + (when (search-forward (concat "</" tag ">") nil t) + (delete-region (match-beginning 0) (match-end 0))) + (setq end (point)) + (cond + ;; Fetch and insert a picture. + ((equal tag "img_alt")) + ;; Add a link. + ((or (equal tag "a") + (equal tag "A")) + (when (string-match "href=\"\\([^\"]+\\)" parameters) + (setq url (match-string 1 parameters)) + (gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url) + (gnus-article-add-button start end + 'browse-url (mm-url-decode-entities-string url) + url) + (let ((overlay (gnus-make-overlay start end))) + (gnus-overlay-put overlay 'evaporate t) + (gnus-overlay-put overlay 'gnus-button-url url) + (gnus-put-text-property start end 'gnus-string url) + (when gnus-article-mouse-face + (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face))))) + ;; The upper-case IMG_ALT is apparently just an artifact that + ;; should be deleted. + ((equal tag "IMG_ALT") + (delete-region start end)) + ;; w3m does not normalize the case + ((or (equal tag "b") + (equal tag "B")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold)) + ((or (equal tag "u") + (equal tag "U")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline)) + ((or (equal tag "i") + (equal tag "I")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic)) + ((or (equal tag "s") + (equal tag "S")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru)) + ((or (equal tag "ins") + (equal tag "INS")) + (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline)) + ;; Handle different UL types + ((equal tag "_SYMBOL") + (when (string-match "TYPE=\\(.+\\)" parameters) + (let ((type (string-to-number (match-string 1 parameters)))) + (delete-region start end) + (cond ((= type 33) (insert " ")) + ((= type 34) (insert " ")) + ((= type 35) (insert " ")) + ((= type 36) (insert " ")) + ((= type 37) (insert " ")) + ((= type 38) (insert " ")) + ((= type 39) (insert " ")) + ((= type 40) (insert " ")) + ((= type 42) (insert " ")) + ((= type 43) (insert " ")) + (t (insert " ")))))) + ;; Whatever. Just ignore the tag. + (t + )) + (goto-char start)) + (goto-char (point-min)) + ;; The output from -halfdump isn't totally regular, so strip + ;; off any </pre_int>s that were left over. + (while (re-search-forward "</pre_int>\\|</internal>" nil t) + (replace-match "" t t)) + (mm-url-decode-entities))) + +(defun gnus-html-insert-image (&rest args) + "Fetch and insert the image under point." + (interactive) + (apply 'gnus-html-display-image (get-text-property (point) 'gnus-image))) + +(defun gnus-html-show-alt-text () + "Show the ALT text of the image under point." + (interactive) + (message "%s" (get-text-property (point) 'gnus-alt-text))) + +(defun gnus-html-browse-image () + "Browse the image under point." + (interactive) + (browse-url (get-text-property (point) 'image-url))) + +(defun gnus-html-browse-url () + "Browse the image under point." + (interactive) + (let ((url (get-text-property (point) 'gnus-string))) + (cond + ((not url) + (message "No link under point")) + ((string-match "^mailto:" url) + (gnus-url-mailto url)) + (t + (browse-url url))))) + +(defun gnus-html-schedule-image-fetching (buffer image) + "Retrieve IMAGE, and place it into BUFFER on arrival." + (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s" + buffer image) + (let ((args (list (car image) + 'gnus-html-image-fetched + (list buffer image)))) + (when (> (length (if (featurep 'xemacs) + (cdr (split-string (function-arglist 'url-retrieve))) + (help-function-arglist 'url-retrieve))) + 4) + (setq args (nconc args (list t)))) + (ignore-errors + (push (apply #'url-retrieve args) gnus-buffers)))) + +(defun gnus-html-image-fetched (status buffer image) + "Callback function called when image has been fetched." + (unless (plist-get status :error) + (when gnus-html-image-automatic-caching + (url-store-in-cache (current-buffer))) + (when (and (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (buffer-live-p buffer)) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (gnus-html-put-image data (car image) (cadr image))))))) + (kill-buffer (current-buffer))) + +(defun gnus-html-get-image-data (url) + "Get image data for URL. +Return a string with image data." + (with-temp-buffer + (mm-disable-multibyte) + (url-cache-extract (url-cache-create-filename url)) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (buffer-substring (point) (point-max))))) + +(defun gnus-html-maximum-image-size () + "Return the maximum size of an image according to `gnus-max-image-proportion'." + (let ((edges (gnus-window-inside-pixel-edges + (get-buffer-window (current-buffer))))) + ;; (width . height) + (cons + ;; Aimed width + (truncate + (* gnus-max-image-proportion + (- (nth 2 edges) (nth 0 edges)))) + ;; Aimed height + (truncate (* gnus-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))))) + +(defun gnus-html-put-image (data url &optional alt-text) + "Put an image with DATA from URL and optional ALT-TEXT." + (when (gnus-graphic-display-p) + (let* ((start (text-property-any (point-min) (point-max) + 'image-url url)) + (end (when start + (next-single-property-change start 'image-url)))) + ;; Image found? + (when start + (let* ((image + (ignore-errors + (gnus-create-image data nil t))) + (size (and image + (if (featurep 'xemacs) + (cons (glyph-width image) (glyph-height image)) + (image-size image t))))) + (save-excursion + (goto-char start) + (let ((alt-text (or alt-text + (buffer-substring-no-properties start end))) + (inhibit-read-only t)) + (if (and image + ;; Kludge to avoid displaying 30x30 gif images, which + ;; seems to be a signal of a broken image. + (not (and (if (featurep 'xemacs) + (glyphp image) + (listp image)) + (eq (if (featurep 'xemacs) + (let ((d (cdadar + (specifier-spec-list + (glyph-image image))))) + (and (vectorp d) + (aref d 0))) + (plist-get (cdr image) :type)) + 'gif) + (= (car size) 30) + (= (cdr size) 30)))) + ;; Good image, add it! + (let ((image (gnus-rescale-image image (gnus-html-maximum-image-size)))) + (delete-region start end) + (gnus-put-image image alt-text 'external) + (widget-convert-button + 'url-link start (point) + :help-echo alt-text + :keymap gnus-html-displayed-image-map + url) + (gnus-put-text-property start (point) + 'gnus-alt-text alt-text) + (when url + (gnus-put-text-property start (point) + 'image-url url)) + (gnus-add-image 'external image) + t) + ;; Bad image, try to show something else + (when (fboundp 'find-image) + (delete-region start end) + (setq image (find-image + '((:type xpm :file "lock-broken.xpm")))) + (gnus-put-image image alt-text 'internal) + (gnus-add-image 'internal image)) + nil)))))))) + +(defun gnus-html-image-url-blocked-p (url blocked-images) + "Find out if URL is blocked by BLOCKED-IMAGES." + (let ((ret (and blocked-images + (string-match blocked-images url)))) + (if ret + (gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s" + url blocked-images) + (gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s" + url blocked-images)) + ret)) + +;;;###autoload +(defun gnus-html-prefetch-images (summary) + (when (buffer-live-p summary) + (let (inhibit-images blocked-images) + (with-current-buffer summary + (setq inhibit-images gnus-inhibit-images + blocked-images (gnus-blocked-images))) + (save-match-data + (while (re-search-forward "<img[^>]+src=[\"']\\(http[^\"']+\\)" nil t) + (let ((url (gnus-html-encode-url + (mm-url-decode-entities-string (match-string 1))))) + (unless (or inhibit-images + (gnus-html-image-url-blocked-p url blocked-images)) + (when (gnus-html-cache-expired url gnus-html-image-cache-ttl) + (gnus-html-schedule-image-fetching nil + (list url)))))))))) + +(provide 'gnus-html) + +;;; gnus-html.el ends here diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index eef1969ef6..b805167149 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -31,6 +31,7 @@ (require 'message) (require 'gnus-range) +(autoload 'gnus-run-hook-with-args "gnus-util") (autoload 'gnus-agent-expire "gnus-agent") (autoload 'gnus-agent-regenerate-group "gnus-agent") (autoload 'gnus-agent-read-servers-validate-native "gnus-agent") @@ -41,6 +42,16 @@ :group 'gnus-start :type 'hook) +(defcustom gnus-after-set-mark-hook nil + "Hook called just after marks are set in a group." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-update-mark-hook nil + "Hook called just before marks are updated in a group." + :group 'gnus-start + :type 'hook) + (defcustom gnus-server-unopen-status nil "The default status if the server is not able to open. If the server is covered by Gnus agent, the possible values are @@ -89,16 +100,13 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." ;; Stream is already opened. nil ;; Open NNTP server. - (unless gnus-nntp-service - (setq gnus-nntp-server nil)) (when confirm ;; Read server name with completion. (setq gnus-nntp-server - (completing-read "NNTP server: " - (mapcar 'list - (cons (list gnus-nntp-server) - gnus-secondary-servers)) - nil nil gnus-nntp-server))) + (gnus-completing-read "NNTP server" + (cons gnus-nntp-server + gnus-secondary-servers) + nil gnus-nntp-server))) (when (and gnus-nntp-server (stringp gnus-nntp-server) @@ -179,15 +187,17 @@ If it is down, start it up (again)." (format " on %s" (nth 1 method))))) (gnus-run-hooks 'gnus-open-server-hook) (prog1 - (condition-case () - (setq result (gnus-open-server method)) - (quit (message "Quit gnus-check-server") - nil)) + (setq result (gnus-open-server method)) (unless silent - (gnus-message 5 "Opening %s server%s...%s" (car method) - (if (equal (nth 1 method) "") "" - (format " on %s" (nth 1 method))) - (if result "done" "failed"))))))) + (gnus-message + (if result 5 3) + "Opening %s server%s...%s" (car method) + (if (equal (nth 1 method) "") "" + (format " on %s" (nth 1 method))) + (if result + "done" + (format "failed: %s" + (nnheader-get-report-string (car method)))))))))) (defun gnus-get-function (method function &optional noerror) "Return a function symbol based on METHOD and FUNCTION." @@ -225,10 +235,22 @@ If it is down, start it up (again)." ;;; Interface functions to the backends. ;;; +(defun gnus-method-denied-p (method) + (eq (nth 1 (assoc method gnus-opened-servers)) + 'denied)) + +(defvar gnus-backend-trace t) + (defun gnus-open-server (gnus-command-method) "Open a connection to GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (when gnus-backend-trace + (with-current-buffer (get-buffer-create "*gnus trace*") + (buffer-disable-undo) + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") + (format " %S\n" gnus-command-method)))) (let ((elem (assoc gnus-command-method gnus-opened-servers)) (server (gnus-method-to-server-name gnus-command-method))) ;; If this method was previously denied, we just return nil. @@ -237,54 +259,51 @@ If it is down, start it up (again)." (gnus-message 1 "Denied server %s" server) nil) ;; Open the server. - (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server)) + (let* ((open-server-function + (gnus-get-function gnus-command-method 'open-server)) (result - (condition-case err - (funcall open-server-function - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method)) - (error - (gnus-message 1 (format - "Unable to open server %s due to: %s" - server (error-message-string err))) - nil) - (quit - (gnus-message 1 "Quit trying to open server %s" server) - nil))) - open-offline) + (condition-case err + (funcall open-server-function + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)) + (error + (gnus-message 1 "Unable to open server %s due to: %s" + server (error-message-string err)) + nil) + (quit + (gnus-message 1 "Quit trying to open server %s" server) + nil))) + open-offline) ;; If this hasn't been opened before, we add it to the list. (unless elem (setq elem (list gnus-command-method nil) gnus-opened-servers (cons elem gnus-opened-servers))) ;; Set the status of this server. - (setcar (cdr elem) - (cond (result - (if (eq open-server-function #'nnagent-open-server) - ;; The agent's backend has a "special" status - 'offline - 'ok)) - ((and gnus-agent - (gnus-agent-method-p gnus-command-method)) - (cond (gnus-server-unopen-status - ;; Set the server's status to the unopen - ;; status. If that status is offline, - ;; recurse to open the agent's backend. - (setq open-offline (eq gnus-server-unopen-status 'offline)) - gnus-server-unopen-status) - ((and - (not gnus-batch-mode) - (gnus-y-or-n-p - (format - "Unable to open server %s, go offline? " - server))) - (setq open-offline t) - 'offline) - (t - ;; This agentized server was still denied - 'denied))) - (t - ;; This unagentized server must be denied - 'denied))) + (setcar + (cdr elem) + (cond (result + (if (eq open-server-function #'nnagent-open-server) + ;; The agent's backend has a "special" status + 'offline + 'ok)) + ((and gnus-agent + (gnus-agent-method-p gnus-command-method)) + (cond + (gnus-server-unopen-status + ;; Set the server's status to the unopen + ;; status. If that status is offline, + ;; recurse to open the agent's backend. + (setq open-offline (eq gnus-server-unopen-status 'offline)) + gnus-server-unopen-status) + ((not gnus-batch-mode) + (setq open-offline t) + 'offline) + (t + ;; This agentized server was still denied + 'denied))) + (t + ;; This unagentized server must be denied + 'denied))) ;; NOTE: I MUST set the server's status to offline before this ;; recursive call as this status will drive the @@ -319,6 +338,22 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method 'request-list) (nth 1 gnus-command-method))) +(defun gnus-finish-retrieve-group-infos (gnus-command-method infos data) + "Read and update infos from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'finish-retrieve-group-infos) + (nth 1 gnus-command-method) + infos data)) + +(defun gnus-retrieve-group-data-early (gnus-command-method infos) + "Start early async retrival of data from GNUS-COMMAND-METHOD." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early) + (nth 1 gnus-command-method) + infos)) + (defun gnus-request-list-newsgroups (gnus-command-method) "Request the newsgroups file from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) @@ -358,16 +393,17 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method 'request-compact) (nth 1 gnus-command-method))) -(defun gnus-request-group (group &optional dont-check gnus-command-method) +(defun gnus-request-group (group &optional dont-check gnus-command-method info) "Request GROUP. If DONT-CHECK, no information is required." (let ((gnus-command-method (or gnus-command-method (inline (gnus-find-method-for-group group))))) (when (stringp gnus-command-method) (setq gnus-command-method (inline (gnus-server-to-method gnus-command-method)))) - (funcall (inline (gnus-get-function gnus-command-method 'request-group)) + (funcall (inline (gnus-get-function gnus-command-method 'request-group)) (gnus-group-real-name group) (nth 1 gnus-command-method) - dont-check))) + dont-check + info))) (defun gnus-list-active-group (group) "Request active information on GROUP." @@ -437,6 +473,18 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (funcall (gnus-get-function gnus-command-method 'request-type) (gnus-group-real-name group) article)))) +(defun gnus-request-update-group-status (group status) + "Change the status of a group. +Valid statuses include `subscribe' and `unsubscribe'." + (let ((gnus-command-method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function + 'request-update-group-status (car gnus-command-method))) + nil + (funcall + (gnus-get-function gnus-command-method 'request-update-group-status) + (gnus-group-real-name group) status + (nth 1 gnus-command-method))))) + (defun gnus-request-set-mark (group action) "Set marks on articles in the back end." (let ((gnus-command-method (gnus-find-method-for-group group))) @@ -445,7 +493,8 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." action (funcall (gnus-get-function gnus-command-method 'request-set-mark) (gnus-group-real-name group) action - (nth 1 gnus-command-method))))) + (nth 1 gnus-command-method)) + (gnus-run-hook-with-args gnus-after-set-mark-hook group action)))) (defun gnus-request-update-mark (group article mark) "Allow the back end to change the mark the user tries to put on an article." @@ -453,6 +502,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (if (not (gnus-check-backend-function 'request-update-mark (car gnus-command-method))) mark + (gnus-run-hook-with-args gnus-before-update-mark-hook group article mark) (funcall (gnus-get-function gnus-command-method 'request-update-mark) (gnus-group-real-name group) article mark)))) @@ -465,6 +515,22 @@ If BUFFER, insert the article in that group." article (gnus-group-real-name group) (nth 1 gnus-command-method) buffer))) +(defun gnus-request-thread (header) + "Request the headers in the thread containing the article specified by HEADER." + (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) + (funcall (gnus-get-function gnus-command-method 'request-thread) + header))) + +(defun gnus-warp-to-article () + "Warps from an article in a virtual group to the article in its +real group. Does nothing on a real group." + (interactive) + (let ((gnus-command-method + (gnus-find-method-for-group gnus-newsgroup-name))) + (when (gnus-check-backend-function + 'warp-to-article (car gnus-command-method)) + (funcall (gnus-get-function gnus-command-method 'warp-to-article))))) + (defun gnus-request-head (article group) "Request the head of ARTICLE in GROUP." (let* ((gnus-command-method (gnus-find-method-for-group group)) @@ -490,8 +556,7 @@ If BUFFER, insert the article in that group." (setq res (gnus-request-article article group) clean-up t))) (when clean-up - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (1- (point)) (point-max))) @@ -523,8 +588,7 @@ If BUFFER, insert the article in that group." (setq res (gnus-request-article article group) clean-up t))) (when clean-up - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (point-min) (1- (point)))))) @@ -537,6 +601,14 @@ If BUFFER, insert the article in that group." (funcall (gnus-get-function gnus-command-method 'request-post) (nth 1 gnus-command-method))) +(defun gnus-request-expunge-group (group gnus-command-method) + "Expunge GROUP, which is removing articles that have been marked as deleted." + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-expunge-group) + (gnus-group-real-name group) + (nth 1 gnus-command-method))) + (defun gnus-request-scan (group gnus-command-method) "Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD. If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." @@ -544,18 +616,28 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (if group (gnus-find-method-for-group group) gnus-command-method)) (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) - (when (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) + (when (or gnus-plugged + (not (gnus-agent-method-p gnus-command-method))) (setq gnus-internal-registry-spool-current-method gnus-command-method) (funcall (gnus-get-function gnus-command-method 'request-scan) (and group (gnus-group-real-name group)) (nth 1 gnus-command-method))))) -(defsubst gnus-request-update-info (info gnus-command-method) +(defun gnus-request-update-info (info gnus-command-method) + (when (gnus-check-backend-function + 'request-update-info (car gnus-command-method)) + (when (stringp gnus-command-method) + (setq gnus-command-method (gnus-server-to-method gnus-command-method))) + (funcall (gnus-get-function gnus-command-method 'request-update-info) + (gnus-group-real-name (gnus-info-group info)) info + (nth 1 gnus-command-method)))) + +(defsubst gnus-request-marks (info gnus-command-method) "Request that GNUS-COMMAND-METHOD update INFO." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (when (gnus-check-backend-function - 'request-update-info (car gnus-command-method)) + 'request-marks (car gnus-command-method)) (let ((group (gnus-info-group info))) (and (funcall (gnus-get-function gnus-command-method 'request-update-info) @@ -575,6 +657,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (defun gnus-request-expire-articles (articles group &optional force) (let* ((gnus-command-method (gnus-find-method-for-group group)) + (gnus-inhibit-demon t) (not-deleted (funcall (gnus-get-function gnus-command-method 'request-expire-articles) @@ -593,7 +676,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (result (funcall (gnus-get-function gnus-command-method 'request-move-article) article (gnus-group-real-name group) - (nth 1 gnus-command-method) accept-function last move-is-internal))) + (nth 1 gnus-command-method) accept-function + last move-is-internal))) (when (and result gnus-agent (gnus-agent-method-p gnus-command-method)) (gnus-agent-unfetch-articles group (list article))) @@ -627,7 +711,9 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (if (stringp group) (gnus-group-real-name group) group) (cadr gnus-command-method) last))) - (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (when (and gnus-agent + (gnus-agent-method-p gnus-command-method) + (cdr result)) (gnus-agent-regenerate-group group (list (cdr result)))) result)) @@ -716,5 +802,4 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (provide 'gnus-int) -;; arch-tag: bbc90087-9b7f-4017-a92c-3abf180ac86d ;;; gnus-int.el ends here diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 119514fba6..3f4a9fce1b 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -349,8 +349,7 @@ If NEWSGROUP is nil, return the global kill file instead." (defun gnus-expunge (marks) "Remove lines marked with MARKS." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-limit-to-marks marks 'reverse))) (defun gnus-apply-kill-file-unless-scored () @@ -442,8 +441,7 @@ Returns the number of articles marked as read." (progn (delete-region beg (point)) (insert (or (eval form) ""))) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (ignore-errors (eval form))))) (and (buffer-modified-p) gnus-kill-save-kill-file @@ -482,7 +480,7 @@ Returns the number of articles marked as read." (or (cdr (assq modifier mod-to-header)) "subject") pattern (if (string-match "m" commands) - '(gnus-summary-mark-as-unread nil " ") + '(gnus-summary-tick-article nil " ") '(gnus-summary-mark-as-read nil "X")) nil t)) (forward-line 1)))) @@ -555,8 +553,7 @@ COMMAND must be a Lisp expression or a string representing a key sequence." (and (eq 'quote (car (nth 2 object))) (not (consp (cdadr (nth 2 object)))))) (concat "\n" (gnus-prin1-to-string object)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Gnus PP*")) + (with-current-buffer (gnus-get-buffer-create "*Gnus PP*") (buffer-disable-undo) (erase-buffer) (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) @@ -610,8 +607,7 @@ COMMAND must be a Lisp expression or a string representing a key sequence." 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) - (when (save-excursion - (set-buffer gnus-article-buffer) + (when (with-current-buffer gnus-article-buffer (goto-char (point-min)) (setq did-kill (re-search-forward regexp nil t))) (cond ((stringp form) ;Keyboard macro. @@ -715,5 +711,4 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (provide 'gnus-kill) -;; arch-tag: b30c0f53-df1a-490b-b81e-17b13474f395 ;;; gnus-kill.el ends here diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el index eaba5ae276..d5d8928f64 100644 --- a/lisp/gnus/gnus-logic.el +++ b/lisp/gnus/gnus-logic.el @@ -179,8 +179,7 @@ (defun gnus-advanced-body (header match type) (when (string= header "all") (setq header "article")) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (let* ((request-func (cond ((string= "head" header) 'gnus-request-head) ((string= "body" header) @@ -225,5 +224,4 @@ (provide 'gnus-logic) -;; arch-tag: 9651a100-4a59-4b69-a55b-e511e67c0f8d ;;; gnus-logic.el ends here diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el index 4428b161c0..197016f5eb 100644 --- a/lisp/gnus/gnus-mh.el +++ b/lisp/gnus/gnus-mh.el @@ -109,5 +109,4 @@ Otherwise, it is like +news/group." (provide 'gnus-mh) -;; arch-tag: 2d5696d3-b363-48e5-8749-c256be56acca ;;; gnus-mh.el ends here diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index 4a618f4950..12ff5ea3a0 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -30,27 +30,25 @@ (require 'gnus) (require 'gnus-msg) (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' ;;; Mailing list minor mode -(defvar gnus-mailing-list-mode nil - "Minor mode for providing mailing-list commands.") - -(defvar gnus-mailing-list-mode-map nil) +(defvar gnus-mailing-list-mode-map + (let ((map (make-sparse-keymap))) + (gnus-define-keys map + "\C-c\C-nh" gnus-mailing-list-help + "\C-c\C-ns" gnus-mailing-list-subscribe + "\C-c\C-nu" gnus-mailing-list-unsubscribe + "\C-c\C-np" gnus-mailing-list-post + "\C-c\C-no" gnus-mailing-list-owner + "\C-c\C-na" gnus-mailing-list-archive) + map)) (defvar gnus-mailing-list-menu) -(unless gnus-mailing-list-mode-map - (setq gnus-mailing-list-mode-map (make-sparse-keymap)) - - (gnus-define-keys gnus-mailing-list-mode-map - "\C-c\C-nh" gnus-mailing-list-help - "\C-c\C-ns" gnus-mailing-list-subscribe - "\C-c\C-nu" gnus-mailing-list-unsubscribe - "\C-c\C-np" gnus-mailing-list-post - "\C-c\C-no" gnus-mailing-list-owner - "\C-c\C-na" gnus-mailing-list-archive)) - (defun gnus-mailing-list-make-menu-bar () (unless (boundp 'gnus-mailing-list-menu) (easy-menu-define @@ -87,22 +85,26 @@ If FORCE is non-nil, replace the old ones." (gnus-mailing-list-mode 1)) (gnus-message 1 "no list-post in this message.")))) +(eval-when-compile + (when (featurep 'xemacs) + (defvar gnus-mailing-list-mode-hook) + (defvar gnus-mailing-list-mode-on-hook) + (defvar gnus-mailing-list-mode-off-hook))) + ;;;###autoload -(defun gnus-mailing-list-mode (&optional arg) +(define-minor-mode gnus-mailing-list-mode "Minor mode for providing mailing-list commands. \\{gnus-mailing-list-mode-map}" - (interactive "P") - (when (eq major-mode 'gnus-summary-mode) - (when (set (make-local-variable 'gnus-mailing-list-mode) - (if (null arg) (not gnus-mailing-list-mode) - (> (prefix-numeric-value arg) 0))) - ;; Set up the menu. - (when (gnus-visual-p 'mailing-list-menu 'menu) - (gnus-mailing-list-make-menu-bar)) - (add-minor-mode 'gnus-mailing-list-mode " Mailing-List" - gnus-mailing-list-mode-map) - (gnus-run-hooks 'gnus-mailing-list-mode-hook)))) + :lighter " Mailing-List" + :keymap gnus-mailing-list-mode-map + (cond + ((not (derived-mode-p 'gnus-summary-mode)) + (setq gnus-mailing-list-mode nil)) + (gnus-mailing-list-mode + ;; Set up the menu. + (when (gnus-visual-p 'mailing-list-menu 'menu) + (gnus-mailing-list-make-menu-bar))))) ;;; Commands @@ -178,5 +180,4 @@ ADDRESS is specified by a \"mailto:\" URL." (provide 'gnus-ml) -;; arch-tag: 936c0fe6-acce-4c16-87d0-eded88078896 ;;; gnus-ml.el ends here diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el index b4dd08df0c..3769535ad4 100644 --- a/lisp/gnus/gnus-mlspl.el +++ b/lisp/gnus/gnus-mlspl.el @@ -227,5 +227,4 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: (provide 'gnus-mlspl) -;; arch-tag: 62b3381f-1e45-4b61-be1a-29fb27703322 ;;; gnus-mlspl.el ends here diff --git a/lisp/gnus/gnus-move.el b/lisp/gnus/gnus-move.el deleted file mode 100644 index dc74102724..0000000000 --- a/lisp/gnus/gnus-move.el +++ /dev/null @@ -1,181 +0,0 @@ -;;; gnus-move.el --- commands for moving Gnus from one server to another - -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'gnus) -(require 'gnus-start) -(require 'gnus-int) -(require 'gnus-range) - -;;; -;;; Moving by comparing Message-ID's. -;;; - -;;;###autoload -(defun gnus-change-server (from-server to-server) - "Move from FROM-SERVER to TO-SERVER. -Update the .newsrc.eld file to reflect the change of nntp server." - (interactive - (list gnus-select-method (gnus-read-method "Move to method: "))) - - ;; First start Gnus. - (let ((gnus-activate-level 0) - (mail-sources nil)) - (gnus)) - - (save-excursion - ;; Go through all groups and translate. - (let ((nntp-nov-gap nil)) - (dolist (info gnus-newsrc-alist) - (when (gnus-group-native-p (gnus-info-group info)) - (gnus-move-group-to-server info from-server to-server)))))) - -(defun gnus-move-group-to-server (info from-server to-server) - "Move group INFO from FROM-SERVER to TO-SERVER." - (let ((group (gnus-info-group info)) - to-active hashtb type mark marks - to-article to-reads to-marks article - act-articles) - (gnus-message 7 "Translating %s..." group) - (when (gnus-request-group group nil to-server) - (setq to-active (gnus-parse-active) - hashtb (gnus-make-hashtable 1024) - act-articles (gnus-uncompress-range to-active)) - ;; Fetch the headers from the `to-server'. - (when (and to-active - act-articles - (setq type (gnus-retrieve-headers - act-articles - group to-server))) - ;; Convert HEAD headers. I don't care. - (when (eq type 'headers) - (nnvirtual-convert-headers)) - ;; Create a mapping from Message-ID to article number. - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while (looking-at - "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") - (gnus-sethash - (buffer-substring (match-beginning 1) (match-end 1)) - (read (current-buffer)) - hashtb) - (forward-line 1)) - ;; Then we read the headers from the `from-server'. - (when (and (gnus-request-group group nil from-server) - (gnus-active group) - (gnus-uncompress-range - (gnus-active group)) - (setq type (gnus-retrieve-headers - (gnus-uncompress-range - (gnus-active group)) - group from-server))) - ;; Make it easier to map marks. - (let ((mark-lists (gnus-info-marks info)) - ms type m) - (while mark-lists - (setq type (caar mark-lists) - ms (gnus-uncompress-range (cdr (pop mark-lists)))) - (while ms - (if (setq m (assq (car ms) marks)) - (setcdr m (cons type (cdr m))) - (push (list (car ms) type) marks)) - (pop ms)))) - ;; Convert. - (when (eq type 'headers) - (nnvirtual-convert-headers)) - ;; Go through the headers and map away. - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while (looking-at - "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") - (when (setq to-article - (gnus-gethash - (buffer-substring (match-beginning 1) (match-end 1)) - hashtb)) - ;; Add this article to the list of read articles. - (push to-article to-reads) - ;; See if there are any marks and then add them. - (when (setq mark (assq (read (current-buffer)) marks)) - (setq marks (delq mark marks)) - (setcar mark to-article) - (push mark to-marks)) - (forward-line 1))) - ;; Now we know what the read articles are and what the - ;; article marks are. We transform the information - ;; into the Gnus info format. - (setq to-reads - (gnus-range-add - (gnus-compress-sequence - (and (setq to-reads (delq nil to-reads)) - (sort to-reads '<)) - t) - (cons 1 (1- (car to-active))))) - (gnus-info-set-read info to-reads) - ;; Do the marks. I'm sure y'all understand what's - ;; going on down below, so I won't bother with any - ;; further comments. <duck> - (let ((mlists gnus-article-mark-lists) - lists ms a) - (while mlists - (push (list (cdr (pop mlists))) lists)) - (while (setq ms (pop marks)) - (setq article (pop ms)) - (while ms - (setcdr (setq a (assq (pop ms) lists)) - (cons article (cdr a))))) - (setq a lists) - (while a - (setcdr (car a) (gnus-compress-sequence - (and (cdar a) (sort (cdar a) '<)))) - (pop a)) - (gnus-info-set-marks info lists t))))) - (gnus-message 7 "Translating %s...done" group))) - -(defun gnus-group-move-group-to-server (info from-server to-server) - "Move the group on the current line from FROM-SERVER to TO-SERVER." - (interactive - (let ((info (gnus-get-info (gnus-group-group-name)))) - (list info (gnus-find-method-for-group (gnus-info-group info)) - (gnus-read-method (format "Move group %s to method: " - (gnus-info-group info)))))) - (save-excursion - (gnus-move-group-to-server info from-server to-server) - ;; We have to update the group info to point use the right server. - (gnus-info-set-method info to-server t) - ;; We also have to change the name of the group and stuff. - (let* ((group (gnus-info-group info)) - (new-name (gnus-group-prefixed-name - (gnus-group-real-name group) to-server))) - (gnus-info-set-group info new-name) - (gnus-sethash new-name (gnus-group-entry group) gnus-newsrc-hashtb) - (gnus-sethash group nil gnus-newsrc-hashtb)))) - -(provide 'gnus-move) - -;; arch-tag: 503742b8-7d66-4d79-bb31-4a698070707b -;;; gnus-move.el ends here diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index a8e17ba887..e352ffacef 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1,7 +1,8 @@ ;;; gnus-msg.el --- mail and post interface for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software +;; Foundation, Inc. ;; Author: Masanobu UMEDA <[email protected]> ;; Lars Magne Ingebrigtsen <[email protected]> @@ -55,7 +56,7 @@ method to use when posting." (sexp :tag "Methods" ,gnus-select-method))) (defcustom gnus-outgoing-message-group nil - "*All outgoing messages will be put in this group. + "All outgoing messages will be put in this group. If you want to store all your outgoing mail and articles in the group \"nnml:archive\", you set this variable to that value. This variable can also be a list of group names. @@ -70,6 +71,8 @@ of names)." (string :tag "Group") (repeat :tag "List of groups" (string :tag "Group")))) +(make-obsolete-variable 'gnus-outgoing-message-group 'gnus-message-archive-group "24.1") + (defcustom gnus-mailing-list-groups nil "*If non-nil a regexp matching groups that are really mailing lists. This is useful when you're reading a mailing list that has been @@ -241,10 +244,10 @@ See also the `mml-default-sign-method' variable." :group 'gnus-message :type 'boolean) -(defcustom gnus-message-replyencrypt - nil +(defcustom gnus-message-replyencrypt t "Automatically encrypt replies to encrypted messages. See also the `mml-default-encrypt-method' variable." + :version "24.1" :group 'gnus-message :type 'boolean) @@ -397,7 +400,6 @@ Thank you for your help in stamping out bugs. (message-mode-hook (copy-sequence message-mode-hook))) (setq mml-buffer-list nil) (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) - (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) ;; message-newsreader and message-mailer were formerly set in ;; gnus-inews-add-send-actions, but this is too late when ;; message-generate-headers-first is used. --ansel @@ -420,7 +422,7 @@ Thank you for your help in stamping out bugs. ;; There may be an old " *gnus article copy*" buffer. (let (gnus-article-copy) (gnus-configure-posting-styles ,group))))) - (gnus-pull ',(intern gnus-draft-meta-information-header) + (gnus-alist-pull ',(intern gnus-draft-meta-information-header) message-required-headers) (when (and ,group (not (string= ,group ""))) @@ -475,7 +477,7 @@ Thank you for your help in stamping out bugs. ;;;###autoload (defun gnus-msg-mail (&optional to subject other-headers continue - switch-action yank-action send-actions) + switch-action yank-action send-actions return-action) "Start editing a mail message to be sent. Like `message-mail', but with Gnus paraphernalia, particularly the Gcc: header for archiving purposes." @@ -484,7 +486,7 @@ Gcc: header for archiving purposes." mail-buf) (gnus-setup-message 'message (message-mail to subject other-headers continue - nil yank-action send-actions)) + nil yank-action send-actions return-action)) (when switch-action (setq mail-buf (current-buffer)) (switch-to-buffer buf) @@ -578,8 +580,8 @@ If ARG is 1, prompt for a group name to find the posting style." (if arg (if (= 1 (prefix-numeric-value arg)) (gnus-group-completing-read - "Use posting style of group: " - nil nil (gnus-read-active-file-p)) + "Use posting style of group" + nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) ;; #### see comment in gnus-setup-message -- drv @@ -607,8 +609,8 @@ network. The corresponding back end must have a 'request-post method." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group: " - nil nil + (gnus-group-completing-read "Use group" + nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) @@ -628,7 +630,7 @@ a news." (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Newsgroup: " nil nil + (gnus-group-completing-read "Newsgroup" nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) @@ -654,8 +656,8 @@ posting style." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group: " - nil nil + (gnus-group-completing-read "Use group" + nil (gnus-read-active-file-p)) "") gnus-newsgroup-name)) @@ -684,8 +686,8 @@ network. The corresponding back end must have a 'request-post method." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group: " - nil nil + (gnus-group-completing-read "Use group" + nil (gnus-read-active-file-p)) "") gnus-newsgroup-name)) @@ -710,7 +712,7 @@ a news." (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Newsgroup: " nil nil + (gnus-group-completing-read "Newsgroup" nil (gnus-read-active-file-p)) "") gnus-newsgroup-name)) @@ -826,7 +828,6 @@ header line with the old Message-ID." (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) message-send-actions) ;; Add Gcc header. - (gnus-inews-insert-archive-gcc) (gnus-inews-insert-gcc)))) @@ -1028,8 +1029,8 @@ If SILENT, don't prompt the user." gnus-last-posting-server) ;; Just use the last value. gnus-last-posting-server - (completing-read - "Posting method: " method-alist nil t + (gnus-completing-read + "Posting method" (mapcar 'car method-alist) t (cons (or gnus-last-posting-server "") 0)))) method-alist)))) ;; Override normal method. @@ -1265,7 +1266,8 @@ For the `inline' alternatives, also see the variable (dolist (article (gnus-summary-work-articles n)) (gnus-summary-select-article nil nil nil article) (with-current-buffer gnus-original-article-buffer - (message-resend address)) + (let ((gnus-gcc-externalize-attachments nil)) + (message-resend address))) (gnus-summary-mark-article-as-forwarded article))) ;; From: Matthieu Moy <[email protected]> @@ -1293,7 +1295,6 @@ composing a new message." (goto-char (point-max)) (insert mail-header-separator) ;; Add Gcc header. - (gnus-inews-insert-archive-gcc) (gnus-inews-insert-gcc) (goto-char (point-min)) (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move) @@ -1306,24 +1307,6 @@ See `gnus-summary-mail-forward' for ARG." (interactive "P") (gnus-summary-mail-forward arg t)) -(defvar gnus-nastygram-message - "The following article was inappropriately posted to %s.\n\n" - "Format string to insert in nastygrams. -The current group name will be inserted at \"%s\".") - -(defun gnus-summary-mail-nastygram (n) - "Send a nastygram to the author of the current article." - (interactive "P") - (when (or gnus-expert-user - (gnus-y-or-n-p - "Really send a nastygram to the author of the current article? ")) - (let ((group gnus-newsgroup-name)) - (gnus-summary-reply-with-original n) - (set-buffer gnus-message-buffer) - (message-goto-body) - (insert (format gnus-nastygram-message group)) - (message-send-and-exit)))) - (defun gnus-summary-mail-crosspost-complaint (n) "Send a complaint about crossposting to the current article(s)." (interactive "P") @@ -1487,7 +1470,7 @@ If YANK is non-nil, include the original article." (defun gnus-summary-yank-message (buffer n) "Yank the current article into a composed message." (interactive - (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t) + (list (gnus-completing-read "Buffer" (message-buffers) t) current-prefix-arg)) (gnus-summary-iterate n (let ((gnus-inhibit-treatment t)) @@ -1579,7 +1562,6 @@ this is a reply." (gnus-setup-message 'compose-bounce (message-bounce) ;; Add Gcc header. - (gnus-inews-insert-archive-gcc) (gnus-inews-insert-gcc) ;; If there are references, we fetch the article we answered to. (when parent @@ -1627,7 +1609,7 @@ this is a reply." (unless (gnus-check-server method) (error "Can't open server %s" (if (stringp method) method (car method)))) - (unless (gnus-request-group group nil method) + (unless (gnus-request-group group t method) (gnus-request-create-group group method)) (setq mml-externalize-attachments (if (stringp gnus-gcc-externalize-attachments) @@ -1693,44 +1675,13 @@ this is a reply." (gnus-group-mark-article-read group (cdr group-art))) (kill-buffer (current-buffer))))))))) -(defun gnus-inews-insert-gcc () - "Insert Gcc headers based on `gnus-outgoing-message-group'." - (save-excursion - (save-restriction - (message-narrow-to-headers) - (let* ((group gnus-outgoing-message-group) - (gcc (cond - ((functionp group) - (funcall group)) - ((or (stringp group) (listp group)) - group)))) - (when gcc - (insert "Gcc: " - (if (stringp gcc) - (if (string-match " " gcc) - (concat "\"" gcc "\"") - gcc) - (mapconcat (lambda (group) - (if (string-match " " group) - (concat "\"" group "\"") - group)) - gcc " ")) - "\n")))))) - -(defun gnus-inews-insert-archive-gcc (&optional group) +(defun gnus-inews-insert-gcc (&optional group) "Insert the Gcc to say where the article is to be archived." - (setq group (cond (group - (gnus-group-decoded-name group)) - (gnus-newsgroup-name - (gnus-group-decoded-name gnus-newsgroup-name)) - (t - ""))) - (let* ((var gnus-message-archive-group) + (let* ((group (or group gnus-newsgroup-name)) + (group (when group (gnus-group-decoded-name group))) + (var (or gnus-outgoing-message-group gnus-message-archive-group)) (gcc-self-val - (and gnus-newsgroup-name - (not (equal gnus-newsgroup-name "")) - (gnus-group-find-parameter - gnus-newsgroup-name 'gcc-self))) + (and group (gnus-group-find-parameter group 'gcc-self))) result (groups (cond @@ -1890,7 +1841,11 @@ this is a reply." (setq v (cond ((stringp value) - value) + (if (and (stringp match) + (gnus-string-match-p "\\\\[&[:digit:]]" value) + (match-beginning 1)) + (gnus-match-substitute-replacement value nil nil group) + value)) ((or (symbolp value) (functionp value)) (cond ((functionp value) @@ -1989,5 +1944,4 @@ this is a reply." (provide 'gnus-msg) -;; arch-tag: 9f22b2f5-1c0a-49de-916e-4c88e984852b ;;; gnus-msg.el ends here diff --git a/lisp/gnus/gnus-nocem.el b/lisp/gnus/gnus-nocem.el deleted file mode 100644 index 0fc779628b..0000000000 --- a/lisp/gnus/gnus-nocem.el +++ /dev/null @@ -1,453 +0,0 @@ -;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'gnus) -(require 'nnmail) -(require 'gnus-art) -(require 'gnus-sum) -(require 'gnus-range) - -(defgroup gnus-nocem nil - "NoCeM pseudo-cancellation treatment." - :group 'gnus-score) - -(defcustom gnus-nocem-groups - '("news.lists.filters" "alt.nocem.misc") - "*List of groups that will be searched for NoCeM messages." - :group 'gnus-nocem - :version "23.1" - :type '(repeat (string :tag "Group"))) - -(defcustom gnus-nocem-issuers - '("Adri Verhoef" - "[email protected]") - "*List of NoCeM issuers to pay attention to. - -This can also be a list of `(ISSUER CONDITION ...)' elements. - -See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an -issuer registry." - :group 'gnus-nocem - :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html") - :version "23.1" - :type '(repeat (cons :format "%v" (string :tag "Issuer") - (repeat :tag "Condition" - (group (checklist :inline t (const not)) - (regexp :tag "Type" :value ".*"))))) - :get (lambda (symbol) - (mapcar (lambda (elem) - (if (consp elem) - (cons (car elem) - (mapcar (lambda (elt) - (if (consp elt) elt (list elt))) - (cdr elem))) - (list elem))) - (default-value symbol))) - :set (lambda (symbol value) - (custom-set-default - symbol - (mapcar (lambda (elem) - (if (consp elem) - (if (cdr elem) - (mapcar (lambda (elt) - (if (consp elt) - (if (cdr elt) elt (car elt)) - elt)) - elem) - (car elem)) - elem)) - value)))) - -(defcustom gnus-nocem-directory - (nnheader-concat gnus-article-save-directory "NoCeM/") - "*Directory where NoCeM files will be stored." - :group 'gnus-nocem - :type 'directory) - -(defcustom gnus-nocem-expiry-wait 15 - "*Number of days to keep NoCeM headers in the cache." - :group 'gnus-nocem - :type 'integer) - -(defcustom gnus-nocem-verifyer (if (locate-library "epg") - 'gnus-nocem-epg-verify - 'pgg-verify) - "*Function called to verify that the NoCeM message is valid. -If the function in this variable isn't bound, the message will be used -unconditionally." - :group 'gnus-nocem - :version "23.1" - :type '(radio (function-item gnus-nocem-epg-verify) - (function-item pgg-verify) - (function-item mc-verify) - (function :tag "other")) - :set (lambda (symbol value) - (custom-set-default symbol - (if (and (eq value 'gnus-nocem-epg-verify) - (not (locate-library "epg"))) - 'pgg-verify - value)))) - -(defcustom gnus-nocem-liberal-fetch nil - "*If t try to fetch all messages which have @@NCM in the subject. -Otherwise don't fetch messages which have references or whose message-id -matches a previously scanned and verified nocem message." - :group 'gnus-nocem - :type 'boolean) - -(defcustom gnus-nocem-check-article-limit 500 - "*If non-nil, the maximum number of articles to check in any NoCeM group." - :group 'gnus-nocem - :version "21.1" - :type '(choice (const :tag "unlimited" nil) - (integer 1000))) - -(defcustom gnus-nocem-check-from t - "Non-nil means check for valid issuers in message bodies. -Otherwise don't bother fetching articles unless their author matches a -valid issuer, which is much faster if you are selective about the issuers." - :group 'gnus-nocem - :version "21.1" - :type 'boolean) - -;;; Internal variables - -(defvar gnus-nocem-active nil) -(defvar gnus-nocem-alist nil) -(defvar gnus-nocem-touched-alist nil) -(defvar gnus-nocem-hashtb nil) -(defvar gnus-nocem-seen-message-ids nil) - -;;; Functions - -(defun gnus-nocem-active-file () - (concat (file-name-as-directory gnus-nocem-directory) "active")) - -(defun gnus-nocem-cache-file () - (concat (file-name-as-directory gnus-nocem-directory) "cache")) - -;; -;; faster lookups for group names: -;; - -(defvar gnus-nocem-real-group-hashtb nil - "Real-name mappings of subscribed groups.") - -(defun gnus-fill-real-hashtb () - "Fill up a hash table with the real-name mappings from the user's active file." - (if (hash-table-p gnus-nocem-real-group-hashtb) - (clrhash gnus-nocem-real-group-hashtb) - (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal))) - (mapcar (lambda (group) - (setq group (gnus-group-real-name (car group))) - (puthash group t gnus-nocem-real-group-hashtb)) - gnus-newsrc-alist)) - -;;;###autoload -(defun gnus-nocem-scan-groups () - "Scan all NoCeM groups for new NoCeM messages." - (interactive) - (let ((groups gnus-nocem-groups) - (gnus-inhibit-demon t) - group active gactive articles check-headers) - (gnus-make-directory gnus-nocem-directory) - ;; Load any previous NoCeM headers. - (gnus-nocem-load-cache) - ;; Get the group name mappings: - (gnus-fill-real-hashtb) - ;; Read the active file if it hasn't been read yet. - (and (file-exists-p (gnus-nocem-active-file)) - (not gnus-nocem-active) - (ignore-errors - (load (gnus-nocem-active-file) t t t))) - ;; Go through all groups and see whether new articles have - ;; arrived. - (while (setq group (pop groups)) - (if (not (setq gactive (gnus-activate-group group))) - () ; This group doesn't exist. - (setq active (nth 1 (assoc group gnus-nocem-active))) - (when (and (not (< (cdr gactive) (car gactive))) ; Empty group. - (or (not active) - (< (cdr active) (cdr gactive)))) - ;; Ok, there are new articles in this group, se we fetch the - ;; headers. - (save-excursion - (let ((dependencies (make-vector 10 nil)) - headers header) - (with-temp-buffer - (setq headers - (if (eq 'nov - (gnus-retrieve-headers - (setq articles - (gnus-uncompress-range - (cons - (if active (1+ (cdr active)) - (car gactive)) - (cdr gactive)))) - group)) - (gnus-get-newsgroup-headers-xover - articles nil dependencies) - (gnus-get-newsgroup-headers dependencies))) - (while (setq header (pop headers)) - ;; We take a closer look on all articles that have - ;; "@@NCM" in the subject. Unless we already read - ;; this cross posted message. Nocem messages - ;; are not allowed to have references, so we can - ;; ignore scanning followups. - (and (string-match "@@NCM" (mail-header-subject header)) - (and gnus-nocem-check-from - (let ((case-fold-search t)) - (catch 'ok - (mapc - (lambda (author) - (if (consp author) - (setq author (car author))) - (if (string-match - author (mail-header-from header)) - (throw 'ok t))) - gnus-nocem-issuers) - nil))) - (or gnus-nocem-liberal-fetch - (and (or (string= "" (mail-header-references - header)) - (null (mail-header-references header))) - (not (member (mail-header-message-id header) - gnus-nocem-seen-message-ids)))) - (push header check-headers))) - (setq check-headers (last (nreverse check-headers) - gnus-nocem-check-article-limit)) - (let ((i 0) - (len (length check-headers))) - (dolist (h check-headers) - (gnus-message - 7 "Checking article %d in %s for NoCeM (%d of %d)..." - (mail-header-number h) group (incf i) len) - (gnus-nocem-check-article group h))))))) - (setq gnus-nocem-active - (cons (list group gactive) - (delq (assoc group gnus-nocem-active) - gnus-nocem-active))))) - ;; Save the results, if any. - (gnus-nocem-save-cache) - (gnus-nocem-save-active))) - -(defun gnus-nocem-check-article (group header) - "Check whether the current article is an NCM article and that we want it." - ;; Get the article. - (let ((date (mail-header-date header)) - (gnus-newsgroup-name group) - issuer b e type) - (when (or (not date) - (time-less-p - (time-since (date-to-time date)) - (days-to-time gnus-nocem-expiry-wait))) - (gnus-request-article-this-buffer (mail-header-number header) group) - (goto-char (point-min)) - (when (re-search-forward - "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----" - nil t) - (delete-region (point-min) (match-beginning 0))) - (when (re-search-forward - "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?" - nil t) - (delete-region (match-end 0) (point-max))) - (goto-char (point-min)) - ;; The article has to have proper NoCeM headers. - (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t)) - (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) - ;; We get the name of the issuer. - (narrow-to-region b e) - (setq issuer (mail-fetch-field "issuer") - type (mail-fetch-field "type")) - (widen) - (if (not (gnus-nocem-message-wanted-p issuer type)) - (message "invalid NoCeM issuer: %s" issuer) - (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is. - (gnus-nocem-enter-article) ; We gobble the message. - (push (mail-header-message-id header) ; But don't come back for - gnus-nocem-seen-message-ids))))))) ; second helpings. - -(defun gnus-nocem-message-wanted-p (issuer type) - (let ((issuers gnus-nocem-issuers) - wanted conditions condition) - (cond - ;; Do the quick check first. - ((member issuer issuers) - t) - ((setq conditions (cdr (assoc issuer issuers))) - ;; Check whether we want this type. - (while (setq condition (pop conditions)) - (cond - ((stringp condition) - (when (string-match condition type) - (setq wanted t))) - ((and (consp condition) - (eq (car condition) 'not) - (stringp (cadr condition))) - (when (string-match (cadr condition) type) - (setq wanted nil))) - (t - (error "Invalid NoCeM condition: %S" condition)))) - wanted)))) - -(defun gnus-nocem-verify-issuer (person) - "Verify using PGP that the canceler is who she says she is." - (if (functionp gnus-nocem-verifyer) - (ignore-errors - (funcall gnus-nocem-verifyer)) - ;; If we don't have Mailcrypt, then we use the message anyway. - t)) - -(defun gnus-nocem-enter-article () - "Enter the current article into the NoCeM cache." - (goto-char (point-min)) - (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) - (e (search-forward "\n@@END NCM BODY\n" nil t)) - (buf (current-buffer)) - ncm id group) - (when (and b e) - (narrow-to-region b (1+ (match-beginning 0))) - (goto-char (point-min)) - (while (search-forward "\t" nil t) - (cond - ((not (ignore-errors - (setq group (gnus-group-real-name (symbol-name (read buf)))) - (gethash group gnus-nocem-real-group-hashtb))) - ;; An error. - ) - (t - ;; Valid group. - (beginning-of-line) - (while (eq (char-after) ?\t) - (forward-line -1)) - (setq id (buffer-substring (point) (1- (search-forward "\t")))) - (unless (if (hash-table-p gnus-nocem-hashtb) - (gethash id gnus-nocem-hashtb) - (setq gnus-nocem-hashtb (make-hash-table :test 'equal)) - nil) - ;; only store if not already present - (puthash id t gnus-nocem-hashtb) - (push id ncm)) - (forward-line 1) - (while (eq (char-after) ?\t) - (forward-line 1))))) - (when ncm - (setq gnus-nocem-touched-alist t) - (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) - ncm) - gnus-nocem-alist)) - t))) - -;;;###autoload -(defun gnus-nocem-load-cache () - "Load the NoCeM cache." - (interactive) - (unless gnus-nocem-alist - ;; The buffer doesn't exist, so we create it and load the NoCeM - ;; cache. - (when (file-exists-p (gnus-nocem-cache-file)) - (load (gnus-nocem-cache-file) t t t) - (gnus-nocem-alist-to-hashtb)))) - -(defun gnus-nocem-save-cache () - "Save the NoCeM cache." - (when (and gnus-nocem-alist - gnus-nocem-touched-alist) - (with-temp-file (gnus-nocem-cache-file) - (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist))) - (setq gnus-nocem-touched-alist nil))) - -(defun gnus-nocem-save-active () - "Save the NoCeM active file." - (with-temp-file (gnus-nocem-active-file) - (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active)))) - -(defun gnus-nocem-alist-to-hashtb () - "Create a hashtable from the Message-IDs we have." - (let* ((alist gnus-nocem-alist) - (pprev (cons nil alist)) - (prev pprev) - (expiry (days-to-time gnus-nocem-expiry-wait)) - entry) - (if (hash-table-p gnus-nocem-hashtb) - (clrhash gnus-nocem-hashtb) - (setq gnus-nocem-hashtb (make-hash-table :test 'equal))) - (while (setq entry (car alist)) - (if (not (time-less-p (time-since (car entry)) expiry)) - ;; This entry has expired, so we remove it. - (setcdr prev (cdr alist)) - (setq prev alist) - ;; This is ok, so we enter it into the hashtable. - (setq entry (cdr entry)) - (while entry - (puthash (car entry) t gnus-nocem-hashtb) - (setq entry (cdr entry)))) - (setq alist (cdr alist))))) - -(gnus-add-shutdown 'gnus-nocem-close 'gnus) - -(defun gnus-nocem-close () - "Clear internal NoCeM variables." - (setq gnus-nocem-alist nil - gnus-nocem-hashtb nil - gnus-nocem-active nil - gnus-nocem-touched-alist nil - gnus-nocem-seen-message-ids nil - gnus-nocem-real-group-hashtb nil)) - -(defun gnus-nocem-unwanted-article-p (id) - "Say whether article ID in the current group is wanted." - (and gnus-nocem-hashtb - (gethash id gnus-nocem-hashtb))) - -(autoload 'epg-make-context "epg") -(eval-when-compile - (autoload 'epg-verify-string "epg") - (autoload 'epg-context-result-for "epg") - (autoload 'epg-signature-status "epg")) - -(defun gnus-nocem-epg-verify () - "Return t if EasyPG verifies a signed message in the current buffer." - (let ((context (epg-make-context 'OpenPGP)) - result) - (epg-verify-string context (buffer-string)) - (and (setq result (epg-context-result-for context 'verify)) - (not (cdr result)) - (eq (epg-signature-status (car result)) 'good)))) - -(provide 'gnus-nocem) - -;; arch-tag: 0e0c74ea-2f8e-4f3e-8fff-09f767c1adef -;;; gnus-nocem.el ends here diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index a35e6fe930..d138776149 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -38,7 +38,7 @@ ;; ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -85,23 +85,14 @@ added right to the textual representation." (const right)) :group 'gnus-picon) -(defface gnus-picon-xbm '((t (:foreground "black" :background "white"))) - "Face to show xbm picon in." +(defcustom gnus-picon-inhibit-top-level-domains t + "If non-nil, don't piconify top-level domains. +These are often not very interesting." + :type 'boolean :group 'gnus-picon) -;; backward-compatibility alias -(put 'gnus-picon-xbm-face 'face-alias 'gnus-picon-xbm) -(put 'gnus-picon-xbm-face 'obsolete-face "22.1") - -(defface gnus-picon '((t (:foreground "black" :background "white"))) - "Face to show picon in." - :group 'gnus-picon) -;; backward-compatibility alias -(put 'gnus-picon-face 'face-alias 'gnus-picon) -(put 'gnus-picon-face 'obsolete-face "22.1") ;;; Internal variables: -(defvar gnus-picon-setup-p nil) (defvar gnus-picon-glyph-alist nil "Picon glyphs cache. List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") @@ -166,7 +157,9 @@ replacement is added." (defun gnus-picon-create-glyph (file) (or (cdr (assoc file gnus-picon-glyph-alist)) - (cdar (push (cons file (gnus-create-image file)) + (cdar (push (cons file (gnus-create-image + file nil nil + :color-symbols '(("None" . "white")))) gnus-picon-glyph-alist)))) ;;; Functions that does picon transformations: @@ -201,7 +194,9 @@ replacement is added." (setcar spec (cons (gnus-picon-create-glyph file) (car spec)))) - (dotimes (i (1- (length spec))) + (dotimes (i (- (length spec) + (if gnus-picon-inhibit-top-level-domains + 2 1))) (when (setq file (gnus-picon-find-face (concat "unknown@" (mapconcat @@ -319,5 +314,4 @@ If picons are already displayed, remove them." (provide 'gnus-picon) -;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f ;;; gnus-picon.el ends here diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index 7e917c0395..b8696240b2 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -59,6 +59,36 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." (setq list2 (cdr list2))) list1)) +(defun gnus-range-nconcat (&rest ranges) + "Return a range comprising all the RANGES, which are pre-sorted. +RANGES will be destructively altered." + (setq ranges (delete nil ranges)) + (let* ((result (gnus-range-normalize (pop ranges))) + (last (last result))) + (dolist (range ranges) + (setq range (gnus-range-normalize range)) + ;; Normalize the single-number case, so that we don't need to + ;; special-case that so much. + (when (numberp (car last)) + (setcar last (cons (car last) (car last)))) + (when (numberp (car range)) + (setcar range (cons (car range) (car range)))) + (if (= (1+ (cdar last)) (caar range)) + (progn + (setcdr (car last) (cdar range)) + (setcdr last (cdr range))) + (setcdr last range) + ;; Denormalize back, since we couldn't join the ranges up. + (when (= (caar range) (cdar range)) + (setcar range (caar range))) + (when (= (caar last) (cdar last)) + (setcar last (caar last)))) + (setq last (last last))) + (if (and (consp (car result)) + (= (length result) 1)) + (car result) + result))) + (defun gnus-range-difference (range1 range2) "Return the range of elements in RANGE1 that do not appear in RANGE2. Both ranges must be in ascending order." @@ -187,7 +217,7 @@ LIST1 and LIST2 have to be sorted over <." RANGE1 and RANGE2 have to be sorted over <." (let* (out (min1 (car range1)) - (max1 (if (numberp min1) + (max1 (if (numberp min1) (if (numberp (cdr range1)) (prog1 (cdr range1) (setq range1 nil)) min1) @@ -196,8 +226,8 @@ RANGE1 and RANGE2 have to be sorted over <." (min2 (car range2)) (max2 (if (numberp min2) (if (numberp (cdr range2)) - (prog1 (cdr range2) - (setq range2 nil)) min2) + (prog1 (cdr range2) + (setq range2 nil)) min2) (prog1 (cdr min2) (setq min2 (car min2)))))) (setq range1 (cdr range1) @@ -654,5 +684,4 @@ LIST is a sorted list." (provide 'gnus-range) -;; arch-tag: 4780bdd8-5a15-4aff-be28-18727895b6ad ;;; gnus-range.el ends here diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 0f7071f821..69d5c05432 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -45,6 +45,9 @@ ;; (: gnus-registry-split-fancy-with-parent) +;; You should also consider using the nnregistry backend to look up +;; articles. See the Gnus manual for more information. + ;; TODO: ;; - get the correct group on spool actions @@ -60,6 +63,7 @@ (require 'gnus-sum) (require 'gnus-util) (require 'nnmail) +(require 'easymenu) (defvar gnus-adaptive-word-syntax-table) @@ -71,7 +75,7 @@ :version "22.1" :group 'gnus) -(defvar gnus-registry-hashtb (make-hash-table +(defvar gnus-registry-hashtb (make-hash-table :size 256 :test 'equal) "*The article registry by Message ID.") @@ -96,7 +100,7 @@ "List of registry marks and their options. `gnus-registry-mark-article' will offer symbols from this list -for completion. +for completion. Each entry must have a character to be useful for summary mode line display and for keyboard shortcuts. @@ -120,13 +124,15 @@ display." :group 'gnus-registry :type 'symbol) -(defcustom gnus-registry-unfollowed-groups - '("delayed$" "drafts$" "queue$" "INBOX$") +(defcustom gnus-registry-unfollowed-groups + '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:") "List of groups that gnus-registry-split-fancy-with-parent won't return. The group names are matched, they don't have to be fully qualified. This parameter tells the Registry 'never split a message into a group that matches one of these, regardless of -references.'" +references.' + +nnmairix groups are specifically excluded because they are ephemeral." :group 'gnus-registry :type '(repeat regexp)) @@ -137,6 +143,10 @@ references.'" (const :tag "Always Install" t) (const :tag "Ask Me" ask))) +(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. + +(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus + (defcustom gnus-registry-clean-empty t "Whether the empty registry entries should be deleted. Registry entries are considered empty when they have no groups @@ -201,9 +211,9 @@ considered precious) will not be trimmed." :group 'gnus-registry :type '(repeat symbol)) -(defcustom gnus-registry-cache-file - (nnheader-concat - (or gnus-dribble-directory gnus-home-directory "~/") +(defcustom gnus-registry-cache-file + (nnheader-concat + (or gnus-dribble-directory gnus-home-directory "~/") ".gnus.registry.eld") "File where the Gnus registry will be stored." :group 'gnus-registry @@ -236,8 +246,7 @@ considered precious) will not be trimmed." "Save the registry cache file." (interactive) (let ((file gnus-registry-cache-file)) - (save-excursion - (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) + (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*") (make-local-variable 'version-control) (setq version-control gnus-backup-startup-file) (setq buffer-file-name file) @@ -248,7 +257,7 @@ considered precious) will not be trimmed." (if gnus-save-startup-file-via-temp-buffer (let ((coding-system-for-write gnus-ding-file-coding-system) (standard-output (current-buffer))) - (gnus-gnus-to-quick-newsrc-format + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) (gnus-registry-cache-whitespace file) (save-buffer)) @@ -271,7 +280,7 @@ considered precious) will not be trimmed." (unwind-protect (progn (gnus-with-output-to-file working-file - (gnus-gnus-to-quick-newsrc-format + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) ;; These bindings will mislead the current buffer @@ -321,7 +330,7 @@ considered precious) will not be trimmed." (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) ;; now trim and clean text properties from the registry appropriately - (setq gnus-registry-alist + (setq gnus-registry-alist (gnus-registry-remove-alist-text-properties (gnus-registry-trim (gnus-hashtable-to-alist @@ -341,7 +350,7 @@ considered precious) will not be trimmed." (dolist (group (gnus-registry-fetch-groups key)) (when (gnus-parameter-registry-ignore group) (gnus-message - 10 + 10 "gnus-registry: deleted ignored group %s from key %s" group key) (gnus-registry-delete-group key group))) @@ -356,14 +365,14 @@ considered precious) will not be trimmed." (gnus-registry-fetch-extra key 'label)) (incf count) (gnus-registry-delete-id key)) - + (unless (stringp key) - (gnus-message - 10 - "gnus-registry key %s was not a string, removing" + (gnus-message + 10 + "gnus-registry key %s was not a string, removing" key) (gnus-registry-delete-id key)))) - + gnus-registry-hashtb) count)) @@ -386,7 +395,7 @@ considered precious) will not be trimmed." (defun gnus-registry-trim (alist) "Trim alist to size, using gnus-registry-max-entries. Any entries with extra data (marks, currently) are left alone." - (if (null gnus-registry-max-entries) + (if (null gnus-registry-max-entries) alist ; just return the alist ;; else, when given max-entries, trim the alist (let* ((timehash (make-hash-table @@ -415,25 +424,25 @@ Any entries with extra data (marks, currently) are left alone." (push item precious-list) (push item junk-list)))) - (sort + (sort junk-list (lambda (a b) - (let ((t1 (or (cdr (gethash (car a) timehash)) + (let ((t1 (or (cdr (gethash (car a) timehash)) '(0 0 0))) - (t2 (or (cdr (gethash (car b) timehash)) + (t2 (or (cdr (gethash (car b) timehash)) '(0 0 0)))) (time-less-p t1 t2)))) ;; we use the return value of this setq, which is the trimmed alist (setq alist (append precious-list (nthcdr trim-length junk-list)))))) - + (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (mail-header-subject data-header)))) - (sender (gnus-string-remove-all-properties + (sender (gnus-string-remove-all-properties (mail-header-from data-header))) (from (gnus-group-guess-full-name-from-command-method from)) (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) @@ -484,7 +493,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed (reply-to (message-fetch-field "in-reply-to")) ; may be nil ;; now, if reply-to is valid, append it to the References - (refstr (if reply-to + (refstr (if reply-to (concat refstr " " reply-to) refstr)) ;; these may not be used, but the code is cleaner having them up here @@ -512,8 +521,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 9 "%s is looking for matches for reference %s from [%s]" log-agent reference refstr) - (dolist (group (gnus-registry-fetch-groups - reference + (dolist (group (gnus-registry-fetch-groups + reference gnus-registry-max-track-groups)) (when (and group (gnus-registry-follow-group-p group)) (gnus-message @@ -523,9 +532,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (push group found)))) ;; filter the found groups and return them ;; the found groups are the full groups - (setq found (gnus-registry-post-process-groups + (setq found (gnus-registry-post-process-groups "references" refstr found found))) - + ;; else: there were no matches, now try the extra tracking by sender ((and (gnus-registry-track-sender-p) sender @@ -538,12 +547,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." matches) (when (and this-sender (equal sender this-sender)) - (let ((groups (gnus-registry-fetch-groups + (let ((groups (gnus-registry-fetch-groups key gnus-registry-max-track-groups))) (dolist (group groups) - (push group found-full) - (setq found (append (list group) (delete group found))))) + (when (and group (gnus-registry-follow-group-p group)) + (push group found-full) + (setq found (append (list group) (delete group found)))))) (push key matches) (gnus-message ;; raise level of messaging if gnus-registry-track-extra @@ -553,9 +563,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." gnus-registry-hashtb) ;; filter the found groups and return them ;; the found groups are NOT the full groups - (setq found (gnus-registry-post-process-groups + (setq found (gnus-registry-post-process-groups "sender" sender found found-full))) - + ;; else: there were no matches, now try the extra tracking by subject ((and (gnus-registry-track-subject-p) subject @@ -567,12 +577,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." matches) (when (and this-subject (equal subject this-subject)) - (let ((groups (gnus-registry-fetch-groups + (let ((groups (gnus-registry-fetch-groups key gnus-registry-max-track-groups))) (dolist (group groups) - (push group found-full) - (setq found (append (list group) (delete group found))))) + (when (and group (gnus-registry-follow-group-p group)) + (push group found-full) + (setq found (append (list group) (delete group found)))))) (push key matches) (gnus-message ;; raise level of messaging if gnus-registry-track-extra @@ -582,7 +593,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." gnus-registry-hashtb) ;; filter the found groups and return them ;; the found groups are NOT the full groups - (setq found (gnus-registry-post-process-groups + (setq found (gnus-registry-post-process-groups "subject" subject found found-full)))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -622,7 +633,7 @@ necessary." (lambda (a b) (> (gethash a freq 0) (gethash b freq 0))))))))) - + (if gnus-registry-use-long-group-names (dolist (group groups) (let ((m1 (gnus-find-method-for-group group)) @@ -656,10 +667,10 @@ necessary." "Determines if a group name should be followed. Consults `gnus-registry-unfollowed-groups' and `nnmail-split-fancy-with-parent-ignore-groups'." - (not (or (gnus-registry-grep-in-list + (not (or (gnus-grep-in-list group gnus-registry-unfollowed-groups) - (gnus-registry-grep-in-list + (gnus-grep-in-list group nnmail-split-fancy-with-parent-ignore-groups)))) @@ -669,8 +680,7 @@ Consults `gnus-registry-unfollowed-groups' and word words) (if (or (not (gnus-registry-fetch-extra id 'keywords)) force) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (article-goto-body) (save-window-excursion (save-restriction @@ -703,8 +713,8 @@ Consults `gnus-registry-unfollowed-groups' and (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id)) (gnus-message 9 "Registry: Registering article %d with group %s" article gnus-newsgroup-name) - (gnus-registry-add-group - id + (gnus-registry-add-group + id gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) (gnus-registry-fetch-sender-fast article))))))) @@ -740,14 +750,6 @@ Consults `gnus-registry-unfollowed-groups' and (assoc article (gnus-data-list nil))))) nil)) -(defun gnus-registry-grep-in-list (word list) -"Find if a WORD matches any regular expression in the given LIST." - (when (and word list) - (catch 'found - (dolist (r list) - (when (string-match r word) - (throw 'found r)))))) - (defun gnus-registry-do-marks (type function) "For each known mark, call FUNCTION for each cell of type TYPE. @@ -764,7 +766,8 @@ FUNCTION should take two parameters, a mark symbol and the cell value." "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." (let (keys-plist) - (gnus-registry-do-marks + (setq gnus-registry-misc-menus nil) + (gnus-registry-do-marks :char (lambda (mark data) (let ((function-format @@ -785,20 +788,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (function-name (format function-format variant-name)) (shortcut (format "%c" data)) (shortcut (if remove (upcase shortcut) shortcut))) - (unintern function-name) + (unintern function-name obarray) (eval - `(defun + `(defun ;; function name - ,(intern function-name) + ,(intern function-name) ;; parameter definition (&rest articles) ;; documentation - ,(format + ,(format "%s the %s mark over process-marked ARTICLES." (upcase-initials variant-name) mark) ;; interactive definition - (interactive + (interactive (gnus-summary-work-articles current-prefix-arg)) ;; actual code @@ -809,34 +812,49 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; now the user is asked if gnus-registry-install is 'ask (when (gnus-registry-install-p) - (gnus-registry-set-article-mark-internal + (gnus-registry-set-article-mark-internal ;; all this just to get the mark, I must be doing it wrong (intern ,(symbol-name mark)) articles ,remove t) + (gnus-message + 9 + "Applying mark %s to %d articles" + ,(symbol-name mark) (length articles)) (dolist (article articles) - (gnus-summary-update-article - article + (gnus-summary-update-article + article (assoc article (gnus-data-list nil))))))) (push (intern function-name) keys-plist) (push shortcut keys-plist) - (gnus-message - 9 - "Defined mark handling function %s" + (push (vector (format "%s %s" + (upcase-initials variant-name) + (symbol-name mark)) + (intern function-name) t) + gnus-registry-misc-menus) + (gnus-message + 9 + "Defined mark handling function %s" function-name)))))) (gnus-define-keys-1 - '(gnus-registry-mark-map "M" gnus-summary-mark-map) - keys-plist))) + '(gnus-registry-mark-map "M" gnus-summary-mark-map) + keys-plist) + (add-hook 'gnus-summary-menu-hook + (lambda () + (easy-menu-add-item + gnus-summary-misc-menu + nil + (cons "Registry Marks" gnus-registry-misc-menus)))))) ;;; use like this: -;;; (defalias 'gnus-user-format-function-M +;;; (defalias 'gnus-user-format-function-M ;;; 'gnus-registry-user-format-function-M) (defun gnus-registry-user-format-function-M (headers) (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-fetch-extra-marks id)))) (apply 'concat (mapcar (lambda(mark) - (let ((c + (let ((c (plist-get - (cdr-safe + (cdr-safe (assoc mark gnus-registry-marks)) :char))) (if c @@ -846,12 +864,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (defun gnus-registry-read-mark () "Read a mark name from the user with completion." - (let ((mark (gnus-completing-read-with-default - (symbol-name gnus-registry-default-mark) - "Label" - (mapcar (lambda (x) ; completion list - (cons (symbol-name (car-safe x)) (car-safe x))) - gnus-registry-marks)))) + (let ((mark (gnus-completing-read + "Label" + (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + nil nil nil + (symbol-name gnus-registry-default-mark)))) (when (stringp mark) (intern mark)))) @@ -883,7 +900,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" (if remove "Removing" "Adding") mark id new-marks)) - + (apply 'gnus-registry-store-extra-marks ; set the extra marks id ; for the message ID new-marks))))) @@ -994,7 +1011,7 @@ The message must have at least one group name." "Put a specific entry in the extras field of the registry entry for id." (let* ((extra (gnus-registry-fetch-extra id)) ;; all the entries except the one for `key' - (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) + (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) (alist (if value (gnus-registry-remove-alist-text-properties (cons (cons key value) @@ -1021,7 +1038,7 @@ Returns the first place where the trail finds a group name." (dolist (crumb trail) (when (stringp crumb) ;; push the group name into the list - (setq + (setq groups (cons (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) @@ -1162,13 +1179,8 @@ Returns the first place where the trail finds a group name." ;;; we could call it here: (customize-variable 'gnus-registry-install) gnus-registry-install) -(when (or (eq gnus-registry-install t) - (gnus-registry-install-p)) - (gnus-registry-initialize)) - ;; TODO: a few things (provide 'gnus-registry) -;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 ;;; gnus-registry.el ends here diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index 422c260787..410772fcbd 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -26,6 +26,9 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus) (require 'gnus-sum) @@ -35,10 +38,6 @@ ;;; gnus-pick-mode ;;; -(defvar gnus-pick-mode nil - "Minor mode for providing a pick-and-read interface in Gnus -summary buffers.") - (defcustom gnus-pick-display-summary nil "*Display summary while reading." :type 'boolean @@ -72,17 +71,15 @@ It accepts the same format specs that `gnus-summary-line-format' does." ;;; Internal variables. -(defvar gnus-pick-mode-map nil) - -(unless gnus-pick-mode-map - (setq gnus-pick-mode-map (make-sparse-keymap)) - - (gnus-define-keys gnus-pick-mode-map - " " gnus-pick-next-page - "u" gnus-pick-unmark-article-or-thread - "." gnus-pick-article-or-thread - gnus-down-mouse-2 gnus-pick-mouse-pick-region - "\r" gnus-pick-start-reading)) +(defvar gnus-pick-mode-map + (let ((map (make-sparse-keymap))) + (gnus-define-keys map + " " gnus-pick-next-page + "u" gnus-pick-unmark-article-or-thread + "." gnus-pick-article-or-thread + gnus-down-mouse-2 gnus-pick-mouse-pick-region + "\r" gnus-pick-start-reading) + map)) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) @@ -104,30 +101,35 @@ It accepts the same format specs that `gnus-summary-line-format' does." ["Start reading" gnus-pick-start-reading t] ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) -(defun gnus-pick-mode (&optional arg) +(eval-when-compile + (when (featurep 'xemacs) + (defvar gnus-pick-mode-on-hook) + (defvar gnus-pick-mode-off-hook))) + +(define-minor-mode gnus-pick-mode "Minor mode for providing a pick-and-read interface in Gnus summary buffers. \\{gnus-pick-mode-map}" - (interactive "P") - (when (eq major-mode 'gnus-summary-mode) - (if (not (set (make-local-variable 'gnus-pick-mode) - (if (null arg) (not gnus-pick-mode) - (> (prefix-numeric-value arg) 0)))) - (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) - ;; Make sure that we don't select any articles upon group entry. - (set (make-local-variable 'gnus-auto-select-first) nil) - ;; Change line format. - (setq gnus-summary-line-format gnus-summary-pick-line-format) - (setq gnus-summary-line-format-spec nil) - (gnus-update-format-specifications nil 'summary) - (gnus-update-summary-mark-positions) - (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) - (set (make-local-variable 'gnus-summary-goto-unread) 'never) - ;; Set up the menu. - (when (gnus-visual-p 'pick-menu 'menu) - (gnus-pick-make-menu-bar)) - (add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) - (gnus-run-hooks 'gnus-pick-mode-hook)))) + :lighter " Pick" :keymap gnus-pick-mode-map + (cond + ((not (derived-mode-p 'gnus-summary-mode)) (setq gnus-pick-mode nil)) + ((not gnus-pick-mode) + ;; FIXME: a buffer-local minor mode removing globally from a hook?? + (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)) + (t + ;; Make sure that we don't select any articles upon group entry. + (set (make-local-variable 'gnus-auto-select-first) nil) + ;; Change line format. + (setq gnus-summary-line-format gnus-summary-pick-line-format) + (setq gnus-summary-line-format-spec nil) + (gnus-update-format-specifications nil 'summary) + (gnus-update-summary-mark-positions) + ;; FIXME: a buffer-local minor mode adding globally to a hook?? + (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) + (set (make-local-variable 'gnus-summary-goto-unread) 'never) + ;; Set up the menu. + (when (gnus-visual-p 'pick-menu 'menu) + (gnus-pick-make-menu-bar))))) (defun gnus-pick-setup-message () "Make Message do the right thing on exit." @@ -319,20 +321,14 @@ This must be bound to a button-down mouse event." ;;; gnus-binary-mode ;;; -(defvar gnus-binary-mode nil - "Minor mode for providing a binary group interface in Gnus summary buffers.") - (defvar gnus-binary-mode-hook nil "Hook run in summary binary mode buffers.") -(defvar gnus-binary-mode-map nil) - -(unless gnus-binary-mode-map - (setq gnus-binary-mode-map (make-sparse-keymap)) - - (gnus-define-keys - gnus-binary-mode-map - "g" gnus-binary-show-article)) +(defvar gnus-binary-mode-map + (let ((map (make-sparse-keymap))) + (gnus-define-keys map + "g" gnus-binary-show-article) + map)) (defun gnus-binary-make-menu-bar () (unless (boundp 'gnus-binary-menu) @@ -341,25 +337,25 @@ This must be bound to a button-down mouse event." '("Pick" ["Switch binary mode off" gnus-binary-mode t])))) -(defun gnus-binary-mode (&optional arg) +(eval-when-compile + (when (featurep 'xemacs) + (defvar gnus-binary-mode-on-hook) + (defvar gnus-binary-mode-off-hook))) + +(define-minor-mode gnus-binary-mode "Minor mode for providing a binary group interface in Gnus summary buffers." - (interactive "P") - (when (eq major-mode 'gnus-summary-mode) - (make-local-variable 'gnus-binary-mode) - (setq gnus-binary-mode - (if (null arg) (not gnus-binary-mode) - (> (prefix-numeric-value arg) 0))) - (when gnus-binary-mode - ;; Make sure that we don't select any articles upon group entry. - (make-local-variable 'gnus-auto-select-first) - (setq gnus-auto-select-first nil) - (make-local-variable 'gnus-summary-display-article-function) - (setq gnus-summary-display-article-function 'gnus-binary-display-article) - ;; Set up the menu. - (when (gnus-visual-p 'binary-menu 'menu) - (gnus-binary-make-menu-bar)) - (add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) - (gnus-run-hooks 'gnus-binary-mode-hook)))) + :lighter " Binary" :keymap gnus-binary-mode-map + (cond + ((not (derived-mode-p 'gnus-summary-mode)) (setq gnus-binary-mode nil)) + (gnus-binary-mode + ;; Make sure that we don't select any articles upon group entry. + (make-local-variable 'gnus-auto-select-first) + (setq gnus-auto-select-first nil) + (make-local-variable 'gnus-summary-display-article-function) + (setq gnus-summary-display-article-function 'gnus-binary-display-article) + ;; Set up the menu. + (when (gnus-visual-p 'binary-menu 'menu) + (gnus-binary-make-menu-bar))))) (defun gnus-binary-display-article (article &optional all-header) "Run ARTICLE through the binary decode functions." @@ -873,181 +869,9 @@ Two predefined functions are available: (set-window-point (gnus-get-buffer-window (current-buffer) t) (cdr region)))))) -;;; -;;; gnus-carpal -;;; - -(defvar gnus-carpal-group-buffer-buttons - '(("next" . gnus-group-next-unread-group) - ("prev" . gnus-group-prev-unread-group) - ("read" . gnus-group-read-group) - ("select" . gnus-group-select-group) - ("catch-up" . gnus-group-catchup-current) - ("new-news" . gnus-group-get-new-news-this-group) - ("toggle-sub" . gnus-group-unsubscribe-current-group) - ("subscribe" . gnus-group-unsubscribe-group) - ("kill" . gnus-group-kill-group) - ("yank" . gnus-group-yank-group) - ("describe" . gnus-group-describe-group) - "list" - ("subscribed" . gnus-group-list-groups) - ("all" . gnus-group-list-all-groups) - ("killed" . gnus-group-list-killed) - ("zombies" . gnus-group-list-zombies) - ("matching" . gnus-group-list-matching) - ("post" . gnus-group-post-news) - ("mail" . gnus-group-mail) - ("local" . (lambda () (interactive) (gnus-group-news 0))) - ("rescan" . gnus-group-get-new-news) - ("browse-foreign" . gnus-group-browse-foreign) - ("exit" . gnus-group-exit))) - -(defvar gnus-carpal-summary-buffer-buttons - '("mark" - ("read" . gnus-summary-mark-as-read-forward) - ("tick" . gnus-summary-tick-article-forward) - ("clear" . gnus-summary-clear-mark-forward) - ("expirable" . gnus-summary-mark-as-expirable) - "move" - ("scroll" . gnus-summary-next-page) - ("next-unread" . gnus-summary-next-unread-article) - ("prev-unread" . gnus-summary-prev-unread-article) - ("first" . gnus-summary-first-unread-article) - ("best" . gnus-summary-best-unread-article) - "article" - ("headers" . gnus-summary-toggle-header) - ("uudecode" . gnus-uu-decode-uu) - ("enter-digest" . gnus-summary-enter-digest-group) - ("fetch-parent" . gnus-summary-refer-parent-article) - "mail" - ("move" . gnus-summary-move-article) - ("copy" . gnus-summary-copy-article) - ("respool" . gnus-summary-respool-article) - "threads" - ("lower" . gnus-summary-lower-thread) - ("kill" . gnus-summary-kill-thread) - "post" - ("post" . gnus-summary-post-news) - ("local" . gnus-summary-news-other-window) - ("mail" . gnus-summary-mail-other-window) - ("followup" . gnus-summary-followup-with-original) - ("reply" . gnus-summary-reply-with-original) - ("cancel" . gnus-summary-cancel-article) - "misc" - ("exit" . gnus-summary-exit) - ("fed-up" . gnus-summary-catchup-and-goto-next-group))) - -(defvar gnus-carpal-server-buffer-buttons - '(("add" . gnus-server-add-server) - ("browse" . gnus-server-browse-server) - ("list" . gnus-server-list-servers) - ("kill" . gnus-server-kill-server) - ("yank" . gnus-server-yank-server) - ("copy" . gnus-server-copy-server) - ("exit" . gnus-server-exit))) - -(defvar gnus-carpal-browse-buffer-buttons - '(("subscribe" . gnus-browse-unsubscribe-current-group) - ("exit" . gnus-browse-exit))) - -(defvar gnus-carpal-group-buffer "*Carpal Group*") -(defvar gnus-carpal-summary-buffer "*Carpal Summary*") -(defvar gnus-carpal-server-buffer "*Carpal Server*") -(defvar gnus-carpal-browse-buffer "*Carpal Browse*") - -(defvar gnus-carpal-attached-buffer nil) - -(defvar gnus-carpal-mode-hook nil - "*Hook run in carpal mode buffers.") - -(defvar gnus-carpal-button-face 'bold - "*Face used on carpal buttons.") - -(defvar gnus-carpal-header-face 'bold-italic - "*Face used on carpal buffer headers.") - -(defvar gnus-carpal-mode-map nil) -(put 'gnus-carpal-mode 'mode-class 'special) - -(if gnus-carpal-mode-map - nil - (setq gnus-carpal-mode-map (make-keymap)) - (suppress-keymap gnus-carpal-mode-map) - (define-key gnus-carpal-mode-map " " 'gnus-carpal-select) - (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select) - (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select)) - -(defun gnus-carpal-mode () - "Major mode for clicking buttons. - -All normal editing commands are switched off. -\\<gnus-carpal-mode-map> -The following commands are available: - -\\{gnus-carpal-mode-map}" - (interactive) - (kill-all-local-variables) - (setq mode-line-modified (cdr gnus-mode-line-modified)) - (setq major-mode 'gnus-carpal-mode) - (setq mode-name "Gnus Carpal") - (setq mode-line-process nil) - (use-local-map gnus-carpal-mode-map) - (buffer-disable-undo) - (setq buffer-read-only t) - (make-local-variable 'gnus-carpal-attached-buffer) - (gnus-run-mode-hooks 'gnus-carpal-mode-hook)) - -(defun gnus-carpal-setup-buffer (type) - (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) - (if (get-buffer buffer) - () - (with-current-buffer (gnus-get-buffer-create buffer) - (gnus-carpal-mode) - (setq gnus-carpal-attached-buffer - (intern (format "gnus-%s-buffer" type))) - (let ((buttons (symbol-value - (intern (format "gnus-carpal-%s-buffer-buttons" - type)))) - (buffer-read-only nil) - button) - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (if (stringp button) - (set-text-properties - (point) - (prog2 (insert button) (point) (insert " ")) - (list 'face gnus-carpal-header-face)) - (set-text-properties - (point) - (prog2 (insert (car button)) (point) (insert " ")) - (list 'gnus-callback (cdr button) - 'face gnus-carpal-button-face - gnus-mouse-face-prop 'highlight)))) - (let ((fill-column (- (window-width) 2))) - (fill-region (point-min) (point-max))) - (set-window-point (get-buffer-window (current-buffer)) - (point-min))))))) - -(defun gnus-carpal-select () - "Select the button under point." - (interactive) - (let ((func (get-text-property (point) 'gnus-callback))) - (if (null func) - () - (pop-to-buffer (symbol-value gnus-carpal-attached-buffer)) - (call-interactively func)))) - -(defun gnus-carpal-mouse-select (event) - "Select the button under the mouse pointer." - (interactive "e") - (mouse-set-point event) - (gnus-carpal-select)) - ;;; Allow redefinition of functions. (gnus-ems-redefine) (provide 'gnus-salt) -;; arch-tag: 35449164-77b3-4398-bcbd-a2e3e998f810 ;;; gnus-salt.el ends here diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 795fcff2fb..096bc5b635 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -680,14 +680,14 @@ file for the command instead of the current score file." (and gnus-extra-headers (equal (nth 1 entry) "extra") (intern ; need symbol - (gnus-completing-read-with-default - (symbol-name (car gnus-extra-headers)) ; default response - "Score extra header" ; prompt - (mapcar (lambda (x) ; completion list - (cons (symbol-name x) x)) - gnus-extra-headers) - nil ; no completion limit - t)))) ; require match + (let ((collection (mapcar 'symbol-name gnus-extra-headers))) + (gnus-completing-read + "Score extra header" ; prompt + collection ; completion list + t ; require match + nil ; no history + nil ; no initial-input + (car collection)))))) ; default value ;; extra is now nil or a symbol. ;; We have all the data, so we enter this score. @@ -708,8 +708,7 @@ file for the command instead of the current score file." ;; Change score file to the "all.SCORE" file. (when (eq symp 'a) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file ;; This is a kludge; yes... (cond @@ -735,14 +734,12 @@ file for the command instead of the current score file." (when (eq symp 'a) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file))))) (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Score Help*")) + (with-current-buffer (gnus-get-buffer-create "*Score Help*") (buffer-disable-undo) (delete-windows-on (current-buffer)) (erase-buffer) @@ -916,10 +913,13 @@ MATCH is the string we are looking for. TYPE is the score type. SCORE is the score to add. EXTRA is the possible non-standard header." - (interactive (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) + (interactive (list (gnus-completing-read "Header" + (mapcar + 'car + (gnus-remove-if-not + (lambda (x) (fboundp (nth 2 x))) + gnus-header-index)) + t) (read-string "Match: ") (if (y-or-n-p "Use regexp match? ") 'r 's) (string-to-number (read-string "Score: ")))) @@ -1117,8 +1117,8 @@ EXTRA is the possible non-standard header." (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))) + 4 "%s" (substitute-command-keys + "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))) (defun gnus-score-edit-all-score () "Edit the all.SCORE file." @@ -1145,8 +1145,8 @@ EXTRA is the possible non-standard header." (make-local-variable 'gnus-prev-winconf) (setq gnus-prev-winconf winconf)) (gnus-message - 4 (substitute-command-keys - "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) + 4 "%s" (substitute-command-keys + "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) (defun gnus-score-edit-file-at-point (&optional format) "Edit score file at point in Score Trace buffers. @@ -1270,8 +1270,7 @@ If FORMAT, also format the current score file." exclude-files)) gnus-scores-exclude-files)) (when local - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (while local (and (consp (car local)) (symbolp (caar local)) @@ -1395,7 +1394,7 @@ If FORMAT, also format the current score file." (if err (progn (ding) - (gnus-message 3 err) + (gnus-message 3 "%s" err) (sit-for 2) nil) alist))))) @@ -1528,8 +1527,7 @@ If FORMAT, also format the current score file." (cons (cons header (or gnus-summary-default-score 0)) gnus-scores-articles)))) - (save-excursion - (set-buffer (gnus-get-buffer-create "*Headers*")) + (with-current-buffer (gnus-get-buffer-create "*Headers*") (buffer-disable-undo) (when (gnus-buffer-live-p gnus-summary-buffer) (message-clone-locals gnus-summary-buffer)) @@ -1854,8 +1852,7 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Change score file to the adaptive score file. All entries that ;; this function makes will be put into this file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-score-file-name @@ -1946,15 +1943,13 @@ score in `gnus-newsgroup-scored' by SCORE." (setq rest entries))) (setq entries rest)))) ;; We change the score file back to the previous one. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file)) (list (cons "references" news))))) (defun gnus-score-add-followups (header score scores &optional thread) "Add a score entry to the adapt file." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let* ((id (mail-header-id header)) (scores (car scores)) entry dont) @@ -2055,8 +2050,11 @@ score in `gnus-newsgroup-scored' by SCORE." ;; Evil hackery to make match usable in non-standard headers. (when extra - (setq match (concat "[ (](" extra " \\. \"[^)]*" - match "[^\"]*\")[ )]") + (setq match (concat "[ (](" extra " \\. \"\\([^\"]*\\\\\"\\)*[^\"]*" + (if (eq search-func 're-search-forward) + match + (regexp-quote match)) + "\\([^\"]*\\\\\"\\)*[^\"]*\")[ )]") search-func 're-search-forward)) ; XXX danger?!? (cond @@ -2279,8 +2277,7 @@ score in `gnus-newsgroup-scored' by SCORE." "Create adaptive score rules for this newsgroup." (when gnus-newsgroup-adaptive ;; We change the score file to the adaptive score file. - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-score-load-file (or gnus-newsgroup-adaptive-score-file (gnus-home-score-file gnus-newsgroup-name t) @@ -2694,8 +2691,7 @@ GROUP using BNews sys file syntax." (trans (cdr (assq ?: nnheader-file-name-translation-alist))) (group-trans (nnheader-translate-file-chars group t)) ofiles not-match regexp) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus score files*")) + (with-current-buffer (gnus-get-buffer-create "*gnus score files*") (buffer-disable-undo) ;; Go through all score file names and create regexp with them ;; as the source. @@ -3119,5 +3115,4 @@ See Info node `(gnus)Scoring Tips' for examples of good regular expressions." (provide 'gnus-score) -;; arch-tag: d3922589-764d-46ae-9954-9330fd192634 ;;; gnus-score.el ends here diff --git a/lisp/gnus/gnus-setup.el b/lisp/gnus/gnus-setup.el index a2e6dff975..4b7d210418 100644 --- a/lisp/gnus/gnus-setup.el +++ b/lisp/gnus/gnus-setup.el @@ -189,5 +189,4 @@ score the alt hierarchy, you'd say \"!alt.all\"." t nil)) (run-hooks 'gnus-setup-load-hook) -;; arch-tag: 08e4af93-8565-46bf-905c-36229400609d ;;; gnus-setup.el ends here diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el index b3c67e74a9..d76e63900e 100644 --- a/lisp/gnus/gnus-sieve.el +++ b/lisp/gnus/gnus-sieve.el @@ -235,5 +235,4 @@ This is returned as a string." (provide 'gnus-sieve) -;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3 ;;; gnus-sieve.el ends here diff --git a/lisp/gnus/gnus-soup.el b/lisp/gnus/gnus-soup.el deleted file mode 100644 index e8b9cc35f8..0000000000 --- a/lisp/gnus/gnus-soup.el +++ /dev/null @@ -1,611 +0,0 @@ -;;; gnus-soup.el --- SOUP packet writing support for Gnus - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Per Abrahamsen <[email protected]> -;; Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'gnus) -(require 'gnus-art) -(require 'message) -(require 'gnus-start) -(require 'gnus-range) - -(defgroup gnus-soup nil - "SOUP packet writing support for Gnus." - :group 'gnus) - -;;; User Variables: - -(defcustom gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/") - "Directory containing an unpacked SOUP packet." - :version "22.1" ;; Gnus 5.10.9 - :type 'directory - :group 'gnus-soup) - -(defcustom gnus-soup-replies-directory - (nnheader-concat gnus-soup-directory "SoupReplies/") - "Directory where Gnus will do processing of replies." - :version "22.1" ;; Gnus 5.10.9 - :type 'directory - :group 'gnus-soup) - -(defcustom gnus-soup-prefix-file "gnus-prefix" - "Name of the file where Gnus stores the last used prefix." - :version "22.1" ;; Gnus 5.10.9 - :type 'file - :group 'gnus-soup) - -(defcustom gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz" - "Format string command for packing a SOUP packet. -The SOUP files will be inserted where the %s is in the string. -This string MUST contain both %s and %d. The file number will be -inserted where %d appears." - :version "22.1" ;; Gnus 5.10.9 - :type 'string - :group 'gnus-soup) - -(defcustom gnus-soup-unpacker "gunzip -c %s | tar xvf -" - "Format string command for unpacking a SOUP packet. -The SOUP packet file name will be inserted at the %s." - :version "22.1" ;; Gnus 5.10.9 - :type 'string - :group 'gnus-soup) - -(defcustom gnus-soup-packet-directory gnus-home-directory - "Where gnus-soup will look for REPLIES packets." - :version "22.1" ;; Gnus 5.10.9 - :type 'directory - :group 'gnus-soup) - -(defcustom gnus-soup-packet-regexp "Soupin" - "Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'." - :version "22.1" ;; Gnus 5.10.9 - :type 'regexp - :group 'gnus-soup) - -(defcustom gnus-soup-ignored-headers "^Xref:" - "Regexp to match headers to be removed when brewing SOUP packets." - :version "22.1" ;; Gnus 5.10.9 - :type 'regexp - :group 'gnus-soup) - -;;; Internal Variables: - -(defvar gnus-soup-encoding-type ?u - "*Soup encoding type. -`u' is USENET news format, `m' is Unix mbox format, and `M' is MMDF mailbox -format.") - -(defvar gnus-soup-index-type ?c - "*Soup index type. -`n' means no index file and `c' means standard Cnews overview -format.") - -(defvar gnus-soup-areas nil) -(defvar gnus-soup-last-prefix nil) -(defvar gnus-soup-prev-prefix nil) -(defvar gnus-soup-buffers nil) - -;;; Access macros: - -(defmacro gnus-soup-area-prefix (area) - `(aref ,area 0)) -(defmacro gnus-soup-set-area-prefix (area prefix) - `(aset ,area 0 ,prefix)) -(defmacro gnus-soup-area-name (area) - `(aref ,area 1)) -(defmacro gnus-soup-area-encoding (area) - `(aref ,area 2)) -(defmacro gnus-soup-area-description (area) - `(aref ,area 3)) -(defmacro gnus-soup-area-number (area) - `(aref ,area 4)) -(defmacro gnus-soup-area-set-number (area value) - `(aset ,area 4 ,value)) - -(defmacro gnus-soup-encoding-format (encoding) - `(aref ,encoding 0)) -(defmacro gnus-soup-encoding-index (encoding) - `(aref ,encoding 1)) -(defmacro gnus-soup-encoding-kind (encoding) - `(aref ,encoding 2)) - -(defmacro gnus-soup-reply-prefix (reply) - `(aref ,reply 0)) -(defmacro gnus-soup-reply-kind (reply) - `(aref ,reply 1)) -(defmacro gnus-soup-reply-encoding (reply) - `(aref ,reply 2)) - -;;; Commands: - -(defun gnus-soup-send-replies () - "Unpack and send all replies in the reply packet." - (interactive) - (let ((packets (directory-files - gnus-soup-packet-directory t gnus-soup-packet-regexp))) - (while packets - (when (gnus-soup-send-packet (car packets)) - (delete-file (car packets))) - (setq packets (cdr packets))))) - -(defun gnus-soup-add-article (n) - "Add the current article to SOUP packet. -If N is a positive number, add the N next articles. -If N is a negative number, add the N previous articles. -If N is nil and any articles have been marked with the process mark, -move those articles instead." - (interactive "P") - (let* ((articles (gnus-summary-work-articles n)) - (tmp-buf (gnus-get-buffer-create "*soup work*")) - (area (gnus-soup-area gnus-newsgroup-name)) - (prefix (gnus-soup-area-prefix area)) - headers) - (buffer-disable-undo tmp-buf) - (save-excursion - (while articles - ;; Put the article in a buffer. - (set-buffer tmp-buf) - (when (gnus-request-article-this-buffer - (car articles) gnus-newsgroup-name) - (setq headers (nnheader-parse-head t)) - (save-restriction - (message-narrow-to-head) - (message-remove-header gnus-soup-ignored-headers t)) - (gnus-soup-store gnus-soup-directory prefix headers - gnus-soup-encoding-type - gnus-soup-index-type) - (gnus-soup-area-set-number - area (1+ (or (gnus-soup-area-number area) 0))) - ;; Mark article as read. - (set-buffer gnus-summary-buffer) - (gnus-summary-mark-as-read (car articles) gnus-souped-mark)) - (gnus-summary-remove-process-mark (car articles)) - (setq articles (cdr articles))) - (kill-buffer tmp-buf)) - (gnus-soup-save-areas) - (gnus-set-mode-line 'summary))) - -(defun gnus-soup-pack-packet () - "Make a SOUP packet from the SOUP areas." - (interactive) - (gnus-soup-read-areas) - (if (file-exists-p gnus-soup-directory) - (if (directory-files gnus-soup-directory nil "\\.MSG$") - (gnus-soup-pack gnus-soup-directory gnus-soup-packer) - (message "No files to pack.")) - (message "No such directory: %s" gnus-soup-directory))) - -(defun gnus-group-brew-soup (n) - "Make a soup packet from the current group. -Uses the process/prefix convention." - (interactive "P") - (let ((groups (gnus-group-process-prefix n))) - (while groups - (gnus-group-remove-mark (car groups)) - (gnus-soup-group-brew (car groups) t) - (setq groups (cdr groups))) - (gnus-soup-save-areas))) - -(defun gnus-brew-soup (&optional level) - "Go through all groups on LEVEL or less and make a soup packet." - (interactive "P") - (let ((level (or level gnus-level-subscribed)) - (newsrc (cdr gnus-newsrc-alist))) - (while newsrc - (when (<= (nth 1 (car newsrc)) level) - (gnus-soup-group-brew (caar newsrc) t)) - (setq newsrc (cdr newsrc))) - (gnus-soup-save-areas))) - -;;;###autoload -(defun gnus-batch-brew-soup () - "Brew a SOUP packet from groups mention on the command line. -Will use the remaining command line arguments as regular expressions -for matching on group names. - -For instance, if you want to brew on all the nnml groups, as well as -groups with \"emacs\" in the name, you could say something like: - -$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\" - -Note -- this function hasn't been implemented yet." - (interactive) - nil) - -;;; Internal Functions: - -;; Store the current buffer. -(defun gnus-soup-store (directory prefix headers format index) - ;; Create the directory, if needed. - (gnus-make-directory directory) - (let* ((msg-buf (nnheader-find-file-noselect - (concat directory prefix ".MSG"))) - (idx-buf (if (= index ?n) - nil - (nnheader-find-file-noselect - (concat directory prefix ".IDX")))) - (article-buf (current-buffer)) - from head-line beg type) - (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers))) - (buffer-disable-undo msg-buf) - (when idx-buf - (push idx-buf gnus-soup-buffers) - (buffer-disable-undo idx-buf)) - (save-excursion - ;; Make sure the last char in the buffer is a newline. - (goto-char (point-max)) - (unless (= (current-column) 0) - (insert "\n")) - ;; Find the "from". - (goto-char (point-min)) - (setq from - (gnus-mail-strip-quoted-names - (or (mail-fetch-field "from") - (mail-fetch-field "really-from") - (mail-fetch-field "sender")))) - (goto-char (point-min)) - ;; Depending on what encoding is supposed to be used, we make - ;; a soup header. - (setq head-line - (cond - ((or (= gnus-soup-encoding-type ?u) - (= gnus-soup-encoding-type ?n)) ;;Gnus back compatibility. - (format "#! rnews %d\n" (buffer-size))) - ((= gnus-soup-encoding-type ?m) - (while (search-forward "\nFrom " nil t) - (replace-match "\n>From " t t)) - (concat "From " (or from "unknown") - " " (current-time-string) "\n")) - ((= gnus-soup-encoding-type ?M) - "\^a\^a\^a\^a\n") - (t (error "Unsupported type: %c" gnus-soup-encoding-type)))) - ;; Insert the soup header and the article in the MSG buf. - (set-buffer msg-buf) - (goto-char (point-max)) - (insert head-line) - (setq beg (point)) - (insert-buffer-substring article-buf) - ;; Insert the index in the IDX buf. - (cond ((= index ?c) - (set-buffer idx-buf) - (gnus-soup-insert-idx beg headers)) - ((/= index ?n) - (error "Unknown index type: %c" type))) - ;; Return the MSG buf. - msg-buf))) - -(defun gnus-soup-group-brew (group &optional not-all) - "Enter GROUP and add all articles to a SOUP package. -If NOT-ALL, don't pack ticked articles." - (let ((gnus-expert-user t) - (gnus-large-newsgroup nil) - (entry (gnus-group-entry group))) - (when (or (null entry) - (eq (car entry) t) - (and (car entry) - (> (car entry) 0)) - (and (not not-all) - (gnus-range-length (cdr (assq 'tick (gnus-info-marks - (nth 2 entry))))))) - (when (gnus-summary-read-group group nil t) - (setq gnus-newsgroup-processable - (reverse - (if (not not-all) - (append gnus-newsgroup-marked gnus-newsgroup-unreads) - gnus-newsgroup-unreads))) - (gnus-soup-add-article nil) - (gnus-summary-exit))))) - -(defun gnus-soup-insert-idx (offset header) - ;; [number subject from date id references chars lines xref] - (goto-char (point-max)) - (insert - (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n" - offset - (or (mail-header-subject header) "(none)") - (or (mail-header-from header) "(nobody)") - (or (mail-header-date header) "") - (or (mail-header-id header) - (concat "soup-dummy-id-" - (mapconcat - (lambda (time) (int-to-string time)) - (current-time) "-"))) - (or (mail-header-references header) "") - (or (mail-header-chars header) 0) - (or (mail-header-lines header) "0")))) - -(defun gnus-soup-save-areas () - "Write all SOUP buffers." - (interactive) - (gnus-soup-write-areas) - (save-excursion - (let (buf) - (while gnus-soup-buffers - (setq buf (car gnus-soup-buffers) - gnus-soup-buffers (cdr gnus-soup-buffers)) - (if (not (buffer-name buf)) - () - (set-buffer buf) - (when (buffer-modified-p) - (save-buffer)) - (kill-buffer (current-buffer))))) - (gnus-soup-write-prefixes))) - -(defun gnus-soup-write-prefixes () - (let ((prefixes gnus-soup-last-prefix) - prefix) - (save-excursion - (gnus-set-work-buffer) - (while (setq prefix (pop prefixes)) - (erase-buffer) - (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) - (let ((coding-system-for-write mm-text-coding-system)) - (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file))))))) - -(defun gnus-soup-pack (dir packer) - (let* ((files (mapconcat 'identity - '("AREAS" "*.MSG" "*.IDX" "INFO" - "LIST" "REPLIES" "COMMANDS" "ERRORS") - " ")) - (packer (if (< (string-match "%s" packer) - (string-match "%d" packer)) - (format packer files - (string-to-number (gnus-soup-unique-prefix dir))) - (format packer - (string-to-number (gnus-soup-unique-prefix dir)) - files))) - (dir (expand-file-name dir))) - (gnus-make-directory dir) - (setq gnus-soup-areas nil) - (gnus-message 4 "Packing %s..." packer) - (if (eq 0 (call-process shell-file-name - nil nil nil shell-command-switch - (concat "cd " dir " ; " packer))) - (progn - (call-process shell-file-name nil nil nil shell-command-switch - (concat "cd " dir " ; rm " files)) - (gnus-message 4 "Packing...done" packer)) - (error "Couldn't pack packet")))) - -(defun gnus-soup-parse-areas (file) - "Parse soup area file FILE. -The result is a of vectors, each containing one entry from the AREA file. -The vector contain five strings, - [prefix name encoding description number] -though the two last may be nil if they are missing." - (let (areas) - (when (file-exists-p file) - (save-excursion - (set-buffer (nnheader-find-file-noselect file 'force)) - (buffer-disable-undo) - (goto-char (point-min)) - (while (not (eobp)) - (push (vector (gnus-soup-field) - (gnus-soup-field) - (gnus-soup-field) - (and (eq (preceding-char) ?\t) - (gnus-soup-field)) - (and (eq (preceding-char) ?\t) - (string-to-number (gnus-soup-field)))) - areas) - (when (eq (preceding-char) ?\t) - (beginning-of-line 2))) - (kill-buffer (current-buffer)))) - areas)) - -(defun gnus-soup-parse-replies (file) - "Parse soup REPLIES file FILE. -The result is a of vectors, each containing one entry from the REPLIES -file. The vector contain three strings, [prefix name encoding]." - (let (replies) - (save-excursion - (set-buffer (nnheader-find-file-noselect file)) - (buffer-disable-undo) - (goto-char (point-min)) - (while (not (eobp)) - (push (vector (gnus-soup-field) (gnus-soup-field) - (gnus-soup-field)) - replies) - (when (eq (preceding-char) ?\t) - (beginning-of-line 2))) - (kill-buffer (current-buffer))) - replies)) - -(defun gnus-soup-field () - (prog1 - (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point))) - (forward-char 1))) - -(defun gnus-soup-read-areas () - (or gnus-soup-areas - (setq gnus-soup-areas - (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS"))))) - -(defun gnus-soup-write-areas () - "Write the AREAS file." - (interactive) - (when gnus-soup-areas - (with-temp-file (concat gnus-soup-directory "AREAS") - (let ((areas gnus-soup-areas) - area) - (while (setq area (pop areas)) - (insert - (format - "%s\t%s\t%s%s\n" - (gnus-soup-area-prefix area) - (gnus-soup-area-name area) - (gnus-soup-area-encoding area) - (if (or (gnus-soup-area-description area) - (gnus-soup-area-number area)) - (concat "\t" (or (gnus-soup-area-description - area) "") - (if (gnus-soup-area-number area) - (concat "\t" (int-to-string - (gnus-soup-area-number area))) - "")) "")))))))) - -(defun gnus-soup-write-replies (dir areas) - "Write a REPLIES file in DIR containing AREAS." - (with-temp-file (concat dir "REPLIES") - (let (area) - (while (setq area (pop areas)) - (insert (format "%s\t%s\t%s\n" - (gnus-soup-reply-prefix area) - (gnus-soup-reply-kind area) - (gnus-soup-reply-encoding area))))))) - -(defun gnus-soup-area (group) - (gnus-soup-read-areas) - (let ((areas gnus-soup-areas) - (real-group (gnus-group-real-name group)) - area result) - (while areas - (setq area (car areas) - areas (cdr areas)) - (when (equal (gnus-soup-area-name area) real-group) - (setq result area))) - (unless result - (setq result - (vector (gnus-soup-unique-prefix) - real-group - (format "%c%c%c" - gnus-soup-encoding-type - gnus-soup-index-type - (if (gnus-member-of-valid 'mail group) ?m ?n)) - nil nil) - gnus-soup-areas (cons result gnus-soup-areas))) - result)) - -(defun gnus-soup-unique-prefix (&optional dir) - (let* ((dir (file-name-as-directory (or dir gnus-soup-directory))) - (entry (assoc dir gnus-soup-last-prefix)) - gnus-soup-prev-prefix) - (if entry - () - (when (file-exists-p (concat dir gnus-soup-prefix-file)) - (ignore-errors - (load (concat dir gnus-soup-prefix-file) nil t t))) - (push (setq entry (cons dir (or gnus-soup-prev-prefix 0))) - gnus-soup-last-prefix)) - (setcdr entry (1+ (cdr entry))) - (gnus-soup-write-prefixes) - (int-to-string (cdr entry)))) - -(defun gnus-soup-unpack-packet (dir unpacker packet) - "Unpack PACKET into DIR using UNPACKER. -Return whether the unpacking was successful." - (gnus-make-directory dir) - (gnus-message 4 "Unpacking: %s" (format unpacker packet)) - (prog1 - (eq 0 (call-process - shell-file-name nil nil nil shell-command-switch - (format "cd %s ; %s" (expand-file-name dir) - (format unpacker packet)))) - (gnus-message 4 "Unpacking...done"))) - -(defun gnus-soup-send-packet (packet) - (gnus-soup-unpack-packet - gnus-soup-replies-directory gnus-soup-unpacker packet) - (let ((replies (gnus-soup-parse-replies - (concat gnus-soup-replies-directory "REPLIES")))) - (save-excursion - (while replies - (let* ((msg-file (concat gnus-soup-replies-directory - (gnus-soup-reply-prefix (car replies)) - ".MSG")) - (msg-buf (and (file-exists-p msg-file) - (nnheader-find-file-noselect msg-file))) - (tmp-buf (gnus-get-buffer-create " *soup send*")) - beg end) - (cond - ((and (/= (gnus-soup-encoding-format - (gnus-soup-reply-encoding (car replies))) - ?u) - (/= (gnus-soup-encoding-format - (gnus-soup-reply-encoding (car replies))) - ?n)) ;; Gnus back compatibility. - (error "Unsupported encoding")) - ((null msg-buf) - t) - (t - (buffer-disable-undo msg-buf) - (set-buffer msg-buf) - (goto-char (point-min)) - (while (not (eobp)) - (unless (looking-at "#! *rnews +\\([0-9]+\\)") - (error "Bad header")) - (forward-line 1) - (setq beg (point) - end (+ (point) (string-to-number - (buffer-substring - (match-beginning 1) (match-end 1))))) - (switch-to-buffer tmp-buf) - (erase-buffer) - (mm-disable-multibyte) - (insert-buffer-substring msg-buf beg end) - (cond - ((string= (gnus-soup-reply-kind (car replies)) "news") - (gnus-message 5 "Sending news message to %s..." - (mail-fetch-field "newsgroups")) - (sit-for 1) - (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me) - (method (if (functionp message-post-method) - (funcall message-post-method) - message-post-method)) - result) - (run-hooks 'message-send-news-hook) - (gnus-open-server method) - (message "Sending news via %s..." - (gnus-server-string method)) - (unless (let ((mail-header-separator "")) - (gnus-request-post method)) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method)))))) - ((string= (gnus-soup-reply-kind (car replies)) "mail") - (gnus-message 5 "Sending mail to %s..." - (mail-fetch-field "to")) - (sit-for 1) - (let ((mail-header-separator "")) - (funcall (or message-send-mail-real-function - message-send-mail-function)))) - (t - (error "Unknown reply kind"))) - (set-buffer msg-buf) - (goto-char end)) - (delete-file (buffer-file-name)) - (kill-buffer msg-buf) - (kill-buffer tmp-buf) - (gnus-message 4 "Sent packet")))) - (setq replies (cdr replies))) - t))) - -(provide 'gnus-soup) - -;; arch-tag: eddfa69d-13e8-4aea-84ef-62a526ef185c -;;; gnus-soup.el ends here diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 0d6848cc36..0f5169ecf6 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) @@ -680,7 +680,7 @@ are supported for %s." ((string= fstring "%d") (setq dontinsert t) (if insert - (list `(princ ,(car flist))) + `(insert (int-to-string ,(car flist))) (list `(int-to-string ,(car flist))))) ;; Just lots of chars and strings. ((string-match "\\`\\(%[cs]\\)+\\'" fstring) @@ -767,5 +767,4 @@ If PROPS, insert the result." ;; coding: iso-8859-1 ;; End: -;; arch-tag: a4328fa1-1f84-4b09-97ad-4b5767cfd50f ;;; gnus-spec.el ends here diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f2ae61db8e..67cc088515 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -28,11 +28,14 @@ (eval-when-compile (require 'cl)) (require 'gnus) +(require 'gnus-start) (require 'gnus-spec) (require 'gnus-group) (require 'gnus-int) (require 'gnus-range) +(autoload 'gnus-group-make-nnir-group "nnir") + (defcustom gnus-server-mode-hook nil "Hook run in `gnus-server-mode' buffers." :group 'gnus-server @@ -112,6 +115,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Kill" gnus-server-kill-server t] ["Yank" gnus-server-yank-server t] ["Copy" gnus-server-copy-server t] + ["Show" gnus-server-show-server t] ["Edit" gnus-server-edit-server t] ["Regenerate" gnus-server-regenerate-server t] ["Compact" gnus-server-compact-server t] @@ -149,6 +153,7 @@ If nil, a faster, but more primitive, buffer is used instead." "c" gnus-server-copy-server "a" gnus-server-add-server "e" gnus-server-edit-server + "S" gnus-server-show-server "s" gnus-server-scan-server "O" gnus-server-open-server @@ -164,6 +169,8 @@ If nil, a faster, but more primitive, buffer is used instead." "g" gnus-server-regenerate-server + "G" gnus-group-make-nnir-group + "z" gnus-server-compact-server "\C-c\C-i" gnus-info-find-node @@ -300,9 +307,7 @@ The following commands are available: "Initialize the server buffer." (unless (get-buffer gnus-server-buffer) (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) - (gnus-server-mode) - (when gnus-carpal - (gnus-carpal-setup-buffer 'server))))) + (gnus-server-mode)))) (defun gnus-server-prepare () (gnus-set-format 'server-mode) @@ -547,6 +552,7 @@ The following commands are available: (gnus-server-list-servers)) (defun gnus-server-copy-server (from to) + "Copy a server definiton to a new name." (interactive (list (or (gnus-server-server-name) @@ -569,8 +575,9 @@ The following commands are available: (defun gnus-server-add-server (how where) (interactive - (list (intern (completing-read "Server method: " - gnus-valid-select-methods nil t)) + (list (intern (gnus-completing-read "Server method" + (mapcar 'car gnus-valid-select-methods) + t)) (read-string "Server name: "))) (when (assq where gnus-server-alist) (error "Server with that name already defined")) @@ -580,7 +587,7 @@ The following commands are available: (defun gnus-server-goto-server (server) "Jump to a server line." (interactive - (list (completing-read "Goto server: " gnus-server-alist nil t))) + (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t))) (let ((to (text-property-any (point-min) (point-max) 'gnus-server (intern server)))) (when to @@ -604,6 +611,18 @@ The following commands are available: (gnus-server-position-point)) 'edit-server))) +(defun gnus-server-show-server (server) + "Show the definition of the server on the current line." + (interactive (list (gnus-server-server-name))) + (unless server + (error "No server on current line")) + (let ((info (gnus-server-to-method server))) + (gnus-edit-form + info "Showing the server." + `(lambda (form) + (gnus-server-position-point)) + 'edit-server))) + (defun gnus-server-scan-server (server) "Request a scan from the current server." (interactive (list (gnus-server-server-name))) @@ -643,6 +662,30 @@ The following commands are available: (defvar gnus-browse-menu-hook nil "*Hook run after the creation of the browse mode menu.") +(defcustom gnus-browse-subscribe-newsgroup-method + 'gnus-subscribe-alphabetically + "Function(s) called when subscribing groups in the Browse Server Buffer +A few pre-made functions are supplied: `gnus-subscribe-randomly' +inserts new groups at the beginning of the list of groups; +`gnus-subscribe-alphabetically' inserts new groups in strict +alphabetic order; `gnus-subscribe-hierarchically' inserts new groups +in hierarchical newsgroup order; `gnus-subscribe-interactively' asks +for your decision; `gnus-subscribe-killed' kills all new groups; +`gnus-subscribe-zombies' will make all new groups into zombies; +`gnus-subscribe-topics' will enter groups into the topics that +claim them." + :version "24.1" + :group 'gnus-server + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + (function-item gnus-subscribe-topics) + function + (repeat function))) + (defvar gnus-browse-mode-hook nil) (defvar gnus-browse-mode-map nil) (put 'gnus-browse-mode 'mode-class 'special) @@ -723,7 +766,8 @@ The following commands are available: (with-current-buffer nntp-server-buffer (let ((cur (current-buffer))) (goto-char (point-min)) - (unless (string= gnus-ignored-newsgroups "") + (unless (or (null gnus-ignored-newsgroups) + (string= gnus-ignored-newsgroups "")) (delete-matching-lines gnus-ignored-newsgroups)) ;; We treat NNTP as a special case to avoid problems with ;; garbage group names like `"foo' that appear in some badly @@ -779,8 +823,6 @@ The following commands are available: (funcall gnus-group-prepare-function gnus-level-killed 'ignore 1 'ignore)) (gnus-get-buffer-create gnus-browse-buffer) - (when gnus-carpal - (gnus-carpal-setup-buffer 'browse)) (gnus-configure-windows 'browse) (buffer-disable-undo) (let ((buffer-read-only nil)) @@ -890,7 +932,9 @@ If NUMBER, fetch this number of articles." (gnus-browse-next-group (- n))) (defun gnus-browse-unsubscribe-current-group (arg) - "(Un)subscribe to the next ARG groups." + "(Un)subscribe to the next ARG groups. +The variable `gnus-browse-subscribe-newsgroup-method' determines +how new groups will be entered into the group buffer." (interactive "p") (when (eobp) (error "No group at current line")) @@ -939,22 +983,25 @@ If NUMBER, fetch this number of articles." ;; subscribe to it. (if (gnus-ephemeral-group-p group) (gnus-kill-ephemeral-group group)) - ;; We need to discern between killed/zombie groups and - ;; just unsubscribed ones. - (gnus-group-change-level - (or (gnus-group-entry group) - (list t group gnus-level-default-subscribed - nil nil (if (gnus-server-equal - gnus-browse-current-method "native") - nil - (gnus-method-simplify - gnus-browse-current-method)))) - gnus-level-default-subscribed (gnus-group-level group) - (and (car (nth 1 gnus-newsrc-alist)) - (gnus-group-entry (car (nth 1 gnus-newsrc-alist)))) - (null (gnus-group-entry group))) + (let ((entry (gnus-group-entry group))) + (if entry + ;; Just change the subscription level if it is an + ;; unsubscribed group. + (gnus-group-change-level entry + gnus-level-default-subscribed) + ;; If it is a killed group or a zombie, feed it to the + ;; mechanism for new group subscription. + (gnus-call-subscribe-functions + gnus-browse-subscribe-newsgroup-method + group) + (gnus-request-update-group-status group 'subscribe))) (delete-char 1) - (insert ? )) + (insert (let ((lvl (gnus-group-level group))) + (cond + ((< lvl gnus-level-unsubscribed) ? ) + ((< lvl gnus-level-zombie) ?U) + ((< lvl gnus-level-killed) ?Z) + (t ?K))))) (gnus-group-change-level group gnus-level-unsubscribed gnus-level-default-subscribed) (delete-char 1) @@ -976,7 +1023,7 @@ If NUMBER, fetch this number of articles." (defun gnus-browse-describe-briefly () "Give a one line description of the group mode commands." (interactive) - (gnus-message 6 + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help"))) (defun gnus-server-regenerate-server () @@ -1033,5 +1080,4 @@ Requesting compaction of %s... (this may take a long time)" (provide 'gnus-srvr) -;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 ;;; gnus-srvr.el ends here diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index c14ec7f4c6..38b8174e44 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -86,14 +86,6 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead." :group 'gnus-start :type '(choice file (const nil))) -(defcustom gnus-default-subscribed-newsgroups nil - "List of newsgroups to subscribe, when a user runs Gnus the first time. -The value should be a list of strings. -If it is t, Gnus will not do anything special the first time it is -started; it'll just use the normal newsgroups subscription methods." - :group 'gnus-start - :type '(choice (repeat string) (const :tag "Nothing special" t))) - (defcustom gnus-use-dribble-file t "*Non-nil means that Gnus will use a dribble file to store user updates. If Emacs should crash without saving the .newsrc files, complete @@ -181,7 +173,7 @@ Groups with levels less than `gnus-level-subscribed', which should be less than this variable, are subscribed. Groups with levels from `gnus-level-subscribed' (exclusive) upto this variable (inclusive) are unsubscribed. See also -`gnus-level-zombie', `gnus-level-killed' and the Info node `Group +`gnus-level-zombie', `gnus-level-killed' and the Info node `(gnus)Group Levels' for details.") (defconst gnus-level-zombie 8 @@ -268,7 +260,7 @@ not match this regexp will be removed before saving the list." (mapconcat 'identity '("^to\\." ; not "real" groups "^[0-9. \t]+\\( \\|$\\)" ; all digits in name - "^[\"][]\"[#'()]" ; bogus characters + "^[\"][\"#'()]" ; bogus characters ) "\\|") "*A regexp to match uninteresting newsgroups in the active file. @@ -341,8 +333,17 @@ hierarchy in its entirety." :group 'gnus-group-new :type 'boolean) +(defcustom gnus-auto-subscribed-categories '(mail post-mail) + "*New groups from methods of these categories will be subscribed automatically. +Note that this variable only deals with new groups. It has no +effect whatsoever on old groups. The default is to automatically +subscribe all groups from mail-like backends." + :version "24.1" + :group 'gnus-group-new + :type '(repeat symbol)) + (defcustom gnus-auto-subscribed-groups - "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir" + "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir\\|^nnimap" "*All new groups that match this regexp will be subscribed automatically. Note that this variable only deals with new groups. It has no effect whatsoever on old groups. @@ -380,6 +381,13 @@ disc." :group 'gnus-newsrc :type 'boolean) +(defcustom gnus-use-backend-marks nil + "If non-nil, Gnus will store and retrieve marks from the backends. +This means that marks will be stored both in .newsrc.eld and in +the backend, and will slow operation down somewhat." + :group 'gnus-newsrc + :type 'boolean) + (defcustom gnus-check-bogus-groups-hook nil "A hook run after removing bogus groups." :group 'gnus-start-server @@ -402,8 +410,7 @@ This hook is called as the first thing when Gnus is started." :group 'gnus-start :type 'hook) -(defcustom gnus-setup-news-hook - '(gnus-fixup-nnimap-unread-after-getting-new-news) +(defcustom gnus-setup-news-hook nil "A hook after reading the .newsrc file, but before generating the buffer." :group 'gnus-start :type 'hook) @@ -420,9 +427,9 @@ This hook is called as the first thing when Gnus is started." :type 'hook) (defcustom gnus-after-getting-new-news-hook - '(gnus-display-time-event-handler - gnus-fixup-nnimap-unread-after-getting-new-news) + '(gnus-display-time-event-handler) "*A hook run after Gnus checks for new news when Gnus is already running." + :version "24.1" :group 'gnus-group-new :type 'hook) @@ -594,8 +601,7 @@ Can be used to turn version control on or off." (defun gnus-subscribe-hierarchically (newgroup) "Subscribe new NEWGROUP and insert it in hierarchical newsgroup order." ;; Basic ideas by [email protected] (Mike Williams) - (save-excursion - (set-buffer (nnheader-find-file-noselect gnus-current-startup-file)) + (with-current-buffer (nnheader-find-file-noselect gnus-current-startup-file) (prog1 (let ((groupkey newgroup) before) (while (and (not before) groupkey) @@ -639,6 +645,7 @@ the first newsgroup." (gnus-group-change-level newsgroup gnus-level-default-subscribed gnus-level-killed (gnus-group-entry (or next "dummy.group"))) + (gnus-request-update-group-status newsgroup 'subscribe) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup) t)) @@ -706,6 +713,7 @@ the first newsgroup." nnoo-state-alist nil gnus-current-select-method nil nnmail-split-history nil + gnus-extended-servers nil gnus-ephemeral-servers nil) (gnus-shutdown 'gnus) ;; Kill the startup file. @@ -765,18 +773,10 @@ prompt the user for the name of an NNTP server to use." (when gnus-select-method (push (cons "native" gnus-select-method) gnus-predefined-server-alist)) - + (if gnus-agent (gnus-agentize)) - (when gnus-simple-splash - (setq gnus-simple-splash nil) - (cond - ((featurep 'xemacs) - (gnus-xmas-splash)) - (window-system - (gnus-x-splash)))) - (let ((level (and (numberp arg) (> arg 0) arg)) did-connect) (unwind-protect @@ -786,10 +786,9 @@ prompt the user for the name of an NNTP server to use." (gnus-start-news-server (and arg (not level)))))) (if (and (not dont-connect) (not did-connect)) + ;; Couldn't connect to the server, so bail out. (gnus-group-quit) (gnus-run-hooks 'gnus-startup-hook) - ;; NNTP server is successfully open. - ;; Find the current startup file name. (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file)) @@ -799,11 +798,10 @@ prompt the user for the name of an NNTP server to use." (gnus-dribble-read-file)) ;; Do the actual startup. - (if gnus-agent - (gnus-request-create-group "queue" '(nndraft ""))) - (gnus-request-create-group "drafts" '(nndraft "")) (gnus-setup-news nil level dont-connect) (gnus-run-hooks 'gnus-setup-news-hook) + (when gnus-agent + (gnus-request-create-group "queue" '(nndraft ""))) (gnus-start-draft-setup) ;; Generate the group buffer. (gnus-group-list-groups level) @@ -814,13 +812,14 @@ prompt the user for the name of an NNTP server to use." (defun gnus-start-draft-setup () "Make sure the draft group exists." + (interactive) (gnus-request-create-group "drafts" '(nndraft "")) (unless (gnus-group-entry "nndraft:drafts") (let ((gnus-level-default-subscribed 1)) - (gnus-subscribe-group "nndraft:drafts" nil '(nndraft "")))) + (gnus-subscribe-group "nndraft:drafts" nil '(nndraft ""))) + (setcar (gnus-group-entry "nndraft:drafts") 0)) (unless (equal (gnus-group-get-parameter "nndraft:drafts" 'gnus-dummy t) '((gnus-draft-mode))) - (gnus-message 3 "Setting up drafts group") (gnus-group-set-parameter "nndraft:drafts" 'gnus-dummy '((gnus-draft-mode))))) @@ -856,8 +855,7 @@ prompt the user for the name of an NNTP server to use." ;; it's not needed). ;; (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-group-set-mode-line)) (set-buffer obuf)))) @@ -868,10 +866,11 @@ prompt the user for the name of an NNTP server to use." (defun gnus-dribble-read-file () "Read the dribble file from disk." (let ((dribble-file (gnus-dribble-file-name))) - (save-excursion - (set-buffer (setq gnus-dribble-buffer - (gnus-get-buffer-create - (file-name-nondirectory dribble-file)))) + (unless (file-exists-p (file-name-directory dribble-file)) + (make-directory (file-name-directory dribble-file) t)) + (with-current-buffer (setq gnus-dribble-buffer + (gnus-get-buffer-create + (file-name-nondirectory dribble-file))) (set (make-local-variable 'file-precious-flag) t) (erase-buffer) (setq buffer-file-name dribble-file) @@ -920,8 +919,7 @@ prompt the user for the name of an NNTP server to use." (when (file-exists-p (gnus-dribble-file-name)) (delete-file (gnus-dribble-file-name))) (when gnus-dribble-buffer - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (let ((auto (make-auto-save-file-name))) (when (file-exists-p auto) (delete-file auto)) @@ -931,14 +929,12 @@ prompt the user for the name of an NNTP server to use." (defun gnus-dribble-save () (when (and gnus-dribble-buffer (buffer-name gnus-dribble-buffer)) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (save-buffer)))) (defun gnus-dribble-clear () (when (gnus-buffer-exists-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (erase-buffer) (set-buffer-modified-p nil) (setq buffer-saved-size (buffer-size))))) @@ -1000,27 +996,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (when (or (null gnus-read-active-file) (eq gnus-read-active-file 'some)) (gnus-update-active-hashtb-from-killed)) - - ;; Validate agent covered methods now that gnus-server-alist has - ;; been initialized. - ;; NOTE: This is here for one purpose only. By validating the - ;; agentized server's, it converts the old 5.10.3, and earlier, - ;; format to the current format. That enables the agent code - ;; within gnus-read-active-file to function correctly. - (if gnus-agent - (gnus-agent-read-servers-validate)) - - ;; Read the active file and create `gnus-active-hashtb'. - ;; If `gnus-read-active-file' is nil, then we just create an empty - ;; hash table. The partial filling out of the hash table will be - ;; done in `gnus-get-unread-articles'. - (and gnus-read-active-file - (not level) - (gnus-read-active-file nil dont-connect)) - (unless gnus-active-hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096))) - ;; Initialize the cache. (when gnus-use-cache (gnus-cache-open)) @@ -1059,15 +1036,6 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-server-opened gnus-select-method)) (gnus-check-bogus-newsgroups)) - ;; We might read in new NoCeM messages here. - (when (and (not dont-connect) - gnus-use-nocem - (or (and (numberp gnus-use-nocem) - (numberp level) - (>= level gnus-use-nocem)) - (not level))) - (gnus-nocem-scan-groups)) - ;; Read any slave files. (gnus-master-read-slave-newsrc) @@ -1113,53 +1081,53 @@ for new groups, and subscribe the new groups as zombies." 'gnus-subscribe-zombies) t) (t gnus-check-new-newsgroups)))) - (unless (gnus-check-first-time-used) - (if (or (consp check) - (eq check 'ask-server)) - ;; Ask the server for new groups. - (gnus-ask-server-for-new-groups) - ;; Go through the active hashtb and look for new groups. - (let ((groups 0) - group new-newsgroups) - (gnus-message 5 "Looking for new newsgroups...") - (unless gnus-have-read-active-file - (gnus-read-active-file)) - (setq gnus-newsrc-last-checked-date (message-make-date)) - (unless gnus-killed-hashtb - (gnus-make-hashtable-from-killed)) - ;; Go though every newsgroup in `gnus-active-hashtb' and compare - ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. - (mapatoms - (lambda (sym) - (if (or (null (setq group (symbol-name sym))) - (not (boundp sym)) - (null (symbol-value sym)) - (gnus-gethash group gnus-killed-hashtb) - (gnus-gethash group gnus-newsrc-hashtb)) - () - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) - (gnus-call-subscribe-functions - gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) - (if gnus-subscribe-hierarchical-interactive - (push group new-newsgroups) - (gnus-call-subscribe-functions - gnus-subscribe-newsgroup-method group))))))) - gnus-active-hashtb) - (when new-newsgroups - (gnus-subscribe-hierarchical-interactive new-newsgroups)) - (if (> groups 0) - (gnus-message 5 "%d new newsgroup%s arrived." - groups (if (> groups 1) "s have" " has")) - (gnus-message 5 "No new newsgroups."))))))) + (if (or (consp check) + (eq check 'ask-server)) + ;; Ask the server for new groups. + (gnus-ask-server-for-new-groups) + ;; Go through the active hashtb and look for new groups. + (let ((groups 0) + group new-newsgroups) + (gnus-message 5 "Looking for new newsgroups...") + (unless gnus-have-read-active-file + (gnus-read-active-file)) + (setq gnus-newsrc-last-checked-date (message-make-date)) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + ;; Go though every newsgroup in `gnus-active-hashtb' and compare + ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. + (mapatoms + (lambda (sym) + (if (or (null (setq group (symbol-name sym))) + (not (boundp sym)) + (null (symbol-value sym)) + (gnus-gethash group gnus-killed-hashtb) + (gnus-gethash group gnus-newsrc-hashtb)) + () + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (gnus-call-subscribe-functions + gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (if gnus-subscribe-hierarchical-interactive + (push group new-newsgroups) + (gnus-call-subscribe-functions + gnus-subscribe-newsgroup-method group))))))) + gnus-active-hashtb) + (when new-newsgroups + (gnus-subscribe-hierarchical-interactive new-newsgroups)) + (if (> groups 0) + (gnus-message 5 "%d new newsgroup%s arrived." + groups (if (> groups 1) "s have" " has")) + (gnus-message 5 "No new newsgroups.")) + groups)))) (defun gnus-matches-options-n (group) ;; Returns `subscribe' if the group is to be unconditionally @@ -1171,6 +1139,12 @@ for new groups, and subscribe the new groups as zombies." ((and gnus-options-subscribe (string-match gnus-options-subscribe group)) 'subscribe) + ((let ((do-subscribe nil)) + (dolist (category gnus-auto-subscribed-categories) + (when (gnus-member-of-valid category group) + (setq do-subscribe t))) + do-subscribe) + 'subscribe) ((and gnus-auto-subscribed-groups (string-match gnus-auto-subscribed-groups group)) 'subscribe) @@ -1257,55 +1231,7 @@ for new groups, and subscribe the new groups as zombies." (gnus-message 5 "No new newsgroups")) (when got-new (setq gnus-newsrc-last-checked-date new-date)) - got-new)) - -(defun gnus-check-first-time-used () - (catch 'ended - ;; First check if any of the following files exist. If they do, - ;; it's not the first time the user has used Gnus. - (dolist (file (list (concat gnus-current-startup-file ".el") - (concat gnus-current-startup-file ".eld") - (concat gnus-startup-file ".el") - (concat gnus-startup-file ".eld"))) - (when (file-exists-p file) - (throw 'ended nil))) - (gnus-message 6 "First time user; subscribing you to default groups") - (unless (gnus-read-active-file-p) - (let ((gnus-read-active-file t)) - (gnus-read-active-file))) - (setq gnus-newsrc-last-checked-date (message-make-date)) - ;; Subscribe to the default newsgroups. - (let ((groups (or gnus-default-subscribed-newsgroups - gnus-backup-default-subscribed-newsgroups)) - group) - (if (eq groups t) - ;; If t, we subscribe (or not) all groups as if they were new. - (mapatoms - (lambda (sym) - (when (setq group (symbol-name sym)) - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (gnus-sethash group group gnus-killed-hashtb) - (gnus-call-subscribe-functions - gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (push group gnus-killed-list)))))) - gnus-active-hashtb) - (dolist (group groups) - ;; Only subscribe the default groups that are activated. - (when (gnus-active group) - (gnus-group-change-level - group gnus-level-default-subscribed gnus-level-killed))) - (save-excursion - (set-buffer gnus-group-buffer) - ;; Don't error if the group already exists. This happens when a - ;; first-time user types 'F'. -- didier - (gnus-group-make-help-group t)) - (when gnus-novice-user - (gnus-message 7 "`A k' to list killed groups")))))) + new-newsgroups)) (defun gnus-subscribe-group (group &optional previous method) "Subscribe GROUP and put it after PREVIOUS." @@ -1471,7 +1397,7 @@ newsgroup." (push group bogus))) (if confirm (map-y-or-n-p - "Remove bogus group %s? " + (format "Remove bogus group %%s (of %d groups)? " (length bogus)) (lambda (group) ;; Remove all bogus subscribed groups by first killing them, and ;; then removing them from the list of killed groups. @@ -1523,7 +1449,8 @@ newsgroup." (when (> (cdr cache-active) (cdr active)) (setcdr active (cdr cache-active)))))))) -(defun gnus-activate-group (group &optional scan dont-check method) +(defun gnus-activate-group (group &optional scan dont-check method + dont-sub-check) "Check whether a group has been activated or not. If SCAN, request a scan of that group as well." (let ((method (or method (inline (gnus-find-method-for-group group)))) @@ -1538,9 +1465,13 @@ If SCAN, request a scan of that group as well." (gnus-request-scan group method)) t) (if (or debug-on-error debug-on-quit) - (inline (gnus-request-group group dont-check method)) + (inline (gnus-request-group group (or dont-sub-check dont-check) + method + (gnus-get-info group))) (condition-case nil - (inline (gnus-request-group group dont-check method)) + (inline (gnus-request-group group (or dont-sub-check dont-check) + method + (gnus-get-info group))) ;;(error nil) (quit (message "Quit activating %s" group) @@ -1578,6 +1509,13 @@ If SCAN, request a scan of that group as well." (gnus-info-group info))))) (gnus-activate-group (gnus-info-group info) nil t)) + ;; Allow backends to update marks, + (when gnus-use-backend-marks + (let ((method (inline (gnus-find-method-for-group + (gnus-info-group info))))) + (when (gnus-check-backend-function 'request-marks (car method)) + (gnus-request-marks info method)))) + (let* ((range (gnus-info-read info)) (num 0)) @@ -1668,148 +1606,162 @@ If SCAN, request a scan of that group as well." ;; and compute how many unread articles there are in each group. (defun gnus-get-unread-articles (&optional level) (setq gnus-server-method-cache nil) + (require 'gnus-agent) (let* ((newsrc (cdr gnus-newsrc-alist)) (alevel (or level gnus-activate-level (1+ gnus-level-subscribed))) (foreign-level - (min - (cond ((and gnus-activate-foreign-newsgroups - (not (numberp gnus-activate-foreign-newsgroups))) - (1+ gnus-level-subscribed)) - ((numberp gnus-activate-foreign-newsgroups) - gnus-activate-foreign-newsgroups) - (t 0)) - alevel)) + (or + level + (min + (cond ((and gnus-activate-foreign-newsgroups + (not (numberp gnus-activate-foreign-newsgroups))) + (1+ gnus-level-subscribed)) + ((numberp gnus-activate-foreign-newsgroups) + gnus-activate-foreign-newsgroups) + (t 0)) + alevel))) (methods-cache nil) (type-cache nil) - scanned-methods info group active method retrieve-groups cmethod - method-type) + (gnus-agent-article-local-times 0) + (archive-method (gnus-server-to-method "archive")) + infos info group active method cmethod + method-type method-group-list entry) (gnus-message 6 "Checking new news...") (while newsrc (setq active (gnus-active (setq group (gnus-info-group (setq info (pop newsrc)))))) - - ;; Check newsgroups. If the user doesn't want to check them, or - ;; they can't be checked (for instance, if the news server can't - ;; be reached) we just set the number of unread articles in this - ;; newsgroup to t. This means that Gnus thinks that there are - ;; unread articles, but it has no idea how many. - - ;; To be more explicit: - ;; >0 for an active group with messages - ;; 0 for an active group with no unread messages - ;; nil for non-foreign groups that the user has requested not be checked - ;; t for unchecked foreign groups or bogus groups, or groups that can't - ;; be checked, for one reason or other. - (when (setq method (gnus-info-method info)) + ;; First go through all the groups, see what select methods they + ;; belong to, and then collect them into lists per unique select + ;; method. + (if (not (setq method (gnus-info-method info))) + (setq method gnus-select-method) + ;; There may be several similar methods. Possibly extend the + ;; method. (if (setq cmethod (assoc method methods-cache)) (setq method (cdr cmethod)) - (setq cmethod (inline (gnus-server-get-method nil method))) + (setq cmethod (if (stringp method) + (gnus-server-to-method method) + (inline (gnus-find-method-for-group + (gnus-info-group info) info)))) (push (cons method cmethod) methods-cache) (setq method cmethod))) - (when (and method - (not (setq method-type (cdr (assoc method type-cache))))) + (setq method-group-list (assoc method type-cache)) + (unless method-group-list (setq method-type (cond - ((gnus-secondary-method-p method) + ((or (gnus-secondary-method-p method) + (and (gnus-archive-server-wanted-p) + (gnus-methods-equal-p archive-method method))) 'secondary) ((inline (gnus-server-equal gnus-select-method method)) 'primary) (t 'foreign))) - (push (cons method method-type) type-cache)) - - (cond ((and method (eq method-type 'foreign)) - ;; These groups are foreign. Check the level. - (if (<= (gnus-info-level info) foreign-level) - (when (setq active (gnus-activate-group group 'scan)) - ;; Let the Gnus agent save the active file. - (when (and gnus-agent active (gnus-online method)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (unless (inline (gnus-virtual-group-p group)) - (inline (gnus-close-group group))) - (when (fboundp (intern (concat (symbol-name (car method)) - "-request-update-info"))) - (inline (gnus-request-update-info info method)))) - (if (and level - ;; If `active' is nil that means the group has - ;; never been read, the group should be marked - ;; as having never been checked (see below). - active - (> (gnus-info-level info) level)) - ;; Don't check groups of which levels are higher - ;; than the one that a user specified. - (setq active 'ignore)))) - ;; These groups are native or secondary. - ((> (gnus-info-level info) alevel) - ;; We don't want these groups. - (setq active 'ignore)) - ;; Activate groups. - ((not gnus-read-active-file) - (if (gnus-check-backend-function 'retrieve-groups group) - ;; if server support gnus-retrieve-groups we push - ;; the group onto retrievegroups for later checking - (if (assoc method retrieve-groups) - (setcdr (assoc method retrieve-groups) - (cons group (cdr (assoc method retrieve-groups)))) - (push (list method group) retrieve-groups)) - ;; hack: `nnmail-get-new-mail' changes the mail-source depending - ;; on the group, so we must perform a scan for every group - ;; if the users has any directory mail sources. - ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil, - ;; for it scan all spool files even when the groups are - ;; not required. - (if (and - (or nnmail-scan-directory-mail-source-once - (null (assq 'directory mail-sources))) - (member method scanned-methods)) - (setq active (gnus-activate-group group)) - (setq active (gnus-activate-group group 'scan)) - (push method scanned-methods)) - (when active - (gnus-close-group group))))) - - ;; Get the number of unread articles in the group. - (cond - ((eq active 'ignore) - ;; Don't do anything. - ) - (active - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (let ((tmp (gnus-group-entry group))) - (when tmp - (setcar tmp t)))))) - - ;; iterate through groups on methods which support gnus-retrieve-groups - ;; and fetch a partial active file and use it to find new news. - (dolist (rg retrieve-groups) - (let ((method (or (car rg) gnus-select-method)) - (groups (cdr rg))) - (when (gnus-check-server method) - ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - (gnus-read-active-file-2 - (mapcar (lambda (group) (gnus-group-real-name group)) groups) - method) - (dolist (group groups) - (cond - ((setq active (gnus-active (gnus-info-group - (setq info (gnus-get-info group))))) - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (setcar (gnus-group-entry group) t))))))) - + (push (setq method-group-list (list method method-type nil nil)) + type-cache)) + ;; Only add groups that need updating. + (if (<= (gnus-info-level info) + (if (eq (cadr method-group-list) 'foreign) + foreign-level + alevel)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list))) + ;; The group is inactive, so we nix out the number of unread articles. + ;; It leads `(gnus-group-unread group)' to return t. See also + ;; `gnus-group-prepare-flat'. + (unless active + (when (setq entry (gnus-group-entry group)) + (setcar entry t))))) + + ;; Sort the methods based so that the primary and secondary + ;; methods come first. This is done for legacy reasons to try to + ;; ensure that side-effect behaviour doesn't change from previous + ;; Gnus versions. + (setq type-cache + (sort (nreverse type-cache) + (lambda (c1 c2) + (< (gnus-method-rank (cadr c1) (car c1)) + (gnus-method-rank (cadr c2) (car c2)))))) + + ;; Start early async retrieval of data. + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (when (and method infos + (not (gnus-method-denied-p method))) + ;; If the open-server method doesn't exist, then the method + ;; itself doesn't exist, so we ignore it. + (if (not (ignore-errors (gnus-get-function method 'open-server))) + (setq type-cache (delq elem type-cache)) + (unless (gnus-server-opened method) + (gnus-open-server method)) + (when (and + (gnus-server-opened method) + (gnus-check-backend-function + 'retrieve-group-data-early (car method))) + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + (setcar (nthcdr 3 elem) + (gnus-retrieve-group-data-early method infos))))))) + + ;; Do the rest of the retrieval. + (dolist (elem type-cache) + (destructuring-bind (method method-type infos early-data) elem + (when (and method infos) + (let ((updatep (gnus-check-backend-function + 'request-update-info (car method)))) + ;; See if any of the groups from this method require updating. + (gnus-read-active-for-groups method infos early-data) + (dolist (info infos) + (inline (gnus-get-unread-articles-in-group + info (gnus-active (gnus-info-group info)) + updatep))))))) (gnus-message 6 "Checking new news...done"))) +(defun gnus-method-rank (type method) + (cond + ;; Get info for virtual groups last. + ((eq (car method) 'nnvirtual) + 200) + ((eq type 'primary) + 1) + ;; Compute the rank of the secondary methods based on where they + ;; are in the secondary select list. + ((eq type 'secondary) + (let ((i 2)) + (block nil + (dolist (smethod gnus-secondary-select-methods) + (when (equal method smethod) + (return i)) + (incf i)) + i))) + ;; Just say that all foreign groups have the same rank. + (t + 100))) + +(defun gnus-read-active-for-groups (method infos early-data) + (with-current-buffer nntp-server-buffer + (cond + ((and + (gnus-check-backend-function 'finish-retrieve-group-infos (car method)) + (or (not (gnus-agent-method-p method)) + (gnus-online method))) + (gnus-finish-retrieve-group-infos method infos early-data) + (gnus-agent-save-active method)) + ((gnus-check-backend-function 'retrieve-groups (car method)) + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + (let (groups) + (gnus-read-active-file-2 + (dolist (info infos (nreverse groups)) + (push (gnus-group-real-name (gnus-info-group info)) groups)) + method))) + ((gnus-check-backend-function 'request-list (car method)) + (gnus-read-active-file-1 method nil infos)) + (t + (dolist (info infos) + (gnus-activate-group (gnus-info-group info) nil nil method t)))))) + ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. (defun gnus-make-hashtable-from-newsrc-alist () @@ -1830,14 +1782,18 @@ If SCAN, request a scan of that group as well." (if (setq rest (member method methods)) (gnus-info-set-method info (car rest)) (push method methods))) - (gnus-sethash - (car info) - ;; Preserve number of unread articles in groups. - (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) - prev) - gnus-newsrc-hashtb) - (setq prev alist - alist (cdr alist))) + ;; Check for duplicates. + (if (gnus-gethash (car info) gnus-newsrc-hashtb) + ;; Remove this entry from the alist. + (setcdr prev (cddr prev)) + (gnus-sethash + (car info) + ;; Preserve number of unread articles in groups. + (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) + prev) + gnus-newsrc-hashtb) + (setq prev alist)) + (setq alist (cdr alist))) ;; Make the same select-methods in `gnus-server-alist' identical ;; as well. (while methods @@ -1859,8 +1815,7 @@ If SCAN, request a scan of that group as well." (defun gnus-parse-active () "Parse active info in the nntp server buffer." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) ;; Parse the result we got from `gnus-request-group'. (when (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+") @@ -2014,12 +1969,13 @@ If SCAN, request a scan of that group as well." (list "archive"))))) method) (setq gnus-have-read-active-file nil) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (while (setq method (pop methods)) ;; Only do each method once, in case the methods appear more ;; than once in this list. - (unless (member method methods) + (when (and (not (member method methods)) + ;; Check whether the backend exists. + (ignore-errors (gnus-get-function method 'open-server))) (if (or debug-on-error debug-on-quit) (gnus-read-active-file-1 method force) (condition-case () @@ -2030,17 +1986,20 @@ If SCAN, request a scan of that group as well." (message "Quit reading the active file") nil)))))))) -(defun gnus-read-active-file-1 (method force) +(defun gnus-read-active-file-1 (method force &optional infos) (let (where mesg) (setq where (nth 1 method) mesg (format "Reading active file%s via %s..." (if (and where (not (zerop (length where)))) (concat " from " where) "") (car method))) - (gnus-message 5 mesg) + (gnus-message 5 "%s" mesg) (when (gnus-check-server method) ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) + (when (and (or (and gnus-agent + (gnus-online method)) + (not gnus-agent)) + (gnus-check-backend-function 'request-scan (car method))) (gnus-request-scan nil method)) (cond ((and (eq gnus-read-active-file 'some) @@ -2066,17 +2025,16 @@ If SCAN, request a scan of that group as well." (unless (equal method gnus-message-archive-method) (gnus-error 1 "Cannot read active file from %s server" (car method))) - (gnus-message 5 mesg) + (gnus-message 5 "%s" mesg) (gnus-active-to-gnus-format method gnus-active-hashtb nil t) ;; We mark this active file as read. - (push method gnus-have-read-active-file) + (add-to-list 'gnus-have-read-active-file method) (gnus-message 5 "%sdone" mesg))))))) (defun gnus-read-active-file-2 (groups method) "Read an active file for GROUPS in METHOD using `gnus-retrieve-groups'." (when groups - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (gnus-check-server method) (let ((list-type (gnus-retrieve-groups groups method))) (cond ((not list-type) @@ -2757,8 +2715,7 @@ If FORCE is non-nil, the .newsrc file is read." (not force) (or (not gnus-dribble-buffer) (not (buffer-name gnus-dribble-buffer)) - (zerop (save-excursion - (set-buffer gnus-dribble-buffer) + (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) @@ -2892,8 +2849,7 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-gnus-to-newsrc-format () ;; Generate and save the .newsrc file. - (save-excursion - (set-buffer (create-file-buffer gnus-current-startup-file)) + (with-current-buffer (create-file-buffer gnus-current-startup-file) (let ((newsrc (cdr gnus-newsrc-alist)) (standard-output (current-buffer)) info ranges range method) @@ -2960,12 +2916,13 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-slave-mode () "Minor mode for slave Gnusae." + ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil): + ;; Remove, or fix and use define-minor-mode. (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) (gnus-run-hooks 'gnus-slave-mode-hook)) (defun gnus-slave-save-newsrc () - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (let ((slave-name (mm-make-temp-file (concat gnus-current-startup-file "-slave-"))) (modes (ignore-errors @@ -2989,8 +2946,7 @@ If FORCE is non-nil, the .newsrc file is read." (if (not slave-files) () ; There are no slave files to read. (gnus-message 7 "Reading slave newsrcs...") - (save-excursion - (set-buffer (gnus-get-buffer-create " *gnus slave*")) + (with-current-buffer (gnus-get-buffer-create " *gnus slave*") (setq slave-files (sort (mapcar (lambda (file) (list (nth 5 (file-attributes file)) file)) @@ -3058,6 +3014,7 @@ If FORCE is non-nil, the .newsrc file is read." nil) (t (save-excursion + ;; FIXME: Shouldn't save-restriction be done after set-buffer? (save-restriction (set-buffer nntp-server-buffer) (goto-char (point-min)) @@ -3109,8 +3066,7 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-group-get-description (group) "Get the description of a group by sending XGTITLE to the server." (when (gnus-request-group-description group) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (looking-at "[^ \t]+[ \t]+\\(.*\\)") (match-string 1))))) @@ -3137,20 +3093,6 @@ If this variable is nil, don't do anything." (gnus-boundp 'display-time-timer)) (display-time-event-handler))) -;;;###autoload -(defun gnus-fixup-nnimap-unread-after-getting-new-news () - (let (server group info) - (mapatoms - (lambda (sym) - (when (and (setq group (symbol-name sym)) - (gnus-group-entry group) - (setq info (symbol-value sym))) - (gnus-sethash group (cons (nth 2 info) (cdr (gnus-group-entry group))) - gnus-newsrc-hashtb))) - (if (boundp 'nnimap-mailbox-info) - (symbol-value 'nnimap-mailbox-info) - (make-vector 1 0))))) - (defun gnus-check-reasonable-setup () ;; Check whether nnml and nnfolder share a directory. (let ((display-warn @@ -3189,7 +3131,4 @@ If this variable is nil, don't do anything." (provide 'gnus-start) -;; arch-tag: f4584a22-b7b7-4853-abfc-a637329af5d2 ;;; gnus-start.el ends here - - diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 4a38a360d1..2d9986cac7 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -25,11 +25,14 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' (defvar tool-bar-mode) (defvar gnus-tmp-header) @@ -57,6 +60,8 @@ (autoload 'gnus-article-outlook-unwrap-lines "deuglify" nil t) (autoload 'gnus-article-outlook-repair-attribution "deuglify" nil t) (autoload 'gnus-article-outlook-rearrange-citation "deuglify" nil t) +(autoload 'nnir-article-rsv "nnir" nil nil 'macro) +(autoload 'nnir-article-group "nnir" nil nil 'macro) (defcustom gnus-kill-summary-on-exit t "*If non-nil, kill the summary buffer when you exit from it. @@ -73,6 +78,13 @@ See `gnus-group-goto-unread'." :version "23.1" ;; No Gnus :type 'boolean) +(defcustom gnus-summary-stop-at-end-of-message nil + "If non-nil, don't select the next message when using `SPC'." + :link '(custom-manual "(gnus)Group Maneuvering") + :group 'gnus-summary-maneuvering + :version "24.1" + :type 'boolean) + (defcustom gnus-fetch-old-headers nil "*Non-nil means that Gnus will try to build threads by grabbing old headers. If an unread article in the group refers to an older, already @@ -211,7 +223,7 @@ This variable will only be used if the value of :group 'gnus-summary-format :type 'string) -(defcustom gnus-summary-goto-unread t +(defcustom gnus-summary-goto-unread nil "*If t, many commands will go to the next unread article. This applies to marking commands as well as other commands that \"naturally\" select the next article, like, for instance, `SPC' at @@ -221,6 +233,7 @@ If nil, the marking commands do NOT go to the next unread article \(they go to the next article instead). If `never', commands that usually go to the next unread article, will go to the next article, whether it is read or not." + :version "24.1" :group 'gnus-summary-marks :link '(custom-manual "(gnus)Setting Marks") :type '(choice (const :tag "off" nil) @@ -339,7 +352,7 @@ newsgroups, set the variable to nil in `gnus-select-group-hook'." :type '(choice (const :tag "none" nil) (sexp :menu-tag "first" t))) -(defcustom gnus-auto-select-subject 'unread +(defcustom gnus-auto-select-subject 'unseen-or-unread "*Says what subject to place under point when entering a group. This variable can either be the symbols `first' (place point on the @@ -350,7 +363,7 @@ the first unseen article), `unseen-or-unread' (place point on the subject line of the first unseen article or, if all article have been seen, on the subject line of the first unread article), or a function to be called to place point on some subject line." - :version "22.1" + :version "24.1" :group 'gnus-group-select :type '(choice (const best) (const unread) @@ -440,8 +453,10 @@ and non-`vertical', do both horizontal and vertical recentering." (integer :tag "height") (sexp :menu-tag "both" t))) -(defvar gnus-auto-center-group t - "*If non-nil, always center the group buffer.") +(defcustom gnus-auto-center-group t + "If non-nil, always center the group buffer." + :group 'gnus-summary-maneuvering + :type 'boolean) (defcustom gnus-show-all-headers nil "*If non-nil, don't hide any headers." @@ -454,9 +469,16 @@ and non-`vertical', do both horizontal and vertical recentering." :group 'gnus-summary :type 'boolean) -(defcustom gnus-single-article-buffer t +(defcustom gnus-single-article-buffer nil "*If non-nil, display all articles in the same buffer. If nil, each group will get its own article buffer." + :version "24.1" + :group 'gnus-article-various + :type 'boolean) + +(defcustom gnus-widen-article-window nil + "If non-nil, selecting the article buffer will display only the article buffer." + :version "24.1" :group 'gnus-article-various :type 'boolean) @@ -528,11 +550,6 @@ string with the suggested prefix." :group 'gnus-summary-marks :type 'character) -(defcustom gnus-souped-mark ?F - "*Mark used for souped articles." - :group 'gnus-summary-marks - :type 'character) - (defcustom gnus-kill-file-mark ?X "*Mark used for articles killed by kill files." :group 'gnus-summary-marks @@ -656,9 +673,9 @@ string with the suggested prefix." (defcustom gnus-auto-expirable-marks (list gnus-killed-mark gnus-del-mark gnus-catchup-mark gnus-low-score-mark gnus-ancient-mark gnus-read-mark - gnus-souped-mark gnus-duplicate-mark) + gnus-duplicate-mark) "*The list of marks converted into expiration if a group is auto-expirable." - :version "21.1" + :version "24.1" :group 'gnus-summary :type '(repeat character)) @@ -978,8 +995,7 @@ This hook is not called from the non-updating exit commands like `Q'." :group 'gnus-various :type 'hook) -(defcustom gnus-summary-update-hook - (list 'gnus-summary-highlight-line) +(defcustom gnus-summary-update-hook nil "*A hook called when a summary line is changed. The hook will not be called if `gnus-visual' is nil. @@ -1248,7 +1264,7 @@ type of files to save." "Whether Gnus should parse all headers made available to it. This is mostly relevant for slow back ends where the user may wish to widen the summary buffer to include all headers -that were fetched. Say, for nnultimate groups." +that were fetched." :version "22.1" :group 'gnus-summary :type '(choice boolean regexp)) @@ -1347,6 +1363,16 @@ the normal Gnus MIME machinery." (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) (?k (gnus-summary-line-message-size gnus-tmp-header) ?s) (?L gnus-tmp-lines ?s) + (?Z (or ,(gnus-macroexpand-all + '(nnir-article-rsv (mail-header-number gnus-tmp-header))) + 0) ?d) + (?G (or ,(gnus-macroexpand-all + '(nnir-article-group (mail-header-number gnus-tmp-header))) + "") ?s) + (?g (or ,(gnus-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) @@ -1423,6 +1449,7 @@ the type of the variable (string, integer, character, etc).") (defvar gnus-newsgroup-last-directory nil) (defvar gnus-newsgroup-auto-expire nil) (defvar gnus-newsgroup-active nil) +(defvar gnus-newsgroup-highest nil) (defvar gnus-newsgroup-data nil) (defvar gnus-newsgroup-data-reverse nil) @@ -1533,27 +1560,41 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") (defvar gnus-summary-local-variables '(gnus-newsgroup-name + + ;; Marks lists + gnus-newsgroup-unreads + gnus-newsgroup-unselected + gnus-newsgroup-marked + gnus-newsgroup-spam-marked + gnus-newsgroup-reads + gnus-newsgroup-saved + gnus-newsgroup-replied + gnus-newsgroup-forwarded + gnus-newsgroup-recent + gnus-newsgroup-expirable + gnus-newsgroup-killed + gnus-newsgroup-unseen + gnus-newsgroup-seen + gnus-newsgroup-cached + gnus-newsgroup-downloadable + gnus-newsgroup-undownloaded + gnus-newsgroup-unsendable + gnus-newsgroup-begin gnus-newsgroup-end gnus-newsgroup-last-rmail gnus-newsgroup-last-mail gnus-newsgroup-last-folder gnus-newsgroup-last-file gnus-newsgroup-last-directory - gnus-newsgroup-auto-expire gnus-newsgroup-unreads - gnus-newsgroup-unselected gnus-newsgroup-marked - gnus-newsgroup-spam-marked - gnus-newsgroup-reads gnus-newsgroup-saved - gnus-newsgroup-replied gnus-newsgroup-forwarded - gnus-newsgroup-recent - gnus-newsgroup-expirable - gnus-newsgroup-processable gnus-newsgroup-killed - gnus-newsgroup-downloadable gnus-newsgroup-undownloaded + gnus-newsgroup-auto-expire + gnus-newsgroup-processable gnus-newsgroup-unfetched - gnus-newsgroup-unsendable gnus-newsgroup-unseen - gnus-newsgroup-seen gnus-newsgroup-articles + gnus-newsgroup-articles gnus-newsgroup-bookmarks gnus-newsgroup-dormant gnus-newsgroup-headers gnus-newsgroup-threads gnus-newsgroup-prepared gnus-summary-highlight-line-function gnus-current-article gnus-current-headers gnus-have-all-headers gnus-last-article gnus-article-internal-prepare-hook + (gnus-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 @@ -1562,12 +1603,13 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") (gnus-summary-mark-below . global) (gnus-orphan-score . global) gnus-newsgroup-active gnus-scores-exclude-files + gnus-newsgroup-highest gnus-newsgroup-history gnus-newsgroup-ancient gnus-newsgroup-sparse gnus-newsgroup-process-stack (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring) gnus-newsgroup-adaptive-score-file (gnus-reffed-article-number . -1) (gnus-newsgroup-expunged-tally . 0) - gnus-cache-removable-articles gnus-newsgroup-cached + gnus-cache-removable-articles gnus-newsgroup-data gnus-newsgroup-data-reverse gnus-newsgroup-limit gnus-newsgroup-limits gnus-newsgroup-charset gnus-newsgroup-display @@ -1850,7 +1892,6 @@ increase the score of each group you read." "=" gnus-summary-expand-window "\C-x\C-s" gnus-summary-reselect-current-group "\M-g" gnus-summary-rescan-group - "w" gnus-summary-stop-page-breaking "\C-c\C-r" gnus-summary-caesar-message "f" gnus-summary-followup "F" gnus-summary-followup-with-original @@ -1872,9 +1913,9 @@ increase the score of each group you read." [follow-link] mouse-face "m" gnus-summary-mail-other-window "a" gnus-summary-post-news - "i" gnus-summary-news-other-window "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article + [tab] gnus-summary-widget-forward "t" gnus-summary-toggle-header "g" gnus-summary-show-article "l" gnus-summary-goto-last-article @@ -2031,11 +2072,14 @@ increase the score of each group you read." "e" gnus-summary-end-of-article "^" gnus-summary-refer-parent-article "r" gnus-summary-refer-parent-article + "C" gnus-summary-show-complete-article "D" gnus-summary-enter-digest-group "R" gnus-summary-refer-references "T" gnus-summary-refer-thread + "W" gnus-warp-to-article "g" gnus-summary-show-article "s" gnus-summary-isearch-article + [tab] gnus-summary-widget-forward "P" gnus-summary-print-article "S" gnus-sticky-article "M" gnus-mailing-list-insinuate @@ -2068,6 +2112,7 @@ increase the score of each group you read." "a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive "p" gnus-article-verify-x-pgp-sig "d" gnus-article-treat-dumbquotes + "U" gnus-article-treat-non-ascii "i" gnus-summary-idna-message) (gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map) @@ -2105,9 +2150,12 @@ increase the score of each group you read." "d" gnus-article-display-face "s" gnus-treat-smiley "D" gnus-article-remove-images + "W" gnus-article-show-images "f" gnus-treat-from-picon "m" gnus-treat-mail-picon - "n" gnus-treat-newsgroups-picon) + "n" gnus-treat-newsgroups-picon + "g" gnus-treat-from-gravatar + "h" gnus-treat-mail-gravatar) (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) "w" gnus-article-decode-mime-words @@ -2137,12 +2185,9 @@ increase the score of each group you read." (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) "v" gnus-version - "f" gnus-summary-fetch-faq "d" gnus-summary-describe-group "h" gnus-summary-describe-briefly - "i" gnus-info-find-node - "c" gnus-group-fetch-charter - "C" gnus-group-fetch-control) + "i" gnus-info-find-node) (gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) "e" gnus-summary-expire-articles @@ -2172,8 +2217,7 @@ increase the score of each group you read." "h" gnus-summary-save-article-folder "v" gnus-summary-save-article-vm "p" gnus-summary-pipe-output - "P" gnus-summary-muttprint - "s" gnus-soup-add-article) + "P" gnus-summary-muttprint) (gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) "b" gnus-summary-display-buttonized @@ -2358,6 +2402,8 @@ increase the score of each group you read." ["Show picons in From" gnus-treat-from-picon t] ["Show picons in mail headers" gnus-treat-mail-picon t] ["Show picons in news headers" gnus-treat-newsgroups-picon t] + ["Show Gravatars in From" gnus-treat-from-gravatar t] + ["Show Gravatars in mail headers" gnus-treat-mail-gravatar t] ("View as different encoding" ,@(gnus-summary-menu-split (mapcar @@ -2391,6 +2437,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) gnus-article-remove-leading-whitespace t]) ["Overstrike" gnus-article-treat-overstrike t] ["Dumb quotes" gnus-article-treat-dumbquotes t] + ["Non-ASCII" gnus-article-treat-non-ascii t] ["Emphasis" gnus-article-emphasize t] ["Word wrap" gnus-article-fill-cited-article t] ["Fill long lines" gnus-article-fill-long-lines t] @@ -2437,7 +2484,6 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Save in RMAIL mbox..." gnus-summary-save-article-rmail t] ["Save body in file..." gnus-summary-save-article-body-file t] ["Pipe through a filter..." gnus-summary-pipe-output t] - ["Add to SOUP packet" gnus-soup-add-article t] ["Print with Muttprint..." gnus-summary-muttprint t] ["Print" gnus-summary-print-article ,@(if (featurep 'xemacs) '(t) @@ -2635,17 +2681,6 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Set expirable mark" gnus-summary-mark-as-expirable t] ["Set bookmark" gnus-summary-set-bookmark t] ["Remove bookmark" gnus-summary-remove-bookmark t]) - ("Registry Mark" - ["Important" gnus-registry-set-article-Important-mark t] - ["Not Important" gnus-registry-remove-article-Important-mark t] - ["Work" gnus-registry-set-article-Work-mark t] - ["Not Work" gnus-registry-remove-article-Work-mark t] - ["Later" gnus-registry-set-article-Later-mark t] - ["Not Later" gnus-registry-remove-article-Later-mark t] - ["Personal" gnus-registry-set-article-Personal-mark t] - ["Not Personal" gnus-registry-remove-article-Personal-mark t] - ["To Do" gnus-registry-set-article-To-Do-mark t] - ["Not To Do" gnus-registry-remove-article-To-Do-mark t]) ("Limit to" ["Marks..." gnus-summary-limit-to-marks t] ["Subject..." gnus-summary-limit-to-subject t] @@ -2691,6 +2726,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) gnus-newsgroup-process-stack] ["Save" gnus-summary-save-process-mark t] ["Run command on marked..." gnus-summary-universal-argument t])) + ("Registry Marks") ("Scroll article" ["Page forward" gnus-summary-next-page ,@(if (featurep 'xemacs) '(t) @@ -2728,14 +2764,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Randomize" gnus-summary-sort-by-random t] ["Original sort" gnus-summary-sort-by-original t]) ("Help" - ["Fetch group FAQ" gnus-summary-fetch-faq t] ["Describe group" gnus-summary-describe-group t] - ["Fetch charter" gnus-group-fetch-charter - ,@(if (featurep 'xemacs) nil - '(:help "Display the charter of the current group"))] - ["Fetch control message" gnus-group-fetch-control - ,@(if (featurep 'xemacs) nil - '(:help "Display the archived control message for the current group"))] ["Read manual" gnus-info-find-node t]) ("Modes" ["Pick and read" gnus-pick-mode t] @@ -3027,7 +3056,7 @@ When FORCE, rebuild the tool bar." (declare-function turn-on-gnus-mailing-list-mode "gnus-ml" ()) - +(defvar bookmark-make-record-function) (defun gnus-summary-mode (&optional group) @@ -3063,7 +3092,6 @@ The following commands are available: (gnus-simplify-mode-line) (setq major-mode 'gnus-summary-mode) (setq mode-name "Summary") - (make-local-variable 'minor-mode-alist) (use-local-map gnus-summary-mode-map) (buffer-disable-undo) (setq buffer-read-only t ;Disable modification @@ -3082,6 +3110,8 @@ The following commands are available: (gnus-run-mode-hooks 'gnus-summary-mode-hook) (turn-on-gnus-mailing-list-mode) (mm-enable-multibyte) + (set (make-local-variable 'bookmark-make-record-function) + 'gnus-summary-bookmark-make-record) (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) (gnus-update-summary-mark-positions)) @@ -3100,16 +3130,6 @@ The following commands are available: ;; Simple nil-valued local variable. (set (make-local-variable local) nil))))) -(defun gnus-summary-clear-local-variables () - (let ((locals gnus-summary-local-variables)) - (while locals - (if (consp (car locals)) - (and (symbolp (caar locals)) - (set (caar locals) nil)) - (and (symbolp (car locals)) - (set (car locals) nil))) - (setq locals (cdr locals))))) - ;; Summary data functions. (defmacro gnus-data-number (data) @@ -3412,8 +3432,10 @@ marks of articles." (save-excursion (let (config) (goto-char (point-min)) - (while (search-forward "\r" nil t) - (push (1- (point)) config)) + (while (not (eobp)) + (when (eq (get-char-property (point-at-eol) 'invisible) 'gnus-sum) + (push (save-excursion (forward-line 0) (point)) config)) + (forward-line 1)) config))) (defun gnus-restore-hidden-threads-configuration (config) @@ -3421,10 +3443,8 @@ marks of articles." (save-excursion (let (point (inhibit-read-only t)) (while (setq point (pop config)) - (when (and (< point (point-max)) - (goto-char point) - (eq (char-after) ?\n)) - (subst-char-in-region point (1+ point) ?\n ?\r)))))) + (goto-char point) + (gnus-summary-hide-thread))))) ;; Various summary mode internalish functions. @@ -3494,8 +3514,6 @@ display only a single character." ;; Fix by Sudish Joseph <[email protected]> (setq gnus-summary-buffer (set-buffer (gnus-get-buffer-create buffer))) (gnus-summary-mode group) - (when gnus-carpal - (gnus-carpal-setup-buffer 'summary)) (when (gnus-group-quit-config group) (set (make-local-variable 'gnus-single-article-buffer) nil)) (make-local-variable 'gnus-article-buffer) @@ -3758,6 +3776,7 @@ buffer that was in action when the last article was fetched." (error (gnus-message 5 "Error updating the summary line"))) (when (gnus-visual-p 'summary-highlight 'highlight) (forward-line -1) + (gnus-summary-highlight-line) (gnus-run-hooks 'gnus-summary-update-hook) (forward-line 1)))) @@ -3790,6 +3809,7 @@ buffer that was in action when the last article was fetched." 'score)) ;; Do visual highlighting. (when (gnus-visual-p 'summary-highlight 'highlight) + (gnus-summary-highlight-line) (gnus-run-hooks 'gnus-summary-update-hook))))) (defvar gnus-tmp-new-adopts nil) @@ -3836,7 +3856,8 @@ This function is intended to be used in (defun gnus-summary-set-local-parameters (group) "Go through the local params of GROUP and set all variable specs in that list." - (let ((vars '(quit-config))) ; Ignore quit-config. + (let ((vars '(quit-config active))) ; Ignore things that aren't + ; really variables. (dolist (elem (gnus-group-find-parameter group)) (and (consp elem) ; Has to be a cons. (consp (cdr elem)) ; The cdr has to be a list. @@ -3937,7 +3958,6 @@ If NO-DISPLAY, don't generate a summary buffer." (progn (set-buffer gnus-group-buffer) (gnus-group-jump-to-group group) - (gnus-group-next-unread-group 1) (gnus-configure-windows 'group 'force)) (gnus-handle-ephemeral-exit quit-config)) ;; Finally signal the quit. @@ -3949,6 +3969,7 @@ If NO-DISPLAY, don't generate a summary buffer." (setq gnus-newsgroup-active (gnus-copy-sequence (gnus-active gnus-newsgroup-name))) + (setq gnus-newsgroup-highest (cdr gnus-newsgroup-active)) ;; You can change the summary buffer in some way with this hook. (gnus-run-hooks 'gnus-select-group-hook) (when (memq 'summary (gnus-update-format-specifications @@ -4504,7 +4525,7 @@ the id of the parent article (if any)." (while (not (eobp)) (ignore-errors (setq article (read (current-buffer)) - header (gnus-nov-parse-line article dependencies))) + header (gnus-nov-parse-line article dependencies t))) (when header (with-current-buffer gnus-summary-buffer (push header gnus-newsgroup-headers) @@ -4826,7 +4847,8 @@ If LINE, insert the rebuilt thread starting on line LINE." ;; Even after binding max-lisp-eval-depth, the recursive ;; sorter might fail for very long threads. In that case, ;; try using a (less well-tested) non-recursive sorter. - (error (gnus-sort-threads-loop + (error (gnus-message 9 "Sorting threads with loop...") + (gnus-sort-threads-loop threads (gnus-make-sort-function gnus-thread-sort-functions)))) (gnus-message 8 "Sorting threads...done")))) @@ -4979,6 +5001,10 @@ Unscored articles will be counted as having a score of zero." (t (gnus-thread-total-score-1 (list thread))))) +(defun gnus-article-sort-by-most-recent-number (h1 h2) + "Sort articles by number." + (gnus-article-sort-by-number h1 h2)) + (defun gnus-thread-sort-by-most-recent-number (h1 h2) "Sort threads such that the thread with the most recently arrived article comes first." (> (gnus-thread-highest-number h1) (gnus-thread-highest-number h2))) @@ -4989,26 +5015,25 @@ Unscored articles will be counted as having a score of zero." (mail-header-number header)) (message-flatten-list thread)))) +(defun gnus-article-sort-by-most-recent-date (h1 h2) + "Sort articles by number." + (gnus-article-sort-by-date h1 h2)) + (defun gnus-thread-sort-by-most-recent-date (h1 h2) "Sort threads such that the thread with the most recently dated article comes first." (> (gnus-thread-latest-date h1) (gnus-thread-latest-date h2))) +; Since this is called not only to sort the top-level threads, but +; also in recursive sorts to order the articles within a thread, each +; article will be processed many times. Thus it speeds things up +; quite a bit to use gnus-date-get-time, which caches the time value. (defun gnus-thread-latest-date (thread) "Return the highest article date in THREAD." - (let ((previous-time 0)) - (apply 'max - (mapcar - (lambda (header) - (setq previous-time - (condition-case () - (gnus-float-time (mail-header-parse-date - (mail-header-date header))) - (error previous-time)))) - (sort - (message-flatten-list thread) - (lambda (h1 h2) - (< (mail-header-number h1) - (mail-header-number h2)))))))) + (apply 'max + (mapcar (lambda (header) (gnus-float-time + (gnus-date-get-time + (mail-header-date header)))) + (message-flatten-list thread)))) (defun gnus-thread-total-score-1 (root) ;; This function find the total score of the thread below ROOT. @@ -5367,16 +5392,18 @@ or a straight list of headers." (if (= gnus-tmp-lines -1) (setq gnus-tmp-lines "?") (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) - (gnus-put-text-property - (point) - (progn (eval gnus-summary-line-format-spec) (point)) - 'gnus-number number) - (when gnus-visual-p - (forward-line -1) - (gnus-run-hooks 'gnus-summary-update-hook) - (forward-line 1)) - - (setq gnus-tmp-prev-subject simp-subject))) + (gnus-put-text-property + (point) + (progn (eval gnus-summary-line-format-spec) (point)) + 'gnus-number number) + (when gnus-visual-p + (forward-line -1) + (gnus-summary-highlight-line) + (when gnus-summary-update-hook + (gnus-run-hooks 'gnus-summary-update-hook)) + (forward-line 1)) + + (setq gnus-tmp-prev-subject simp-subject))) (when (nth 1 thread) (push (list (max 0 gnus-tmp-level) @@ -5460,7 +5487,7 @@ or a straight list of headers." (substring subject (match-end 1))))) (mail-header-set-subject header subject)))))) -(defun gnus-fetch-headers (articles) +(defun gnus-fetch-headers (articles &optional limit force-new dependencies) "Fetch headers of ARTICLES." (let ((name (gnus-group-decoded-name gnus-newsgroup-name))) (gnus-message 5 "Fetching headers for %s..." name) @@ -5469,16 +5496,17 @@ or a straight list of headers." (setq gnus-headers-retrieved-by (gnus-retrieve-headers articles gnus-newsgroup-name - ;; We might want to fetch old headers, but - ;; not if there is only 1 article. - (and (or (and - (not (eq gnus-fetch-old-headers 'some)) - (not (numberp gnus-fetch-old-headers))) - (> (length articles) 1)) - gnus-fetch-old-headers)))) + (or limit + ;; We might want to fetch old headers, but + ;; not if there is only 1 article. + (and (or (and + (not (eq gnus-fetch-old-headers 'some)) + (not (numberp gnus-fetch-old-headers))) + (> (length articles) 1)) + gnus-fetch-old-headers))))) (gnus-get-newsgroup-headers-xover - articles nil nil gnus-newsgroup-name t) - (gnus-get-newsgroup-headers)) + articles force-new dependencies gnus-newsgroup-name t) + (gnus-get-newsgroup-headers dependencies force-new)) (gnus-message 5 "Fetching headers for %s...done" name)))) (defun gnus-select-newsgroup (group &optional read-all select-articles) @@ -5511,11 +5539,11 @@ If SELECT-ARTICLES, only select those articles from GROUP." (mm-decode-coding-string (gnus-status-message group) charset)))) (unless (gnus-request-group group t) - (when (equal major-mode 'gnus-summary-mode) - (gnus-kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" - (mm-decode-coding-string group charset) - (mm-decode-coding-string (gnus-status-message group) charset))) + (when (equal major-mode 'gnus-summary-mode) + (gnus-kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + (mm-decode-coding-string group charset) + (mm-decode-coding-string (gnus-status-message group) charset))) (when gnus-agent (gnus-agent-possibly-alter-active group (gnus-active group) info) @@ -5575,7 +5603,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq gnus-newsgroup-processable nil) - (gnus-update-read-articles group gnus-newsgroup-unreads) + (gnus-update-read-articles group gnus-newsgroup-unreads t) ;; Adjust and set lists of article marks. (when info @@ -5671,17 +5699,17 @@ If SELECT-ARTICLES, only select those articles from GROUP." (unseen . unseen)) gnus-article-mark-lists)) (push (cons (cdr elem) - (gnus-byte-compile + (gnus-byte-compile ;Why bother? `(lambda () (gnus-article-marked-p ',(cdr elem))))) gnus-summary-display-cache))) (let ((gnus-category-predicate-alist gnus-summary-display-cache) (gnus-category-predicate-cache gnus-summary-display-cache)) (gnus-get-predicate display))) -;; Uses the dynamically bound `number' variable. -(defvar number) +;; Uses the dynamically bound `gnus-number' variable. +(defvar gnus-number) (defun gnus-article-marked-p (type &optional article) - (let ((article (or article number))) + (let ((article (or article gnus-number))) (cond ((eq type 'tick) (memq article gnus-newsgroup-marked)) @@ -5857,6 +5885,10 @@ If SELECT-ARTICLES, only select those articles from GROUP." (types gnus-article-mark-lists) marks var articles article mark mark-type bgn end) + ;; Hack to avoid adjusting marks for imap. + (when (eq (car (gnus-find-method-for-group (gnus-info-group info))) + 'nnimap) + (setq min 1)) (dolist (marks marked-lists) (setq mark (car marks) @@ -5979,6 +6011,10 @@ If SELECT-ARTICLES, only select those articles from GROUP." (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del + ;; Don't delete marks from outside the active range. This + ;; shouldn't happen, but is a sanity check. + (setq del (gnus-sorted-range-intersection + (gnus-active gnus-newsgroup-name) del)) (push (list del 'del (list (cdr type))) delta-marks)))) (when list @@ -6061,9 +6097,7 @@ If WHERE is `summary', the summary mode line format will be used." (when (> (length mode-string) max-len) (setq mode-string (concat (truncate-string-to-width mode-string (- max-len 3)) - "..."))) - ;; Pad the mode string a bit. - (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) + "..."))))) ;; Update the mode line. (setq mode-line-buffer-identification (gnus-mode-line-buffer-identification (list mode-string))) @@ -6100,8 +6134,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." "Look through all the headers and mark the Xrefs as read." (let ((virtual (gnus-virtual-group-p from-newsgroup)) name info xref-hashtb idlist method nth4) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (when (setq xref-hashtb (gnus-create-xref-hashtb from-newsgroup headers unreads)) (mapatoms @@ -6173,7 +6206,13 @@ The resulting hash table is returned, or nil if no Xrefs were found." (info (nth 2 entry)) (active (gnus-active group)) range) - (when entry + (if (not entry) + ;; Group that Gnus doesn't know exists, but still allow the + ;; backend to set marks. + (gnus-request-set-mark + group (list (list (gnus-compress-sequence (sort articles #'<)) + 'add '(read)))) + ;; Normal, subscribed groups. (setq range (gnus-compute-read-articles group articles)) (with-current-buffer gnus-group-buffer (gnus-undo-register @@ -6208,8 +6247,6 @@ The resulting hash table is returned, or nil if no Xrefs were found." (unless (gnus-ephemeral-group-p group) (gnus-group-update-group group t)))))) -(defvar gnus-newsgroup-none-id 0) - (defun gnus-get-newsgroup-headers (&optional dependencies force-new) (let ((cur nntp-server-buffer) (dependencies @@ -6927,11 +6964,19 @@ displayed, no centering will be performed." ;; Various summary commands (defun gnus-summary-select-article-buffer () - "Reconfigure windows to show article buffer." + "Reconfigure windows to show the article buffer. +If `gnus-widen-article-buffer' is set, show only the article +buffer." (interactive) (if (not (gnus-buffer-live-p gnus-article-buffer)) (error "There is no article buffer for this summary buffer") - (gnus-configure-windows 'article) + (unless (get-buffer-window gnus-article-buffer) + (gnus-summary-show-article)) + (gnus-configure-windows + (if gnus-widen-article-window + 'only-article + 'article) + t) (select-window (get-buffer-window gnus-article-buffer)))) (defun gnus-summary-universal-argument (arg) @@ -7004,7 +7049,11 @@ The prefix argument ALL means to select all articles." (defun gnus-summary-rescan-group (&optional all) "Exit the newsgroup, ask for new articles, and select the newsgroup." (interactive "P") - (gnus-summary-reselect-current-group all t)) + (let ((config gnus-current-window-configuration)) + (gnus-summary-reselect-current-group all t) + (gnus-configure-windows config) + (when (eq config 'article) + (gnus-summary-select-article)))) (defun gnus-summary-update-info (&optional non-destructive) (save-excursion @@ -7081,15 +7130,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (when gnus-use-scoring (gnus-score-save))) (gnus-run-hooks 'gnus-summary-prepare-exit-hook) - ;; If we have several article buffers, we kill them at exit. - (unless gnus-single-article-buffer - (when (gnus-buffer-live-p gnus-article-buffer) - (with-current-buffer gnus-article-buffer - ;; Don't kill sticky article buffers - (unless (eq major-mode 'gnus-sticky-article-mode) - (gnus-kill-buffer gnus-article-buffer) - (setq gnus-article-current nil)))) - (gnus-kill-buffer gnus-original-article-buffer)) (when gnus-use-cache (gnus-cache-possibly-remove-articles) (gnus-cache-save-buffers)) @@ -7126,18 +7166,22 @@ If FORCE (the prefix), also save the .newsrc file(s)." (progn (gnus-deaden-summary) (setq mode nil)) - ;; We set all buffer-local variables to nil. It is unclear why - ;; this is needed, but if we don't, buffer-local variables are - ;; not garbage-collected, it seems. This would the lead to en - ;; ever-growing Emacs. - (gnus-summary-clear-local-variables) - (let ((gnus-summary-local-variables gnus-newsgroup-variables)) - (gnus-summary-clear-local-variables)) (when (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) ;; Return to group mode buffer. (when (eq mode 'gnus-summary-mode) (gnus-kill-buffer buf))) + + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (when (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + ;; Don't kill sticky article buffers + (unless (eq major-mode 'gnus-sticky-article-mode) + (gnus-kill-buffer gnus-article-buffer) + (setq gnus-article-current nil)))) + (gnus-kill-buffer gnus-original-article-buffer)) + (setq gnus-current-select-method gnus-select-method) (set-buffer gnus-group-buffer) (if quit-config @@ -7180,9 +7224,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if (not gnus-kill-summary-on-exit) (gnus-deaden-summary) (gnus-close-group group) - (gnus-summary-clear-local-variables) - (let ((gnus-summary-local-variables gnus-newsgroup-variables)) - (gnus-summary-clear-local-variables)) (gnus-kill-buffer gnus-summary-buffer)) (unless gnus-single-article-buffer (setq gnus-article-current nil)) @@ -7246,33 +7287,21 @@ The state which existed when entering the ephemeral is reset." ;;; Dead summaries. -(defvar gnus-dead-summary-mode-map nil) - -(unless gnus-dead-summary-mode-map - (setq gnus-dead-summary-mode-map (make-keymap)) - (suppress-keymap gnus-dead-summary-mode-map) - (substitute-key-definition - 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map) - (dolist (key '("\C-d" "\r" "\177" [delete])) - (define-key gnus-dead-summary-mode-map - key 'gnus-summary-wake-up-the-dead)) - (dolist (key '("q" "Q")) - (define-key gnus-dead-summary-mode-map key 'bury-buffer))) - -(defvar gnus-dead-summary-mode nil - "Minor mode for Gnus summary buffers.") - -(defun gnus-dead-summary-mode (&optional arg) +(defvar gnus-dead-summary-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (substitute-key-definition 'undefined 'gnus-summary-wake-up-the-dead map) + (dolist (key '("\C-d" "\r" "\177" [delete])) + (define-key map key 'gnus-summary-wake-up-the-dead)) + (dolist (key '("q" "Q")) + (define-key map key 'bury-buffer)) + map)) + +(define-minor-mode gnus-dead-summary-mode "Minor mode for Gnus summary buffers." - (interactive "P") - (when (eq major-mode 'gnus-summary-mode) - (make-local-variable 'gnus-dead-summary-mode) - (setq gnus-dead-summary-mode - (if (null arg) (not gnus-dead-summary-mode) - (> (prefix-numeric-value arg) 0))) - (when gnus-dead-summary-mode - (add-minor-mode - 'gnus-dead-summary-mode " Dead" gnus-dead-summary-mode-map)))) + :lighter " Dead" :keymap gnus-dead-summary-mode-map + (unless (derived-mode-p 'gnus-summary-mode) + (setq gnus-dead-summary-mode nil))) (defun gnus-deaden-summary () "Make the current summary buffer into a dead summary buffer." @@ -7326,23 +7355,6 @@ The state which existed when entering the ephemeral is reset." t))) (gnus-message 3 "This dead summary is now alive again")) -;; Suggested by Andrew Eskilsson <[email protected]>. -(defun gnus-summary-fetch-faq (&optional faq-dir) - "Fetch the FAQ for the current group. -If FAQ-DIR (the prefix), prompt for a directory to search for the faq -in." - (interactive - (list - (when current-prefix-arg - (completing-read - "FAQ dir: " (and (listp gnus-group-faq-directory) - (mapcar 'list - gnus-group-faq-directory)))))) - (let (gnus-faq-buffer) - (when (setq gnus-faq-buffer - (gnus-group-fetch-faq gnus-newsgroup-name faq-dir)) - (gnus-configure-windows 'summary-faq)))) - ;; Suggested by Per Abrahamsen <[email protected]>. (defun gnus-summary-describe-group (&optional force) "Describe the current newsgroup." @@ -7352,7 +7364,7 @@ in." (defun gnus-summary-describe-briefly () "Describe summary mode commands briefly." (interactive) - (gnus-message 6 (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help"))) + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help"))) ;; Walking around group mode buffer from summary mode. @@ -7416,7 +7428,7 @@ If prefix argument NO-ARTICLE is non-nil, no article is selected initially." "Go to the first subject satisfying any non-nil constraint. If UNREAD is non-nil, the article should be unread. If UNDOWNLOADED is non-nil, the article should be undownloaded. -If UNSEEN is non-nil, the article should be unseen. +If UNSEEN is non-nil, the article should be unseen as well as unread. Returns the article selected or nil if there are no matching articles." (interactive "P") (cond @@ -7439,7 +7451,8 @@ Returns the article selected or nil if there are no matching articles." (and undownloaded (memq num gnus-newsgroup-undownloaded)) (and unseen - (memq num gnus-newsgroup-unseen))))))) + (memq num gnus-newsgroup-unseen) + (memq num gnus-newsgroup-unreads))))))) (setq data (cdr data))) (prog1 (if data @@ -7599,9 +7612,11 @@ be displayed." (null (get-buffer gnus-article-buffer)) (not (eq article (cdr gnus-article-current))) (not (equal (car gnus-article-current) - gnus-newsgroup-name)))) + gnus-newsgroup-name)) + (not (get-buffer gnus-original-article-buffer)))) (and (not gnus-single-article-buffer) (or (null gnus-current-article) + (not (get-buffer gnus-original-article-buffer)) (not (eq gnus-current-article article)))) force) ;; The requested article is different from the current article. @@ -7672,9 +7687,6 @@ If BACKWARD, the previous article is selected instead of the next." (if (eq gnus-keep-same-level 'best) (gnus-summary-best-group gnus-newsgroup-name) (gnus-summary-search-group backward gnus-keep-same-level)))) - ;; For some reason, the group window gets selected. We change - ;; it back. - (select-window (get-buffer-window (current-buffer))) ;; Select next unread newsgroup automagically. (cond ((or (not gnus-auto-select-next) @@ -7805,7 +7817,7 @@ Also see the variable `gnus-article-skip-boring'." (setq endp (or (gnus-article-next-page lines) (gnus-article-only-boring-p)))) (when endp - (cond (stop + (cond ((or stop gnus-summary-stop-at-end-of-message) (gnus-message 3 "End of message")) (circular (gnus-summary-beginning-of-article)) @@ -7858,7 +7870,8 @@ If at the beginning of the article, go to the next article." (defun gnus-summary-scroll-up (lines) "Scroll up (or down) one line current article. -Argument LINES specifies lines to be scrolled up (or down if negative)." +Argument LINES specifies lines to be scrolled up (or down if negative). +If no article is selected, then the current article will be selected first." (interactive "p") (gnus-configure-windows 'article) (gnus-summary-show-thread) @@ -7874,7 +7887,8 @@ Argument LINES specifies lines to be scrolled up (or down if negative)." (defun gnus-summary-scroll-down (lines) "Scroll down (or up) one line current article. -Argument LINES specifies lines to be scrolled down (or up if negative)." +Argument LINES specifies lines to be scrolled down (or up if negative). +If no article is selected, then the current article will be selected first." (interactive "p") (gnus-summary-scroll-up (- lines))) @@ -7930,8 +7944,8 @@ Return nil if there are no unseen articles." (gnus-summary-position-point))) (defun gnus-summary-first-unseen-or-unread-subject () - "Place the point on the subject line of the first unseen article or, -if all article have been seen, on the subject line of the first unread + "Place the point on the subject line of the first unseen and unread article. +If all article have been seen, on the subject line of the first unread article." (interactive) (prog1 @@ -8013,10 +8027,9 @@ If FORCE, go to the article even if it isn't displayed. If FORCE is a number, it is the line the article is to be displayed on." (interactive (list - (completing-read - "Article number or Message-ID: " - (mapcar (lambda (number) (list (int-to-string number))) - gnus-newsgroup-limit)) + (gnus-completing-read + "Article number or Message-ID" + (mapcar 'int-to-string gnus-newsgroup-limit)) current-prefix-arg t)) (prog1 @@ -8203,14 +8216,15 @@ in `nnmail-extra-headers'." (gnus-summary-position-point)))) (defun gnus-summary-limit-strange-charsets-predicate (header) - (let ((string (concat (mail-header-subject header) - (mail-header-from header))) - charset found) - (dotimes (i (1- (length string))) - (setq charset (format "%s" (char-charset (aref string (1+ i))))) - (when (string-match "unicode\\|big\\|japanese" charset) - (setq found t))) - found)) + (when (fboundp 'char-charset) + (let ((string (concat (mail-header-subject header) + (mail-header-from header))) + charset found) + (dotimes (i (1- (length string))) + (setq charset (format "%s" (char-charset (aref string (1+ i))))) + (when (string-match "unicode\\|big\\|japanese" charset) + (setq found t))) + found))) (defun gnus-summary-limit-to-predicate (predicate) "Limit to articles where PREDICATE returns non-nil. @@ -8255,9 +8269,7 @@ articles that are younger than AGE days." (when (and (vectorp (gnus-data-header d)) (setq date (mail-header-date (gnus-data-header d)))) (setq is-younger (time-less-p - (time-since (condition-case () - (date-to-time date) - (error '(0 0)))) + (time-since (gnus-date-get-time date)) cutoff)) (when (if younger-p is-younger @@ -8271,16 +8283,13 @@ articles that are younger than AGE days." (interactive (let ((header (intern - (gnus-completing-read-with-default - (symbol-name (car gnus-extra-headers)) + (gnus-completing-read (if current-prefix-arg "Exclude extra header" "Limit extra header") - (mapcar (lambda (x) - (cons (symbol-name x) x)) - gnus-extra-headers) - nil - t)))) + (mapcar 'symbol-name gnus-extra-headers) + t nil nil + (symbol-name (car gnus-extra-headers)))))) (list header (read-string (format "%s header %s (regexp): " (if current-prefix-arg "Exclude" "Limit to") @@ -8302,16 +8311,12 @@ articles that are younger than AGE days." (unless gnus-newsgroup-display (error "There is no `display' group parameter")) (let (articles) - (dolist (number gnus-newsgroup-articles) + (dolist (gnus-number gnus-newsgroup-articles) (when (funcall gnus-newsgroup-display) - (push number articles))) + (push gnus-number articles))) (gnus-summary-limit articles)) (gnus-summary-position-point)) -(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) -(make-obsolete - 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread "Emacs 20.4") - (defun gnus-summary-limit-to-unread (&optional all) "Limit the summary buffer to articles that are not marked as read. If ALL is non-nil, limit strictly to unread articles." @@ -8325,7 +8330,7 @@ If ALL is non-nil, limit strictly to unread articles." gnus-killed-mark gnus-spam-mark gnus-kill-file-mark gnus-low-score-mark gnus-expirable-mark gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark - gnus-duplicate-mark gnus-souped-mark) + gnus-duplicate-mark) 'reverse))) (defun gnus-summary-limit-to-headers (match &optional reverse) @@ -8351,8 +8356,7 @@ If REVERSE (the prefix), limit to articles that don't match." (dolist (data gnus-newsgroup-data) (let (gnus-mark-article-hook) (gnus-summary-select-article t t nil (gnus-data-number data))) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (article-goto-body) (let* ((case-fold-search t) (found (if headersp @@ -8403,10 +8407,6 @@ If UNREPLIED (the prefix), limit to unreplied articles." (gnus-summary-limit gnus-newsgroup-replied)) (gnus-summary-position-point)) -(defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-exclude-marks) -(make-obsolete 'gnus-summary-delete-marked-with - 'gnus-summary-limit-exclude-marks "Emacs 20.4") - (defun gnus-summary-limit-exclude-marks (marks &optional reverse) "Exclude articles that are marked with MARKS (e.g. \"DK\"). If REVERSE, limit the summary buffer to articles that are marked @@ -8462,7 +8462,11 @@ When called interactively, ID is the Message-ID of the current article." (interactive (list (mail-header-id (gnus-summary-article-header)))) (let ((articles (gnus-articles-in-thread - (gnus-id-to-thread (gnus-root-id id))))) + (gnus-id-to-thread (gnus-root-id id)))) + ;;we REALLY want the whole thread---this prevents cut-threads + ;;from removing the thread we want to include. + (gnus-fetch-old-headers nil) + (gnus-build-sparse-threads nil)) (prog1 (gnus-summary-limit (nconc articles gnus-newsgroup-limit)) (gnus-summary-limit-include-matching-articles @@ -8507,6 +8511,18 @@ fetched for this group." (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit)) (gnus-summary-position-point))) +(defun gnus-summary-include-articles (articles) + "Fetch the headers for ARTICLES and then display the summary lines." + (let ((gnus-inhibit-demon t) + (gnus-agent nil) + (gnus-read-all-available-headers t)) + (setq gnus-newsgroup-headers + (gnus-merge + 'list gnus-newsgroup-headers + (gnus-fetch-headers articles nil t) + 'gnus-article-sort-by-number)) + (gnus-summary-limit (append articles gnus-newsgroup-limit)))) + (defun gnus-summary-limit-exclude-dormant () "Hide all dormant articles." (interactive) @@ -8669,8 +8685,7 @@ fetch-old-headers verbiage, and so on." (null gnus-summary-expunge-below) (not (eq gnus-build-sparse-threads 'some)) (not (eq gnus-build-sparse-threads 'more)) - (null gnus-thread-expunge-below) - (not gnus-use-nocem))) + (null gnus-thread-expunge-below))) (push gnus-newsgroup-limit gnus-newsgroup-limits) (setq gnus-newsgroup-limit nil) (mapatoms @@ -8707,8 +8722,8 @@ fetch-old-headers verbiage, and so on." (apply '+ (mapcar 'gnus-summary-limit-children (cdr thread))) 0)) - (number (mail-header-number (car thread))) - score) + (number (mail-header-number (car thread))) + score) (if (and (not (memq number gnus-newsgroup-marked)) (or @@ -8753,14 +8768,8 @@ fetch-old-headers verbiage, and so on." t) ;; Do the `display' group parameter. (and gnus-newsgroup-display - (not (funcall gnus-newsgroup-display))) - ;; Check NoCeM things. - (when (and gnus-use-nocem - (gnus-nocem-unwanted-article-p - (mail-header-id (car thread)))) - (setq gnus-newsgroup-unreads - (delq number gnus-newsgroup-unreads)) - t))) + (let ((gnus-number number)) + (not (funcall gnus-newsgroup-display)))))) ;; Nope, invisible article. 0 ;; Ok, this article is to be visible, so we add it to the limit @@ -8850,31 +8859,41 @@ Return the number of articles fetched." (defun gnus-summary-refer-thread (&optional limit) "Fetch all articles in the current thread. -If LIMIT (the numerical prefix), fetch that many old headers instead -of what's specified by the `gnus-refer-thread-limit' variable." +If no backend-specific 'request-thread function is available +fetch LIMIT (the numerical prefix) old headers. If LIMIT is nil +fetch what's specified by the `gnus-refer-thread-limit' +variable." (interactive "P") - (let ((id (mail-header-id (gnus-summary-article-header))) - (limit (if limit (prefix-numeric-value limit) - gnus-refer-thread-limit))) - (unless (eq gnus-fetch-old-headers 'invisible) - (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) - ;; Retrieve the headers and read them in. - (if (eq (if (numberp limit) - (gnus-retrieve-headers - (list (min - (+ (mail-header-number - (gnus-summary-article-header)) - limit) - gnus-newsgroup-end)) - gnus-newsgroup-name (* limit 2)) - ;; gnus-refer-thread-limit is t, i.e. fetch _all_ - ;; headers. - (gnus-retrieve-headers (list gnus-newsgroup-end) - gnus-newsgroup-name limit)) - 'nov) - (gnus-build-all-threads) - (error "Can't fetch thread from back ends that don't support NOV")) - (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) + (gnus-warp-to-article) + (let* ((header (gnus-summary-article-header)) + (id (mail-header-id header)) + (gnus-inhibit-demon t) + (gnus-summary-ignore-duplicates t) + (gnus-read-all-available-headers t) + (limit (if limit (prefix-numeric-value limit) + gnus-refer-thread-limit))) + (setq gnus-newsgroup-headers + (gnus-merge + 'list gnus-newsgroup-headers + (if (gnus-check-backend-function + 'request-thread gnus-newsgroup-name) + (gnus-request-thread header) + (let* ((last (if (numberp limit) + (min (+ (mail-header-number header) + limit) + gnus-newsgroup-highest) + gnus-newsgroup-highest)) + (subject (gnus-simplify-subject + (mail-header-subject header))) + (refs (split-string (or (mail-header-references header) + ""))) + (gnus-parse-headers-hook + (lambda () (goto-char (point-min)) + (keep-lines + (regexp-opt (append refs (list id subject))))))) + (gnus-fetch-headers (list last) (if (numberp limit) + (* 2 limit) limit) t))) + 'gnus-article-sort-by-number)) (gnus-summary-limit-include-thread id))) (defun gnus-summary-refer-article (message-id) @@ -8957,8 +8976,11 @@ of what's specified by the `gnus-refer-thread-limit' variable." (defun gnus-summary-enter-digest-group (&optional force) "Enter an nndoc group based on the current article. -If FORCE, force a digest interpretation. If not, try -to guess what the document format is." +If FORCE, force a digest interpretation. If not, try to guess +what the document format is. + +To control what happens when you exit the group, see the +`gnus-auto-select-on-ephemeral-exit' variable." (interactive "P") (let ((conf gnus-current-window-configuration)) (save-window-excursion @@ -9036,7 +9058,7 @@ Obeys the standard process/prefix convention." (setq group (format "%s-%d" gnus-newsgroup-name article)) (gnus-summary-remove-process-mark article) (when (gnus-summary-display-article article) - (save-excursion + (save-excursion ;;What for? (with-temp-buffer (insert-buffer-substring gnus-original-article-buffer) ;; Remove some headers that may lead nndoc to make @@ -9071,6 +9093,15 @@ Obeys the standard process/prefix convention." (t (error "Couldn't select virtual nndoc group"))))) +(defun gnus-summary-widget-forward (arg) + "Move point to the next field or button in the article. +With optional ARG, move across that many fields." + (interactive "p") + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (select-window (gnus-get-buffer-window gnus-article-buffer)) + (widget-forward arg)) + (defun gnus-summary-isearch-article (&optional regexp-p) "Do incremental search forward on the current article. If REGEXP-P (the prefix) is non-nil, do regexp isearch." @@ -9258,14 +9289,14 @@ If HEADER is an empty string (or nil), the match is done on the entire article. If BACKWARD (the prefix) is non-nil, search backward instead." (interactive (list (let ((completion-ignore-case t)) - (completing-read - "Header name: " - (mapcar (lambda (header) (list (format "%s" header))) + (gnus-completing-read + "Header name" + (mapcar 'symbol-name (append - '("Number" "Subject" "From" "Lines" "Date" - "Message-ID" "Xref" "References" "Body") + '(Number Subject From Lines Date + Message-ID Xref References Body) gnus-extra-headers)) - nil 'require-match)) + 'require-match)) (read-string "Regexp: ") (read-key-sequence "Command: ") current-prefix-arg)) @@ -9345,50 +9376,58 @@ to save in." (ps-despool filename)) (defun gnus-print-buffer () - (let ((buffer (generate-new-buffer " *print*"))) + (let ((ps-left-header + (list + (concat "(" + (gnus-summary-print-truncate-and-quote + (mail-header-subject gnus-current-headers) + 66) ")") + (concat "(" + (gnus-summary-print-truncate-and-quote + (mail-header-from gnus-current-headers) + 45) ")"))) + (ps-right-header + (list + "/pagenumberstring load" + (concat "(" + (mail-header-date gnus-current-headers) ")")))) + (gnus-run-hooks 'gnus-ps-print-hook) + (save-excursion + (if ps-print-color-p + (ps-spool-buffer-with-faces) + (ps-spool-buffer))))) + +(defun gnus-summary-show-complete-article () + "Show a complete version of the current article. +This is only useful if you're looking at a partial version of the +article currently." + (interactive) + (let ((gnus-keep-backlog nil) + (gnus-use-cache nil) + (gnus-agent nil) + (variable (intern + (format "%s-fetch-partial-articles" + (car (gnus-find-method-for-group + gnus-newsgroup-name))) + obarray)) + old-val) (unwind-protect (progn - (copy-to-buffer buffer (point-min) (point-max)) - (set-buffer buffer) - (gnus-remove-text-with-property 'gnus-decoration) - (when (gnus-visual-p 'article-highlight 'highlight) - ;; Copy-to-buffer doesn't copy overlay. So redo - ;; highlight. - (let ((gnus-article-buffer buffer)) - (gnus-article-highlight-citation t) - (gnus-article-highlight-signature) - (gnus-article-emphasize) - (gnus-article-delete-invisible-text))) - (let ((ps-left-header - (list - (concat "(" - (gnus-summary-print-truncate-and-quote - (mail-header-subject gnus-current-headers) - 66) ")") - (concat "(" - (gnus-summary-print-truncate-and-quote - (mail-header-from gnus-current-headers) - 45) ")"))) - (ps-right-header - (list - "/pagenumberstring load" - (concat "(" - (mail-header-date gnus-current-headers) ")")))) - (gnus-run-hooks 'gnus-ps-print-hook) - (save-excursion - (if ps-print-color-p - (ps-spool-buffer-with-faces) - (ps-spool-buffer))))) - (kill-buffer buffer)))) + (setq old-val (symbol-value variable)) + (set variable nil) + (gnus-flush-original-article-buffer) + (gnus-summary-show-article)) + (set variable old-val)))) (defun gnus-summary-show-article (&optional arg) "Force redisplaying of the current article. If ARG (the prefix) is a number, show the article with the charset defined in `gnus-summary-show-article-charset-alist', or the charset input. -If ARG (the prefix) is non-nil and not a number, show the raw article -without any article massaging functions being run. Normally, the key -strokes are `C-u g'." +If ARG (the prefix) is non-nil and not a number, show the article, +but without running any of the article treatment functions +article. Normally, the keystroke is `C-u g'. When using `C-u +C-u g', show the raw article." (interactive "P") (cond ((numberp arg) @@ -9430,6 +9469,11 @@ strokes are `C-u g'." ((not arg) ;; Select the article the normal way. (gnus-summary-select-article nil 'force)) + ((or (equal arg '(16)) + (eq arg t)) + ;; C-u C-u g + (let ((gnus-inhibit-article-treatments t)) + (gnus-summary-select-article nil 'force))) (t ;; We have to require this here to make sure that the following ;; dynamic binding isn't shadowed by autoloading. @@ -9544,7 +9588,7 @@ IDNA encoded domain names looks like `xn--bar'. If a string remain unencoded after running this function, it is likely an invalid IDNA string (`xn--bar' is invalid). -You must have GNU Libidn (`http://www.gnu.org/software/libidn/') +You must have GNU Libidn (URL `http://www.gnu.org/software/libidn/') installed for this command to work." (interactive "P") (if (not (and (condition-case nil (require 'idna) @@ -9693,6 +9737,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." articles) (while articles (setq article (pop articles)) + ;; Set any marks that may have changed in the summary buffer. + (when gnus-preserve-marks + (gnus-summary-push-marks-to-backend article)) (setq art-group (cond @@ -9704,21 +9751,25 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." gnus-newsgroup-name)) (to-method (or select-method (gnus-find-method-for-group to-newsgroup))) - (move-is-internal (gnus-method-equal from-method to-method))) + (move-is-internal (gnus-server-equal from-method to-method))) (gnus-request-move-article article ; Article to move - gnus-newsgroup-name ; From newsgroup + 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 - move-is-internal))) ; is this move internal? + (and move-is-internal + to-newsgroup ; Not respooling + ; Is this move internal? + (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) + (when (gnus-request-article-this-buffer article + gnus-newsgroup-name) (save-restriction (nnheader-narrow-to-headers) (dolist (hdr gnus-copy-article-ignored-headers) @@ -9728,7 +9779,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." ;; Crosspost the article. ((eq action 'crosspost) (let ((xref (message-tokenize-header - (mail-header-xref (gnus-summary-article-header article)) + (mail-header-xref (gnus-summary-article-header + article)) " "))) (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) ":" (number-to-string article))) @@ -9745,7 +9797,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (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))) + to-newsgroup select-method (not articles) + t))) (setq new-xref (concat new-xref " " (car art-group) ":" (number-to-string (cdr art-group)))) @@ -9794,7 +9847,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (marks (if expirable gnus-article-mark-lists (delete '(expirable . expire) - (copy-sequence gnus-article-mark-lists)))) + (copy-sequence + gnus-article-mark-lists)))) (to-article (cdr art-group))) ;; Enter the article into the cache in the new group, @@ -9811,7 +9865,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (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) + (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)) @@ -9824,7 +9880,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." ;; 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))) + (set (intern (format "gnus-newsgroup-%s" + (caar marks))) (cons to-article (symbol-value (intern (format "gnus-newsgroup-%s" @@ -9845,8 +9902,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (gnus-add-marked-articles to-group 'expire (list to-article) info)) - (gnus-request-set-mark - to-group (list (list (list to-article) 'add to-marks)))) + (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 '" @@ -9871,15 +9929,17 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." to-newsgroup select-method)) - ;;;!!!Why is this necessary? + ;;;!!!Why is this necessary? (set-buffer gnus-summary-buffer) - (gnus-summary-goto-subject article) (when (eq action 'move) - (gnus-summary-mark-article article gnus-canceled-mark)))) + (save-excursion + (gnus-summary-goto-subject article) + (gnus-summary-mark-article article gnus-canceled-mark))))) (push article articles-to-update-marks)) - (apply 'gnus-summary-remove-process-mark articles-to-update-marks) + (save-excursion + (apply 'gnus-summary-remove-process-mark articles-to-update-marks)) ;; Re-activate all groups that have been moved to. (with-current-buffer gnus-group-buffer (let ((gnus-group-marked to-groups)) @@ -9889,6 +9949,20 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (gnus-summary-position-point) (gnus-set-mode-line 'summary))) +(defun gnus-summary-push-marks-to-backend (article) + (let ((set nil) + (marks gnus-article-mark-lists)) + (unless (memq article gnus-newsgroup-unreads) + (push 'read set)) + (while marks + (when (and (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks)))))) + (push (cdar marks) set)) + (pop marks)) + (gnus-request-set-mark gnus-newsgroup-name `(((,article) set ,set))))) + (defun gnus-summary-copy-article (&optional n to-newsgroup select-method) "Copy the current article to some other group. If TO-NEWSGROUP is string, do not prompt for a newsgroup to copy to. @@ -9927,15 +10001,15 @@ current group into whatever groups they are destined to. In the latter case, they will be copied into the relevant groups." (interactive (list current-prefix-arg - (let* ((methods (gnus-methods-using 'respool)) + (let* ((methods (mapcar #'car (gnus-methods-using 'respool))) (methname (symbol-name (or gnus-summary-respool-default-method (car (gnus-find-method-for-group gnus-newsgroup-name))))) (method - (gnus-completing-read-with-default - methname "Backend to use when respooling" - methods nil t nil 'gnus-mail-method-history)) + (gnus-completing-read + "Backend to use when respooling" + methods t nil 'gnus-mail-method-history methname)) ms) (cond ((zerop (length (setq ms (gnus-servers-using-backend @@ -9945,7 +10019,7 @@ latter case, they will be copied into the relevant groups." (car ms)) (t (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms))) - (cdr (assoc (completing-read "Server name: " ms-alist nil t) + (cdr (assoc (gnus-completing-read "Server name" ms-alist t) ms-alist)))))))) (unless method (error "No method given for respooling")) @@ -10135,19 +10209,20 @@ confirmation before the articles are deleted." ;; Delete the articles. (setq not-deleted (gnus-request-expire-articles articles gnus-newsgroup-name 'force)) - (while articles - (gnus-summary-remove-process-mark (car articles)) - ;; The backend might not have been able to delete the article - ;; after all. - (unless (memq (car articles) not-deleted) - (gnus-summary-mark-article (car articles) gnus-canceled-mark)) - (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))) + (save-excursion + (while articles + (gnus-summary-remove-process-mark (car articles)) + ;; The backend might not have been able to delete the article + ;; after all. + (unless (memq (car articles) not-deleted) + (gnus-summary-mark-article (car articles) gnus-canceled-mark) + (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))) (gnus-summary-position-point) @@ -10245,7 +10320,7 @@ groups." "Make edits to the current article permanent." (interactive) (save-excursion - ;; The buffer restriction contains the entire article if it exists. + ;; The buffer restriction contains the entire article if it exists. (when (article-goto-body) (let ((lines (count-lines (point) (point-max))) (length (- (point-max) (point))) @@ -10265,15 +10340,25 @@ groups." (delete-region (match-beginning 1) (match-end 1)) (insert (number-to-string lines)))))) ;; Replace the article. - (let ((buf (current-buffer))) + (let ((buf (current-buffer)) + (article (cdr gnus-article-current)) + replace-result) (with-temp-buffer (insert-buffer-substring buf) - (if (and (not read-only) - (not (gnus-request-replace-article - (cdr gnus-article-current) (car gnus-article-current) - (current-buffer) t))) + (not (setq replace-result + (gnus-request-replace-article + article (car gnus-article-current) + (current-buffer) t)))) (error "Couldn't replace article") + ;; If we got a number back, then that's the new article number + ;; for this article. Otherwise, the article number didn't change. + (when (numberp replace-result) + (with-current-buffer gnus-summary-buffer + (setq gnus-newsgroup-limit (delq article gnus-newsgroup-limit)) + (gnus-summary-limit gnus-newsgroup-limit) + (setq article replace-result) + (gnus-summary-goto-subject article t))) ;; Update the summary buffer. (if (and references (equal (message-tokenize-header references " ") @@ -10287,38 +10372,29 @@ groups." (point-min) (point-max))) header) (with-temp-buffer - (insert (format "211 %d Article retrieved.\n" - (cdr gnus-article-current))) + (insert (format "211 %d Article retrieved.\n" article)) (insert head) (insert ".\n") (let ((nntp-server-buffer (current-buffer))) - (setq header (car (gnus-get-newsgroup-headers - nil t)))) + (setq header (car (gnus-get-newsgroup-headers nil t)))) (with-current-buffer gnus-summary-buffer - (gnus-data-set-header - (gnus-data-find (cdr gnus-article-current)) - header) - (gnus-summary-update-article-line - (cdr gnus-article-current) header) - (if (gnus-summary-goto-subject - (cdr gnus-article-current) nil t) - (gnus-summary-update-secondary-mark - (cdr gnus-article-current)))))))) + (gnus-data-set-header (gnus-data-find article) header) + (gnus-summary-update-article-line article header) + (if (gnus-summary-goto-subject article nil t) + (gnus-summary-update-secondary-mark article))))))) ;; Update threads. (set-buffer (or buffer gnus-summary-buffer)) - (gnus-summary-update-article (cdr gnus-article-current)) - (if (gnus-summary-goto-subject (cdr gnus-article-current) nil t) - (gnus-summary-update-secondary-mark - (cdr gnus-article-current)))) + (gnus-summary-update-article article) + (if (gnus-summary-goto-subject article nil t) + (gnus-summary-update-secondary-mark article))) ;; Prettify the article buffer again. (unless no-highlight (with-current-buffer gnus-article-buffer - ;;;!!! Fix this -- article should be rehighlighted. - ;;;(gnus-run-hooks 'gnus-article-display-hook) + ;;!!! Fix this -- article should be rehighlighted. + ;;(gnus-run-hooks 'gnus-article-display-hook) (set-buffer gnus-original-article-buffer) (gnus-request-article - (cdr gnus-article-current) - (car gnus-article-current) (current-buffer)))) + article (car gnus-article-current) (current-buffer)))) ;; Prettify the summary buffer line. (when (gnus-visual-p 'summary-highlight 'highlight) (gnus-run-hooks 'gnus-visual-mark-article-hook)))))) @@ -10526,7 +10602,7 @@ ARTICLE can also be a list of articles." (not (equal gnus-newsgroup-name (car gnus-article-current)))) (error "No current article selected")) ;; Remove old bookmark, if one exists. - (gnus-pull article gnus-newsgroup-bookmarks) + (gnus-alist-pull article gnus-newsgroup-bookmarks) ;; Set the new bookmark, which is on the form ;; (article-number . line-number-in-body). (push @@ -10547,7 +10623,7 @@ ARTICLE can also be a list of articles." ;; Remove old bookmark, if one exists. (if (not (assq article gnus-newsgroup-bookmarks)) (gnus-message 6 "No bookmark in current article.") - (gnus-pull article gnus-newsgroup-bookmarks) + (gnus-alist-pull article gnus-newsgroup-bookmarks) (gnus-message 6 "Removed bookmark."))) ;; Suggested by Daniel Quinlan <[email protected]>. @@ -10673,7 +10749,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (setq gnus-newsgroup-unreads (gnus-add-to-sorted-list gnus-newsgroup-unreads article)))) - (gnus-pull article gnus-newsgroup-reads) + (gnus-alist-pull article gnus-newsgroup-reads) ;; See whether the article is to be put in the cache. (and gnus-use-cache @@ -10758,6 +10834,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (t gnus-no-mark)) 'replied) (when (gnus-visual-p 'summary-highlight 'highlight) + (gnus-summary-highlight-line) (gnus-run-hooks 'gnus-summary-update-hook)) t) @@ -10785,7 +10862,12 @@ If NO-EXPIRE, auto-expiry will be inhibited." ;; Go to the right position on the line. (goto-char (+ forward (point))) ;; Replace the old mark with the new mark. - (subst-char-in-region (point) (1+ (point)) (char-after) mark) + (let ((to-insert + (mm-subst-char-in-string + (char-after) mark + (buffer-substring (point) (1+ (point)))))) + (delete-region (point) (1+ (point))) + (insert to-insert)) ;; Optionally update the marks by some user rule. (when (eq type 'unread) (gnus-data-set-mark @@ -10841,13 +10923,9 @@ If NO-EXPIRE, auto-expiry will be inhibited." (t (setq gnus-newsgroup-unreads (gnus-add-to-sorted-list gnus-newsgroup-unreads article)))) - (gnus-pull article gnus-newsgroup-reads) + (gnus-alist-pull article gnus-newsgroup-reads) t))) -(defalias 'gnus-summary-mark-as-unread-forward - 'gnus-summary-tick-article-forward) -(make-obsolete 'gnus-summary-mark-as-unread-forward - 'gnus-summary-tick-article-forward "Emacs 20.4") (defun gnus-summary-tick-article-forward (n) "Tick N articles forwards. If N is negative, tick backwards instead. @@ -10855,18 +10933,12 @@ The difference between N and the number of articles ticked is returned." (interactive "p") (gnus-summary-mark-forward n gnus-ticked-mark)) -(defalias 'gnus-summary-mark-as-unread-backward - 'gnus-summary-tick-article-backward) -(make-obsolete 'gnus-summary-mark-as-unread-backward - 'gnus-summary-tick-article-backward "Emacs 20.4") (defun gnus-summary-tick-article-backward (n) "Tick N articles backwards. The difference between N and the number of articles ticked is returned." (interactive "p") (gnus-summary-mark-forward (- n) gnus-ticked-mark)) -(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) -(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article "Emacs 20.4") (defun gnus-summary-tick-article (&optional article clear-mark) "Mark current article as unread. Optional 1st argument ARTICLE specifies article number to be marked as unread. @@ -11202,6 +11274,7 @@ with that article." (mail-header-subject (gnus-data-header (car data))))) (t nil))) (end-point (save-excursion + (goto-char (gnus-data-pos (car data))) (if (gnus-summary-go-to-next-thread) (point) (point-max)))) articles) @@ -11309,7 +11382,7 @@ If ARG is positive number, turn showing conversation threads on." (defalias 'gnus-remove-overlays 'remove-overlays) (defun gnus-remove-overlays (beg end name val) "Clear BEG and END of overlays whose property NAME has value VAL. -For compatibility with Emacs 21 and XEmacs." +For compatibility with XEmacs." (dolist (ov (gnus-overlays-in beg end)) (when (eq (gnus-overlay-get ov name) val) (gnus-delete-overlay ov)))))) @@ -11320,15 +11393,19 @@ For compatibility with Emacs 21 and XEmacs." (gnus-remove-overlays (point-min) (point-max) 'invisible 'gnus-sum) (gnus-summary-position-point)) +(defsubst gnus-summary--inv (p) + (and (eq (get-char-property p 'invisible) 'gnus-sum) p)) + (defun gnus-summary-show-thread () "Show thread subtrees. Returns nil if no thread was there to be shown." (interactive) (let* ((orig (point)) (end (point-at-eol)) + (end (or (gnus-summary--inv end) (gnus-summary--inv (1- end)))) ;; Leave point at bol (beg (progn (beginning-of-line) (if (bobp) (point) (1- (point))))) - (eoi (when (eq (get-char-property end 'invisible) 'gnus-sum) + (eoi (when end (if (fboundp 'next-single-char-property-change) (or (next-single-char-property-change end 'invisible) (point-max)) @@ -11527,7 +11604,7 @@ If the prefix argument is negative, tick articles instead." ((> unmark 0) (gnus-summary-mark-article-as-unread gnus-unread-mark)) ((= unmark 0) - (gnus-summary-mark-article-as-unread gnus-expirable-mark)) + (gnus-summary-mark-article nil gnus-expirable-mark)) (t (gnus-summary-mark-article-as-unread gnus-ticked-mark))) (setq articles (cdr articles)))) @@ -11684,12 +11761,8 @@ will not be marked as saved." (gnus-message 1 "Article %d is unsaveable" article)) ;; This is a real article. (save-window-excursion - (let ((gnus-display-mime-function (when decode - gnus-display-mime-function)) - (gnus-article-prepare-hook (when decode - gnus-article-prepare-hook))) - (gnus-summary-select-article t t nil article) - (gnus-summary-goto-subject article))) + (gnus-summary-select-article decode decode nil article) + (gnus-summary-goto-subject article)) (with-current-buffer save-buffer (erase-buffer) (insert-buffer-substring (if decode @@ -11897,7 +11970,8 @@ save those articles instead." (nreverse split-name))) (defun gnus-valid-move-group-p (group) - (and (boundp group) + (and (symbolp group) + (boundp group) (symbol-name group) (symbol-value group) (gnus-get-function (gnus-find-method-for-group @@ -11914,29 +11988,21 @@ save those articles instead." (format "these %d articles" (length articles)) "this article"))) (to-newsgroup - (let (active group) - (when (or (null split-name) (= 1 (length split-name))) - (setq active (gnus-make-hashtable (length gnus-active-hashtb))) - (mapatoms (lambda (symbol) - (setq group (symbol-name symbol)) - (when (string-match "[^\000-\177]" group) - (setq group (gnus-group-decoded-name group))) - (set (intern group active) group)) - gnus-active-hashtb)) - (cond - ((null split-name) - (gnus-completing-read-with-default - default prom active 'gnus-valid-move-group-p nil prefix - 'gnus-group-history)) - ((= 1 (length split-name)) - (gnus-completing-read-with-default - (car split-name) prom active 'gnus-valid-move-group-p nil nil - 'gnus-group-history)) - (t - (gnus-completing-read-with-default - nil prom (mapcar 'list (nreverse split-name)) nil nil nil - 'gnus-group-history))))) - (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) + (cond + ((null split-name) + (gnus-group-completing-read + prom + (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) + nil prefix nil default)) + ((= 1 (length split-name)) + (gnus-group-completing-read + prom + (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) + nil prefix 'gnus-group-history (car split-name))) + (t + (gnus-completing-read + prom (nreverse split-name) nil nil 'gnus-group-history)))) + (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) encoded) (when to-newsgroup (if (or (string= to-newsgroup "") @@ -12633,13 +12699,15 @@ If ALL is a number, fetch this number of articles." (interactive) (prog1 (let ((old (sort (mapcar 'car gnus-newsgroup-data) '<)) - (old-active gnus-newsgroup-active) + (old-high gnus-newsgroup-highest) (nnmail-fetched-sources (list t)) i new) (setq gnus-newsgroup-active - (gnus-activate-group gnus-newsgroup-name 'scan)) - (setq i (cdr gnus-newsgroup-active)) - (while (> i (cdr old-active)) + (gnus-copy-sequence + (gnus-activate-group gnus-newsgroup-name 'scan))) + (setq i (cdr gnus-newsgroup-active) + gnus-newsgroup-highest i) + (while (> i old-high) (push i new) (decf i)) (if (not new) @@ -12650,6 +12718,64 @@ If ALL is a number, fetch this number of articles." (gnus-summary-limit (gnus-sorted-nunion old new)))) (gnus-summary-position-point))) +;;; Bookmark support for Gnus. +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) +(declare-function bookmark-default-handler "bookmark" (bmk)) +(declare-function bookmark-get-bookmark-record "bookmark" (bmk)) +(defvar bookmark-yank-point) +(defvar bookmark-current-buffer) + +(defun gnus-summary-bookmark-make-record () + "Make a bookmark entry for a Gnus summary buffer." + (let (pos buf) + (unless (and (derived-mode-p 'gnus-summary-mode) gnus-article-current) + (save-restriction ; FIXME is it necessary to widen? + (widen) (setq pos (point))) ; Set position in gnus-article buffer. + (setq buf "art") ; We are recording bookmark from article buffer. + (setq bookmark-yank-point (point)) + (setq bookmark-current-buffer (current-buffer)) + (gnus-article-show-summary)) ; Go back in summary buffer. + ;; We are now recording bookmark from summary buffer. + (unless buf (setq buf "sum")) + (let* ((subject (elt (gnus-summary-article-header) 1)) + (grp (car gnus-article-current)) + (art (cdr gnus-article-current)) + (head (gnus-summary-article-header art)) + (id (mail-header-id head))) + `(,subject + ,@(condition-case nil + (bookmark-make-record-default 'no-file 'no-context pos) + (wrong-number-of-arguments + (bookmark-make-record-default 'point-only))) + (location . ,(format "Gnus-%s %s:%d:%s" buf grp art id)) + (group . ,grp) (article . ,art) + (message-id . ,id) (handler . gnus-summary-bookmark-jump))))) + +;;;###autoload +(defun gnus-summary-bookmark-jump (bookmark) + "Handler function for record returned by `gnus-summary-bookmark-make-record'. +BOOKMARK is a bookmark name or a bookmark record." + (let ((group (bookmark-prop-get bookmark 'group)) + (article (bookmark-prop-get bookmark 'article)) + (id (bookmark-prop-get bookmark 'message-id)) + (buf (car (split-string (bookmark-prop-get bookmark 'location))))) + (gnus-fetch-group group (list article)) + (gnus-summary-insert-cached-articles) + (gnus-summary-goto-article id nil 'force) + ;; FIXME we have to wait article buffer is ready (only large buffer) + ;; Is there a better solution to know that? + ;; If we don't wait `bookmark-default-handler' will have no chance + ;; to set position. However there is no error, just wrong pos. + (sit-for 1) + (when (string= buf "Gnus-art") + (other-window 1)) + (bookmark-default-handler + `("" + (buffer . ,(current-buffer)) + . ,(bookmark-get-bookmark-record bookmark))))) + (gnus-summary-make-all-marking-commands) (gnus-ems-redefine) @@ -12662,5 +12788,4 @@ If ALL is a number, fetch this number of articles." ;; coding: iso-8859-1 ;; End: -;; arch-tag: 17c6748f-6d00-4d36-bf01-835c42f31235 ;;; gnus-sum.el ends here diff --git a/lisp/gnus/gnus-sync.el b/lisp/gnus/gnus-sync.el new file mode 100644 index 0000000000..8a492e8d2c --- /dev/null +++ b/lisp/gnus/gnus-sync.el @@ -0,0 +1,240 @@ +;;; gnus-sync.el --- synchronization facility for Gnus + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov <[email protected]> +;; Keywords: news synchronization nntp nnrss + +;; 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 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is the gnus-sync.el package. + +;; It's due for a rewrite using gnus-after-set-mark-hook and +;; gnus-before-update-mark-hook. Until then please consider it +;; experimental. + +;; Put this in your startup file (~/.gnus.el for instance) + +;; possibilities for gnus-sync-backend: +;; Tramp over SSH: /ssh:user@host:/path/to/filename +;; Tramp over IMAP: /imaps:[email protected]:/INBOX.test/filename +;; ...or any other file Tramp and Emacs can handle... + +;; (setq gnus-sync-backend "/remote:/path.gpg" ; will use Tramp+EPA if loaded +;; gnus-sync-global-vars `(gnus-newsrc-last-checked-date) +;; gnus-sync-newsrc-groups `("nntp" "nnrss") +;; gnus-sync-newsrc-offsets `(2 3)) + +;; TODO: + +;; - after gnus-sync-read, the message counts are wrong + +;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to +;; catch the mark updates + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'gnus) +(require 'gnus-start) +(require 'gnus-util) + +(defgroup gnus-sync nil + "The Gnus synchronization facility." + :version "24.1" + :group 'gnus) + +(defcustom gnus-sync-newsrc-groups `("nntp" "nnrss") + "List of groups to be synchronized in the gnus-newsrc-alist. +The group names are matched, they don't have to be fully +qualified. Typically you would choose all of these. That's the +default because there is no active sync backend by default, so +this setting is harmless until the user chooses a sync backend." + :group 'gnus-sync + :type '(repeat regexp)) + +(defcustom gnus-sync-newsrc-offsets '(2 3) + "List of per-group data to be synchronized." + :group 'gnus-sync + :type '(set (const :tag "Read ranges" 2) + (const :tag "Marks" 3))) + +(defcustom gnus-sync-global-vars nil + "List of global variables to be synchronized. +You may want to sync `gnus-newsrc-last-checked-date' but pretty +much any symbol is fair game. You could additionally sync +`gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology', +and `gnus-topic-alist' to cover all the variables in +newsrc.eld (except for `gnus-format-specs' which should not be +synchronized, I believe). Also see `gnus-variable-list'." + :group 'gnus-sync + :type '(repeat (choice (variable :tag "A known variable") + (symbol :tag "Any symbol")))) + +(defcustom gnus-sync-backend nil + "The synchronization backend." + :group 'gnus-sync + :type '(radio (const :format "None" nil) + (string :tag "Sync to a file"))) + +(defvar gnus-sync-newsrc-loader nil + "Carrier for newsrc data") + +(defun gnus-sync-save () +"Save the Gnus sync data to the backend." + (interactive) + (cond + ((stringp gnus-sync-backend) + (gnus-message 7 "gnus-sync: saving to backend %s" gnus-sync-backend) + ;; populate gnus-sync-newsrc-loader from all but the first dummy + ;; entry in gnus-newsrc-alist whose group matches any of the + ;; gnus-sync-newsrc-groups + ;; TODO: keep the old contents for groups we don't have! + (let ((gnus-sync-newsrc-loader + (loop for entry in (cdr gnus-newsrc-alist) + when (gnus-grep-in-list + (car entry) ;the group name + gnus-sync-newsrc-groups) + collect (cons (car entry) + (mapcar (lambda (offset) + (cons offset (nth offset entry))) + gnus-sync-newsrc-offsets))))) + (with-temp-file gnus-sync-backend + (progn + (let ((coding-system-for-write gnus-ding-file-coding-system) + (standard-output (current-buffer))) + (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" + gnus-ding-file-coding-system)) + (princ ";; Gnus sync data v. 0.0.1\n") + (let* ((print-quoted t) + (print-readably t) + (print-escape-multibyte nil) + (print-escape-nonascii t) + (print-length nil) + (print-level nil) + (print-circle nil) + (print-escape-newlines t) + (variables (cons 'gnus-sync-newsrc-loader + gnus-sync-global-vars)) + variable) + (while variables + (if (and (boundp (setq variable (pop variables))) + (symbol-value variable)) + (progn + (princ "\n(setq ") + (princ (symbol-name variable)) + (princ " '") + (prin1 (symbol-value variable)) + (princ ")\n")) + (princ "\n;;; skipping empty variable ") + (princ (symbol-name variable))))) + (gnus-message + 7 + "gnus-sync: stored variables %s and %d groups in %s" + gnus-sync-global-vars + (length gnus-sync-newsrc-loader) + gnus-sync-backend) + + ;; Idea from Dan Christensen <[email protected]> + ;; Save the .eld file with extra line breaks. + (gnus-message 8 "gnus-sync: adding whitespace to %s" + gnus-sync-backend) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^(\\|(\\\"" nil t) + (replace-match "\n\\&" t)) + (goto-char (point-min)) + (while (re-search-forward " $" nil t) + (replace-match "" t t)))))))) + ;; the pass-through case: gnus-sync-backend is not a known choice + (nil))) + +(defun gnus-sync-read () +"Load the Gnus sync data from the backend." + (interactive) + (when gnus-sync-backend + (gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend) + (cond ((stringp gnus-sync-backend) + ;; read data here... + (if (or debug-on-error debug-on-quit) + (load gnus-sync-backend nil t) + (condition-case var + (load gnus-sync-backend nil t) + (error + (error "Error in %s: %s" gnus-sync-backend (cadr var))))) + (let ((valid-count 0) + invalid-groups) + (dolist (node gnus-sync-newsrc-loader) + (if (gnus-gethash (car node) gnus-newsrc-hashtb) + (progn + (incf valid-count) + (loop for store in (cdr node) + do (setf (nth (car store) + (assoc (car node) gnus-newsrc-alist)) + (cdr store)))) + (push (car node) invalid-groups))) + (gnus-message + 7 + "gnus-sync: loaded %d groups (out of %d) from %s" + valid-count (length gnus-sync-newsrc-loader) + gnus-sync-backend) + (when invalid-groups + (gnus-message + 7 + "gnus-sync: skipped %d groups (out of %d) from %s" + (length invalid-groups) + (length gnus-sync-newsrc-loader) + gnus-sync-backend) + (gnus-message 9 "gnus-sync: skipped groups: %s" + (mapconcat 'identity invalid-groups ", "))))) + (nil)) + ;; make the hashtable again because the newsrc-alist may have been modified + (when gnus-sync-newsrc-offsets + (gnus-message 9 "gnus-sync: remaking the newsrc hashtable") + (gnus-make-hashtable-from-newsrc-alist)))) + +;;;###autoload +(defun gnus-sync-initialize () +"Initialize the Gnus sync facility." + (interactive) + (gnus-message 5 "Initializing the sync facility") + (gnus-sync-install-hooks)) + +;;;###autoload +(defun gnus-sync-install-hooks () + "Install the sync hooks." + (interactive) + ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read) + (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save) + (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) + +(defun gnus-sync-unload-hook () + "Uninstall the sync hooks." + (interactive) + ;; (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read) + (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save) + (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) + +(add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook) + +;; this is harmless by default, until the gnus-sync-backend is set +(gnus-sync-initialize) + +(provide 'gnus-sync) + +;;; gnus-sync.el ends here diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 6c74a8620c..7012afd873 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -148,8 +148,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-group-parent-topic (group) "Return the topic GROUP is member of by looking at the group buffer." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (if (gnus-group-goto-group group) (gnus-current-topic) (gnus-group-topic group)))) @@ -162,9 +161,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-topic-jump-to-topic (topic) "Go to TOPIC." (interactive - (list (completing-read "Go to topic: " - (mapcar 'list (gnus-topic-list)) - nil t))) + (list (gnus-completing-read "Go to topic" (gnus-topic-list) t))) (let ((buffer-read-only nil)) (dolist (topic (gnus-current-topics topic)) (unless (gnus-topic-goto-topic topic) @@ -912,8 +909,7 @@ articles in the topic and its subtopics." (defun gnus-topic-change-level (group level oldlevel &optional previous) "Run when changing levels to enter/remove groups from topics." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (let ((buffer-read-only nil)) (unless gnus-topic-inhibit-change-level (gnus-group-goto-group (or (car (nth 2 previous)) group)) @@ -1140,6 +1136,7 @@ articles in the topic and its subtopics." (defun gnus-topic-mode (&optional arg redisplay) "Minor mode for topicsifying Gnus group buffers." + ;; FIXME: Use define-minor-mode. (interactive (list current-prefix-arg t)) (when (eq major-mode 'gnus-group-mode) (make-local-variable 'gnus-topic-mode) @@ -1258,6 +1255,8 @@ that group. If performed over a topic line, toggle folding the topic." (interactive "P") + (when (and (eobp) (not (gnus-group-group-name))) + (forward-line -1)) (if (gnus-group-topic-p) (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) @@ -1304,8 +1303,8 @@ When used interactively, PARENT will be the topic under point." If COPYP, copy the groups instead." (interactive (list current-prefix-arg - (gnus-completing-read "Move to topic" gnus-topic-alist nil t - 'gnus-topic-history))) + (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t + nil 'gnus-topic-history))) (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n)) @@ -1351,7 +1350,8 @@ If COPYP, copy the groups instead." "Copy the current group to a topic." (interactive (list current-prefix-arg - (completing-read "Copy to topic: " gnus-topic-alist nil t))) + (gnus-completing-read + "Copy to topic" (mapcar 'car gnus-topic-alist) t))) (gnus-topic-move-group n topic t)) (defun gnus-topic-kill-group (&optional n discard) @@ -1444,7 +1444,8 @@ If PERMANENT, make it stay shown in subsequent sessions as well." (gnus-topic-remove-topic t nil) (let ((topic (gnus-topic-find-topology - (completing-read "Show topic: " gnus-topic-alist nil t)))) + (gnus-completing-read "Show topic" + (mapcar 'car gnus-topic-alist) t)))) (setcar (cddr (cadr topic)) nil) (setcar (cdr (cadr topic)) 'visible) (gnus-group-list-groups))))) @@ -1492,7 +1493,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (let (topic) (nreverse (list - (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) + (setq topic (gnus-completing-read "Move to topic" + (mapcar 'car gnus-topic-alist) t)) (read-string (format "Move to %s (regexp): " topic)))))) (gnus-group-mark-regexp regexp) (gnus-topic-move-group nil topic copyp)) @@ -1503,7 +1505,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (let (topic) (nreverse (list - (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) + (setq topic (gnus-completing-read "Copy to topic" + (mapcar 'car gnus-topic-alist) t)) (read-string (format "Copy to %s (regexp): " topic)))))) (gnus-topic-move-matching regexp topic t)) @@ -1724,8 +1727,9 @@ If REVERSE, sort in reverse order." "Sort topics in TOPIC alphabetically by topic name. If REVERSE, reverse the sorting order." (interactive - (list (completing-read "Sort topics in : " gnus-topic-alist nil t - (gnus-current-topic)) + (list (gnus-completing-read "Sort topics in" + (mapcar 'car gnus-topic-alist) t + (gnus-current-topic)) current-prefix-arg)) (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic))) gnus-topic-topology))) @@ -1739,7 +1743,7 @@ If REVERSE, reverse the sorting order." (interactive (list (gnus-group-topic-name) - (completing-read "Move to topic: " gnus-topic-alist nil t))) + (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t))) (unless (and current to) (error "Can't find topic")) (let ((current-top (cdr (gnus-topic-find-topology current))) @@ -1778,5 +1782,4 @@ If REVERSE, reverse the sorting order." (provide 'gnus-topic) -;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c ;;; gnus-topic.el ends here diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 6f814e5241..6b60fac5c9 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -45,6 +45,9 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus-util) (require 'gnus) @@ -59,6 +62,10 @@ :group 'gnus-undo) (defcustom gnus-undo-mode nil + ;; FIXME: This is a buffer-local minor mode which requires running + ;; code upon activation/deactivation, so defining it as a defcustom + ;; doesn't seem very useful: setting it to non-nil via Customize + ;; probably won't do the right thing. "Minor mode for undoing in Gnus buffers." :type 'boolean :group 'gnus-undo) @@ -77,17 +84,15 @@ ;;; Minor mode definition. -(defvar gnus-undo-mode-map nil) - -(unless gnus-undo-mode-map - (setq gnus-undo-mode-map (make-sparse-keymap)) - - (gnus-define-keys gnus-undo-mode-map - "\M-\C-_" gnus-undo - "\C-_" gnus-undo - "\C-xu" gnus-undo - ;; many people are used to type `C-/' on X terminals and get `C-_'. - [(control /)] gnus-undo)) +(defvar gnus-undo-mode-map + (let ((map (make-sparse-keymap))) + (gnus-define-keys map + "\M-\C-_" gnus-undo + "\C-_" gnus-undo + "\C-xu" gnus-undo + ;; many people are used to type `C-/' on X terminals and get `C-_'. + [(control /)] gnus-undo) + map)) (defun gnus-undo-make-menu-bar () ;; This is disabled for the time being. @@ -96,24 +101,19 @@ (cons "Undo" 'gnus-undo-actions) [menu-bar file whatever]))) -(defun gnus-undo-mode (&optional arg) +(define-minor-mode gnus-undo-mode "Minor mode for providing `undo' in Gnus buffers. \\{gnus-undo-mode-map}" - (interactive "P") - (set (make-local-variable 'gnus-undo-mode) - (if (null arg) (not gnus-undo-mode) - (> (prefix-numeric-value arg) 0))) + :keymap gnus-undo-mode-map (set (make-local-variable 'gnus-undo-actions) nil) (set (make-local-variable 'gnus-undo-boundary) t) (when gnus-undo-mode ;; Set up the menu. (when (gnus-visual-p 'undo-menu 'menu) (gnus-undo-make-menu-bar)) - (add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) (gnus-make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'gnus-undo-boundary nil t) - (gnus-run-hooks 'gnus-undo-mode-hook))) + (add-hook 'post-command-hook 'gnus-undo-boundary nil t))) ;;; Interface functions. @@ -188,5 +188,4 @@ A numeric argument serves as a repeat count." (provide 'gnus-undo) -;; arch-tag: 0d787bc7-787d-499a-837f-211d2cb07f2e ;;; gnus-undo.el ends here diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index b7a0605d6b..69648016ed 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -33,16 +33,41 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) -(eval-when-compile - (unless (fboundp 'with-no-warnings) - (defmacro with-no-warnings (&rest body) - `(progn ,@body)))) +(defcustom gnus-completing-read-function 'gnus-emacs-completing-read + "Function use to do completing read." + :version "24.1" + :group 'gnus-meta + :type `(radio (function-item + :doc "Use Emacs standard `completing-read' function." + gnus-emacs-completing-read) + ;; iswitchb.el is very old and ido.el is unavailable + ;; in XEmacs, so we exclude those function items. + ,@(unless (featurep 'xemacs) + '((function-item + :doc "Use `ido-completing-read' function." + gnus-ido-completing-read) + (function-item + :doc "Use iswitchb based completing-read function." + gnus-iswitchb-completing-read))))) + +(defcustom gnus-completion-styles + (if (and (boundp 'completion-styles-alist) + (boundp 'completion-styles)) + (append (when (and (assq 'substring completion-styles-alist) + (not (memq 'substring completion-styles))) + (list 'substring)) + completion-styles) + nil) + "Value of `completion-styles' to use when completing." + :version "24.1" + :group 'gnus-meta + :type 'list) ;; Fixme: this should be a gnus variable, not nnmail-. (defvar nnmail-pathname-coding-system) @@ -53,10 +78,6 @@ (defvar gnus-original-article-buffer) (defvar gnus-user-agent) -(require 'time-date) -(require 'netrc) - -(autoload 'message-fetch-field "message") (autoload 'gnus-get-buffer-window "gnus-win") (autoload 'nnheader-narrow-to-headers "nnheader") (autoload 'nnheader-replace-chars-in-string "nnheader") @@ -126,11 +147,9 @@ This is a compatibility function for different Emacsen." ;; XEmacs. In Emacs we don't need to call `make-local-hook' first. ;; It's harmless, though, so the main purpose of this alias is to shut ;; up the byte compiler. -(defalias 'gnus-make-local-hook - (if (eq (get 'make-local-hook 'byte-compile) - 'byte-compile-obsolete) - 'ignore ; Emacs - 'make-local-hook)) ; XEmacs +(defalias 'gnus-make-local-hook (if (featurep 'xemacs) + 'make-local-hook + 'ignore)) (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -206,8 +225,11 @@ Uses `gnus-extract-address-components'." Uses `gnus-extract-address-components'." (nth 1 (gnus-extract-address-components from))) +(declare-function message-fetch-field "message" (header &optional not-all)) + (defun gnus-fetch-field (field) "Return the value of the header FIELD of current article." + (require 'message) (save-excursion (save-restriction (let ((inhibit-point-motion-hooks t)) @@ -228,13 +250,14 @@ Uses `gnus-extract-address-components'." (point))))) (declare-function gnus-find-method-for-group "gnus" (group &optional info)) -(autoload 'gnus-group-name-decode "gnus-group") +(declare-function gnus-group-name-decode "gnus-group" (string charset)) (declare-function gnus-group-name-charset "gnus-group" (method group)) ;; gnus-group requires gnus-int which requires message. (declare-function message-tokenize-header "message" (header &optional separator)) (defun gnus-decode-newsgroups (newsgroups group &optional method) + (require 'gnus-group) (let ((method (or method (gnus-find-method-for-group group)))) (mapconcat (lambda (group) (gnus-group-name-decode group (gnus-group-name-charset @@ -254,6 +277,24 @@ Uses `gnus-extract-address-components'." (setq start (when end (next-single-property-change start prop)))))) +(defun gnus-find-text-property-region (start end prop) + "Return a list of text property regions that has property PROP." + (let (regions value) + (unless (get-text-property start prop) + (setq start (next-single-property-change start prop))) + (while start + (setq value (get-text-property start prop) + end (text-property-not-all start (point-max) prop value)) + (if (not end) + (setq start nil) + (when value + (push (list (set-marker (make-marker) start) + (set-marker (make-marker) end) + value) + regions)) + (setq start (next-single-property-change start prop)))) + (nreverse regions))) + (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) @@ -292,13 +333,14 @@ Symbols are also allowed; their print names are used instead." (> (nth 1 fdate) (nth 1 date)))))) (eval-and-compile - (if (and (fboundp 'float-time) - (subrp (symbol-function 'float-time))) + (if (or (featurep 'emacs) + (and (fboundp 'float-time) + (subrp (symbol-function 'float-time)))) (defalias 'gnus-float-time 'float-time) (defun gnus-float-time (&optional time) "Convert time value TIME to a floating point number. TIME defaults to the current time." - (with-no-warnings (time-to-seconds (or time (current-time))))))) + (time-to-seconds (or time (current-time)))))) ;;; Keymap macros. @@ -344,16 +386,6 @@ TIME defaults to the current time." (define-key keymap key (pop plist)) (pop plist))))) -(defun gnus-completing-read-with-default (default prompt &rest args) - ;; Like `completing-read', except that DEFAULT is the default argument. - (let* ((prompt (if default - (concat prompt " (default " default "): ") - (concat prompt ": "))) - (answer (apply 'completing-read prompt args))) - (if (or (null answer) (zerop (length answer))) - default - answer))) - ;; Two silly functions to ensure that all `y-or-n-p' questions clear ;; the echo area. ;; @@ -429,6 +461,20 @@ TIME defaults to the current time." (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) (* (- (string-to-number days) 1) 3600 24)))) +(defmacro gnus-date-get-time (date) + "Convert DATE string to Emacs time. +Cache the result as a text property stored in DATE." + ;; Either return the cached value... + `(let ((d ,date)) + (if (equal "" d) + '(0 0) + (or (get-text-property 0 'gnus-time d) + ;; or compute the value... + (let ((time (safe-date-to-time d))) + ;; and store it back in the string. + (put-text-property 0 1 'gnus-time time d) + time))))) + (defvar gnus-user-date-format-alist '(((gnus-seconds-today) . "%k:%M") (604800 . "%a %k:%M") ;;that's one week @@ -455,10 +501,10 @@ respectively.") (defun gnus-user-date (messy-date) "Format the messy-date according to gnus-user-date-format-alist. -Returns \" ? \" if there's bad input or if an other error occurs. +Returns \" ? \" if there's bad input or if another error occurs. Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (condition-case () - (let* ((messy-date (gnus-float-time (safe-date-to-time messy-date))) + (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date))) (now (gnus-float-time)) ;;If we don't find something suitable we'll use this one (my-format "%b %d '%y")) @@ -477,23 +523,9 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." (condition-case () - (format-time-string "%d-%b" (safe-date-to-time messy-date)) + (format-time-string "%d-%b" (gnus-date-get-time messy-date)) (error " - "))) -(defmacro gnus-date-get-time (date) - "Convert DATE string to Emacs time. -Cache the result as a text property stored in DATE." - ;; Either return the cached value... - `(let ((d ,date)) - (if (equal "" d) - '(0 0) - (or (get-text-property 0 'gnus-time d) - ;; or compute the value... - (let ((time (safe-date-to-time d))) - ;; and store it back in the string. - (put-text-property 0 1 'gnus-time time d) - time))))) - (defsubst gnus-time-iso8601 (time) "Return a string of TIME in YYYYMMDDTHHMMSS format." (format-time-string "%Y%m%dT%H%M%S" time)) @@ -601,6 +633,8 @@ but also to the ones displayed in the echo area." (t (apply 'message ,format-string ,args)))))))) +(defvar gnus-action-message-log nil) + (defun gnus-message-with-timestamp (format-string &rest args) "Display message with timestamp. Arguments are the same as `message'. The `gnus-add-timestamp-to-message' variable controls how to add @@ -615,14 +649,26 @@ Guideline for numbers: that take a long time, 7 - not very important messages on stuff, 9 - messages inside loops." (if (<= level gnus-verbose) - (if gnus-add-timestamp-to-message - (apply 'gnus-message-with-timestamp args) - (apply 'message args)) + (let ((message + (if gnus-add-timestamp-to-message + (apply 'gnus-message-with-timestamp args) + (apply 'message args)))) + (when (and (consp gnus-action-message-log) + (<= level 3)) + (push message gnus-action-message-log)) + message) ;; We have to do this format thingy here even if the result isn't ;; shown - the return value has to be the same as the return value ;; from `message'. (apply 'format args))) +(defun gnus-final-warning () + (when (and (consp gnus-action-message-log) + (setq gnus-action-message-log + (delete nil gnus-action-message-log))) + (message "Warning: %s" + (mapconcat #'identity gnus-action-message-log "; ")))) + (defun gnus-error (level &rest args) "Beep an error if LEVEL is equal to or less than `gnus-verbose'. ARGS are passed to `message'." @@ -856,6 +902,7 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." + (require 'nnmail) (let ((file-name-coding-system nnmail-pathname-coding-system)) ;; Make sure the directory exists. (gnus-make-directory (file-name-directory file)) @@ -1070,23 +1117,15 @@ with potentially long computations." ;;; Functions for saving to babyl/mail files. (eval-when-compile - (condition-case nil - (progn - (require 'rmail) - (autoload 'rmail-update-summary "rmailsum")) - (error - (define-compiler-macro rmail-select-summary (&rest body) - ;; Rmail of the XEmacs version is supplied by the package, and - ;; requires tm and apel packages. However, there may be those - ;; who haven't installed those packages. This macro helps such - ;; people even if they install those packages later. - `(eval '(rmail-select-summary ,@body))) - ;; If there's rmail but there's no tm (or there's apel of the - ;; mainstream, not the XEmacs version), loading rmail of the XEmacs - ;; version fails halfway, however it provides the rmail-select-summary - ;; macro which uses the following functions: - (autoload 'rmail-summary-displayed "rmail") - (autoload 'rmail-maybe-display-summary "rmail")))) + (if (featurep 'xemacs) + ;; Don't load tm and apel XEmacs packages that provide some + ;; Emacs emulating functions and variables. + (let ((features features)) + (provide 'tm-view) + (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore)) + (require 'rmail)) ;; It requires tm-view that loads apel. + (require 'rmail)) + (autoload 'rmail-update-summary "rmailsum")) (defvar mm-text-coding-system) @@ -1099,6 +1138,7 @@ In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless FILENAME exists and is Babyl format." (require 'rmail) (require 'mm-util) + (require 'nnmail) ;; Some of this codes is borrowed from rmailout.el. (setq filename (expand-file-name filename)) ;; FIXME should we really be messing with this defcustom? @@ -1123,8 +1163,7 @@ FILENAME exists and is Babyl format." (gnus-yes-or-no-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) - (save-excursion - (set-buffer file-buffer) + (with-current-buffer file-buffer (if (fboundp 'rmail-insert-rmail-file-header) (rmail-insert-rmail-file-header)) (let ((require-final-newline nil) @@ -1191,6 +1230,7 @@ FILENAME exists and is Babyl format." (defun gnus-output-to-mail (filename &optional ask) "Append the current article to a mail file named FILENAME." + (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) (tmpbuf (get-buffer-create " *Gnus-output*"))) @@ -1202,8 +1242,7 @@ FILENAME exists and is Babyl format." (gnus-y-or-n-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) - (save-excursion - (set-buffer file-buffer) + (with-current-buffer file-buffer (let ((require-final-newline nil) (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) @@ -1268,6 +1307,11 @@ ARG is passed to the first function." (save-current-buffer (apply 'run-hooks funcs))) +(defun gnus-run-hook-with-args (hook &rest args) + "Does the same as `run-hook-with-args', but saves the current buffer." + (save-current-buffer + (apply 'run-hook-with-args hook args))) + (defun gnus-run-mode-hooks (&rest funcs) "Run `run-mode-hooks' if it is available, otherwise `run-hooks'. This function saves the current buffer." @@ -1282,17 +1326,43 @@ This function saves the current buffer." "Say whether Gnus is running or not." (and (boundp 'gnus-group-buffer) (get-buffer gnus-group-buffer) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate list) - "Return a copy of LIST with all items satisfying PREDICATE removed." +(defun gnus-remove-if (predicate sequence &optional hash-table-p) + "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. +SEQUENCE should be a list, a vector, or a string. Returns always a list. +If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." + (let (out) + (if hash-table-p + (mapatoms (lambda (symbol) + (unless (funcall predicate symbol) + (push symbol out))) + sequence) + (unless (listp sequence) + (setq sequence (append sequence nil))) + (while sequence + (unless (funcall predicate (car sequence)) + (push (car sequence) out)) + (setq sequence (cdr sequence)))) + (nreverse out))) + +(defun gnus-remove-if-not (predicate sequence &optional hash-table-p) + "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed. +SEQUENCE should be a list, a vector, or a string. Returns always a list. +If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." (let (out) - (while list - (unless (funcall predicate (car list)) - (push (car list) out)) - (setq list (cdr list))) + (if hash-table-p + (mapatoms (lambda (symbol) + (when (funcall predicate symbol) + (push symbol out))) + sequence) + (unless (listp sequence) + (setq sequence (append sequence nil))) + (while sequence + (when (funcall predicate (car sequence)) + (push (car sequence) out)) + (setq sequence (cdr sequence)))) (nreverse out))) (if (fboundp 'assq-delete-all) @@ -1305,7 +1375,15 @@ Return the modified alist." (setq alist (delq entry alist))) alist))) -(defmacro gnus-pull (key alist &optional assoc-p) +(defun gnus-grep-in-list (word list) + "Find if a WORD matches any regular expression in the given LIST." + (when (and word list) + (catch 'found + (dolist (r list) + (when (string-match r word) + (throw 'found r)))))) + +(defmacro gnus-alist-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." (unless (symbolp alist) (error "Not a symbol: %s" alist)) @@ -1563,28 +1641,65 @@ SPEC is a predicate specifier that contains stuff like `or', `and', `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) -(defun gnus-completing-read (prompt table &optional predicate require-match - history) - (when (and history - (not (boundp history))) - (set history nil)) - (completing-read - (if (symbol-value history) - (concat prompt " (" (car (symbol-value history)) "): ") - (concat prompt ": ")) - table - predicate - require-match - nil - history - (car (symbol-value history)))) +(defun gnus-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `gnus-completing-read-function'." + (funcall gnus-completing-read-function + (concat prompt (when def + (concat " (default " def ")")) + ": ") + collection require-match initial-input history def)) + +(defun gnus-emacs-completing-read (prompt collection &optional require-match + initial-input history def) + "Call standard `completing-read-function'." + (let ((completion-styles gnus-completion-styles)) + (completing-read prompt + ;; Old XEmacs (at least 21.4) expect an alist for + ;; collection. + (mapcar 'list collection) + nil require-match initial-input history def))) + +(autoload 'ido-completing-read "ido") +(defun gnus-ido-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `ido-completing-read-function'." + (ido-completing-read prompt collection nil require-match + initial-input history def)) + + +(declare-function iswitchb-read-buffer "iswitchb" + (prompt &optional default require-match start matches-set)) +(defvar iswitchb-temp-buflist) + +(defun gnus-iswitchb-completing-read (prompt collection &optional require-match + initial-input history def) + "`iswitchb' based completing-read function." + ;; Make sure iswitchb is loaded before we let-bind its variables. + ;; If it is loaded inside the let, variables can become unbound afterwards. + (require 'iswitchb) + (let ((iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist + (let ((choices (append + (when initial-input (list initial-input)) + (symbol-value history) collection)) + filtered-choices) + (dolist (x choices) + (setq filtered-choices (adjoin x filtered-choices))) + (nreverse filtered-choices)))))) + (unwind-protect + (progn + (or iswitchb-mode + (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) + (iswitchb-read-buffer prompt def require-match)) + (or iswitchb-mode + (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) (defun gnus-graphic-display-p () - (or (and (fboundp 'display-graphic-p) - (display-graphic-p)) - ;;;!!!This is bogus. Fixme! - (and (featurep 'xemacs) - t))) + (if (featurep 'xemacs) + (device-on-window-system-p) + (display-graphic-p))) (put 'gnus-parse-without-error 'lisp-indent-function 0) (put 'gnus-parse-without-error 'edebug-form-spec '(body)) @@ -1666,30 +1781,16 @@ CHOICE is a list of the choice char and help message at IDX." (kill-buffer buf)) tchar)) -(declare-function x-focus-frame "xfns.c" (frame)) -(declare-function w32-focus-frame "../term/w32-win" (frame)) - -(defun gnus-select-frame-set-input-focus (frame) - "Select FRAME, raise it, and set input focus, if possible." - (cond ((featurep 'xemacs) - (if (fboundp 'select-frame-set-input-focus) - (select-frame-set-input-focus frame) - (raise-frame frame) - (select-frame frame) - (focus-frame frame))) - ;; `select-frame-set-input-focus' defined in Emacs 21 will not - ;; set the input focus. - ((>= emacs-major-version 22) - (select-frame-set-input-focus frame)) - (t - (raise-frame frame) - (select-frame frame) - (cond ((memq window-system '(x ns mac)) - (x-focus-frame frame)) - ((eq window-system 'w32) - (w32-focus-frame frame))) - (when focus-follows-mouse - (set-mouse-position frame (1- (frame-width frame)) 0))))) +(if (featurep 'emacs) + (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) + (if (fboundp 'select-frame-set-input-focus) + (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) + ;; XEmacs 21.4, SXEmacs + (defun gnus-select-frame-set-input-focus (frame) + "Select FRAME, raise it, and set input focus, if possible." + (raise-frame frame) + (select-frame frame) + (focus-frame frame)))) (defun gnus-frame-or-window-display-name (object) "Given a frame or window, return the associated display name. @@ -1854,25 +1955,6 @@ empty directories from OLD-PATH." (defalias 'gnus-set-process-query-on-exit-flag 'process-kill-without-query)) -(if (fboundp 'with-local-quit) - (defalias 'gnus-with-local-quit 'with-local-quit) - (defmacro gnus-with-local-quit (&rest body) - "Execute BODY, allowing quits to terminate BODY but not escape further. -When a quit terminates BODY, `gnus-with-local-quit' returns nil but -requests another quit. That quit will be processed as soon as quitting -is allowed once again. (Immediately, if `inhibit-quit' is nil.)" - ;;(declare (debug t) (indent 0)) - `(condition-case nil - (let ((inhibit-quit nil)) - ,@body) - (quit (setq quit-flag t) - ;; This call is to give a chance to handle quit-flag - ;; in case inhibit-quit is nil. - ;; Without this, it will not be handled until the next function - ;; call, and that might allow it to exit thru a condition-case - ;; that intends to handle the quit signal next time. - (eval '(ignore nil)))))) - (defalias 'gnus-read-shell-command (if (fboundp 'read-shell-command) 'read-shell-command 'read-string)) @@ -1897,7 +1979,85 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" (get-char-table ,character ,display-table))) `(aref ,display-table ,character))) +(defun gnus-rescale-image (image size) + "Rescale IMAGE to SIZE if possible. +SIZE is in format (WIDTH . HEIGHT). Return a new image. +Sizes are in pixels." + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + image + (let ((new-width (car size)) + (new-height (cdr size))) + (when (> (cdr (image-size image t)) new-height) + (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t + :height new-height) + image))) + (when (> (car (image-size image t)) new-width) + (setq image (or + (create-image (plist-get (cdr image) :data) 'imagemagick t + :width new-width) + image))) + image))) + +(defun gnus-list-memq-of-list (elements list) + "Return non-nil if any of the members of ELEMENTS are in LIST." + (let ((found nil)) + (dolist (elem elements) + (setq found (or found + (memq elem list)))) + found)) + +(eval-and-compile + (cond + ((fboundp 'match-substitute-replacement) + (defalias 'gnus-match-substitute-replacement 'match-substitute-replacement)) + (t + (defun gnus-match-substitute-replacement (replacement &optional fixedcase literal string subexp) + "Return REPLACEMENT as it will be inserted by `replace-match'. +In other words, all back-references in the form `\\&' and `\\N' +are substituted with actual strings matched by the last search. +Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same +meaning as for `replace-match'. + +This is the definition of match-substitute-replacement in subr.el from GNU Emacs." + (let ((match (match-string 0 string))) + (save-match-data + (set-match-data (mapcar (lambda (x) + (if (numberp x) + (- x (match-beginning 0)) + x)) + (match-data t))) + (replace-match replacement fixedcase literal match subexp))))))) + +(if (fboundp 'string-match-p) + (defalias 'gnus-string-match-p 'string-match-p) + (defsubst gnus-string-match-p (regexp string &optional start) + "\ +Same as `string-match' except this function does not change the match data." + (save-match-data + (string-match regexp string start)))) + +(eval-and-compile + (if (fboundp 'macroexpand-all) + (defalias 'gnus-macroexpand-all 'macroexpand-all) + (defun gnus-macroexpand-all (form &optional environment) + "Return result of expanding macros at all levels in FORM. +If no macros are expanded, FORM is returned unchanged. +The second optional arg ENVIRONMENT specifies an environment of macro +definitions to shadow the loaded ones for use in file byte-compilation." + (if (consp form) + (let ((idx 1) + (len (length (setq form (copy-sequence form)))) + expanded) + (while (< idx len) + (setcar (nthcdr idx form) (gnus-macroexpand-all (nth idx form) + environment)) + (setq idx (1+ idx))) + (if (eq (setq expanded (macroexpand form environment)) form) + form + (gnus-macroexpand-all expanded environment))) + form)))) + (provide 'gnus-util) -;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 9d3cc9383a..0f6770e229 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -335,7 +335,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (defvar gnus-uu-shar-begin-string "^#! */bin/sh") -(defvar gnus-uu-shar-file-name nil) (defvar gnus-uu-shar-name-marker "begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)") @@ -827,8 +826,7 @@ When called interactively, prompt for REGEXP." (defun gnus-uu-save-article (buffer in-state) (cond (gnus-uu-save-separate-articles - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer (concat gnus-uu-saved-article-name gnus-current-article))) @@ -838,8 +836,7 @@ When called interactively, prompt for REGEXP." ((eq in-state 'last) (list 'end)) (t (list 'middle))))) ((not gnus-uu-save-in-digest) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (write-region (point-min) (point-max) gnus-uu-saved-article-name t) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name @@ -857,11 +854,9 @@ When called interactively, prompt for REGEXP." (eq in-state 'first-and-last)) (progn (setq state (list 'begin)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus-uu-body*")) + (with-current-buffer (gnus-get-buffer-create "*gnus-uu-body*") (erase-buffer)) - (save-excursion - (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*")) + (with-current-buffer (gnus-get-buffer-create "*gnus-uu-pre*") (erase-buffer) (insert (format "Date: %s\nFrom: %s\nSubject: %s Digest\n\n" @@ -873,8 +868,7 @@ When called interactively, prompt for REGEXP." (insert "Topics:\n"))) (when (not (eq in-state 'end)) (setq state (list 'middle)))) - (save-excursion - (set-buffer "*gnus-uu-body*") + (with-current-buffer "*gnus-uu-body*" (goto-char (setq beg (point-max))) (save-excursion (save-restriction @@ -940,8 +934,7 @@ When called interactively, prompt for REGEXP." (when (re-search-forward "^Subject: \\(.*\\)$" nil t) (setq subj (buffer-substring (match-beginning 1) (match-end 1)))) (when subj - (save-excursion - (set-buffer "*gnus-uu-pre*") + (with-current-buffer "*gnus-uu-pre*" (insert (format " %s\n" subj))))) (when (or (eq in-state 'last) (eq in-state 'first-and-last)) @@ -951,8 +944,7 @@ When called interactively, prompt for REGEXP." (insert-buffer-substring "*gnus-uu-pre*") (goto-char (point-max)) (insert-buffer-substring "*gnus-uu-body*")) - (save-excursion - (set-buffer "*gnus-uu-pre*") + (with-current-buffer "*gnus-uu-pre*" (insert (format "\n\n%s\n\n" (make-string 70 ?-))) (if gnus-uu-digest-buffer (with-current-buffer gnus-uu-digest-buffer @@ -960,8 +952,7 @@ When called interactively, prompt for REGEXP." (insert-buffer-substring "*gnus-uu-pre*")) (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer gnus-uu-saved-article-name)))) - (save-excursion - (set-buffer "*gnus-uu-body*") + (with-current-buffer "*gnus-uu-body*" (goto-char (point-max)) (insert (concat (setq end-string (format "End of %s Digest" name)) @@ -993,8 +984,7 @@ When called interactively, prompt for REGEXP." (defun gnus-uu-binhex-article (buffer in-state) (let (state start-char) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (widen) (goto-char (point-min)) (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) @@ -1030,8 +1020,7 @@ When called interactively, prompt for REGEXP." ;; yEnc (defun gnus-uu-yenc-article (buffer in-state) - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (widen) (let ((file-name (yenc-extract-filename)) state start-char) @@ -1065,8 +1054,7 @@ When called interactively, prompt for REGEXP." (defun gnus-uu-decode-postscript-article (process-buffer in-state) (let ((state (list 'ok)) start-char end-char file-name) - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (goto-char (point-min)) (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) (setq state (list 'wrong-type)) @@ -1128,8 +1116,7 @@ When called interactively, prompt for REGEXP." ;; replaces the last thing that looks like "2/3" with "[0-9]+/3" ;; or, if it can't find something like that, tries "2 of 3", then ;; finally just replaces the next to last number with "[0-9]+". - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name) (buffer-disable-undo) (erase-buffer) (insert (regexp-quote string)) @@ -1228,8 +1215,7 @@ When called interactively, prompt for REGEXP." ;; decoded in. Returns the list of expanded strings. (let ((out-list string-list) string) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name) (buffer-disable-undo) (while string-list (erase-buffer) @@ -1332,11 +1318,9 @@ When called interactively, prompt for REGEXP." (gnus-summary-display-article article) ;; Push the article to the processing function. - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (let ((buffer-read-only nil)) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (setq process-state (funcall process-function gnus-original-article-buffer state))))) @@ -1477,8 +1461,7 @@ When called interactively, prompt for REGEXP." (defun gnus-uu-uustrip-article (process-buffer in-state) ;; Uudecodes a file asynchronously. - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (let ((state (list 'wrong-type)) process-connection-type case-fold-search buffer-read-only files start-char) @@ -1488,7 +1471,7 @@ When called interactively, prompt for REGEXP." (when gnus-uu-kill-carriage-return (save-excursion (while (search-forward "\r" nil t) - (delete-backward-char 1)))) + (delete-char -1)))) (while (or (re-search-forward gnus-uu-begin-string nil t) (re-search-forward gnus-uu-body-line nil t)) @@ -1600,8 +1583,7 @@ Gnus might fail to display all of it.") (defun gnus-uu-unshar-article (process-buffer in-state) (let ((state (list 'ok)) start-char) - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (goto-char (point-min)) (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) (setq state (list 'wrong-type)) @@ -1688,8 +1670,7 @@ Gnus might fail to display all of it.") (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) + (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name) (erase-buffer)) (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) @@ -2039,9 +2020,8 @@ If no file has been included, the user will be asked for a file." (setq file-name file-path)) (unwind-protect - (if (save-excursion - (set-buffer (setq uubuf - (gnus-get-buffer-create uuencode-buffer-name))) + (if (with-current-buffer + (setq uubuf (gnus-get-buffer-create uuencode-buffer-name)) (erase-buffer) (funcall gnus-uu-post-encode-method file-path file-name)) (insert-buffer-substring uubuf) @@ -2073,8 +2053,8 @@ If no file has been included, the user will be asked for a file." (setq beg-binary (point)) (setq end-binary (point-max)) - (save-excursion - (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name))) + (with-current-buffer + (setq uubuf (gnus-get-buffer-create encoded-buffer-name)) (erase-buffer) (insert-buffer-substring post-buf beg-binary end-binary) (goto-char (point-min)) @@ -2129,8 +2109,7 @@ If no file has been included, the user will be asked for a file." (insert (format " (%d/%d)" i parts))) (goto-char (point-max)) - (save-excursion - (set-buffer uubuf) + (with-current-buffer uubuf (goto-char beg) (if (= i parts) (goto-char (point-max)) @@ -2170,5 +2149,4 @@ If no file has been included, the user will be asked for a file." (provide 'gnus-uu) -;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853 ;;; gnus-uu.el ends here diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el index bc27cfb1c4..f36c4d5348 100644 --- a/lisp/gnus/gnus-vm.el +++ b/lisp/gnus/gnus-vm.el @@ -103,5 +103,4 @@ save those articles instead." (provide 'gnus-vm) -;; arch-tag: 42ca7f88-a12f-461d-be3e-cac7efb44866 ;;; gnus-vm.el ends here diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 1aa5592a85..2f0f19a8e2 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -68,12 +68,10 @@ used to display Gnus windows." (defvar gnus-buffer-configuration '((group (vertical 1.0 - (group 1.0 point) - (if gnus-carpal '(group-carpal 4)))) + (group 1.0 point))) (summary (vertical 1.0 - (summary 1.0 point) - (if gnus-carpal '(summary-carpal 4)))) + (summary 1.0 point))) (article (cond (gnus-use-trees @@ -84,16 +82,13 @@ used to display Gnus windows." (t '(vertical 1.0 (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) (article 1.0))))) (server (vertical 1.0 - (server 1.0 point) - (if gnus-carpal '(server-carpal 2)))) + (server 1.0 point))) (browse (vertical 1.0 - (browse 1.0 point) - (if gnus-carpal '(browse-carpal 2)))) + (browse 1.0 point))) (message (vertical 1.0 (message 1.0 point))) @@ -107,6 +102,9 @@ used to display Gnus windows." (vertical 1.0 (summary 0.25) (faq 1.0 point))) + (only-article + (vertical 1.0 + (article 1.0 point))) (edit-article (vertical 1.0 (article 1.0 point))) @@ -142,7 +140,6 @@ used to display Gnus windows." (pipe (vertical 1.0 (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) ("*Shell Command Output*" 1.0))) (bug (vertical 1.0 @@ -186,10 +183,6 @@ See the Gnus manual for an explanation of the syntax used.") (edit-group . gnus-group-edit-buffer) (edit-form . gnus-edit-form-buffer) (edit-server . gnus-server-edit-buffer) - (group-carpal . gnus-carpal-group-buffer) - (summary-carpal . gnus-carpal-summary-buffer) - (server-carpal . gnus-carpal-server-buffer) - (browse-carpal . gnus-carpal-browse-buffer) (edit-score . gnus-score-edit-buffer) (message . gnus-message-buffer) (mail . gnus-message-buffer) @@ -235,50 +228,6 @@ See the Gnus manual for an explanation of the syntax used.") (pop list)) (cadr (assq (car list) gnus-window-configuration))) -(defun gnus-windows-old-to-new (setting) - ;; First we take care of the really, really old Gnus 3 actions. - (when (symbolp setting) - (setq setting - ;; Take care of ooold GNUS 3.x values. - (cond ((eq setting 'SelectArticle) 'article) - ((memq setting '(SelectNewsgroup SelectSubject ExpandSubject)) - 'summary) - ((memq setting '(ExitNewsgroup)) 'group) - (t setting)))) - (if (or (listp setting) - (not (and gnus-window-configuration - (memq setting '(group summary article))))) - setting - (let* ((elem - (cond - ((eq setting 'group) - (gnus-window-configuration-element - '(group newsgroups ExitNewsgroup))) - ((eq setting 'summary) - (gnus-window-configuration-element - '(summary SelectNewsgroup SelectSubject ExpandSubject))) - ((eq setting 'article) - (gnus-window-configuration-element - '(article SelectArticle))))) - (total (apply '+ elem)) - (types '(group summary article)) - (pbuf (if (eq setting 'newsgroups) 'group 'summary)) - (i 0) - perc out) - (while (< i 3) - (or (not (numberp (nth i elem))) - (zerop (nth i elem)) - (progn - (setq perc (if (= i 2) - 1.0 - (/ (float (nth i elem)) total))) - (push (if (eq pbuf (nth i types)) - (list (nth i types) perc 'point) - (list (nth i types) perc)) - out))) - (incf i)) - `(vertical 1.0 ,@(nreverse out))))) - ;;;###autoload (defun gnus-add-configuration (conf) "Add the window configuration CONF to `gnus-buffer-configuration'." @@ -300,18 +249,9 @@ See the Gnus manual for an explanation of the syntax used.") (defun gnus-configure-frame (split &optional window) "Split WINDOW according to SPLIT." - (let ((current-window - (or (get-buffer-window (current-buffer)) (selected-window)))) - (unless window - (setq window current-window)) + (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window))) + (window (or window current-window))) (select-window window) - ;; This might be an old-style buffer config. - (when (vectorp split) - (setq split (append split nil))) - (when (or (consp (car split)) - (vectorp (car split))) - (push 1.0 split) - (push 'vertical split)) ;; The SPLIT might be something that is to be evaled to ;; return a new SPLIT. (while (and (not (assq (car split) gnus-window-to-buffer)) @@ -430,56 +370,55 @@ See the Gnus manual for an explanation of the syntax used.") (set-window-configuration setting) (setq gnus-current-window-configuration setting) (setq force (or force gnus-always-force-window-configuration)) - (setq setting (gnus-windows-old-to-new setting)) (let ((split (if (symbolp setting) - (cadr (assq setting gnus-buffer-configuration)) - setting)) - 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) - - ;; 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))) - - (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)))))))) + (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)) + + ;; 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)))))))) (defun gnus-delete-windows-in-gnusey-frames () "Do a `delete-other-windows' in all frames that have Gnus windows." @@ -590,5 +529,4 @@ should have point." (provide 'gnus-win) -;; arch-tag: ccd5a394-2ddf-4397-b8f8-6d80d3e46e2b ;;; gnus-win.el ends here diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index a5140542fc..a8274e8084 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -7,6 +7,7 @@ ;; Author: Masanobu UMEDA <[email protected]> ;; Lars Magne Ingebrigtsen <[email protected]> ;; Keywords: news, mail +;; Version: 5.13 ;; This file is part of GNU Emacs. @@ -29,7 +30,7 @@ (eval '(run-hooks 'gnus-load-hook)) -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -307,14 +308,6 @@ be set in `.emacs' instead." :group 'gnus-start :type 'boolean) -(defcustom gnus-play-startup-jingle nil - "If non-nil, play the Gnus jingle at startup." - :group 'gnus-start - :type 'boolean) - -(unless (fboundp 'gnus-group-remove-excess-properties) - (defalias 'gnus-group-remove-excess-properties 'ignore)) - (unless (featurep 'gnus-xmas) (defalias 'gnus-make-overlay 'make-overlay) (defalias 'gnus-delete-overlay 'delete-overlay) @@ -357,7 +350,6 @@ be set in `.emacs' instead." (list str)) line))) (defalias 'gnus-mode-line-buffer-identification 'identity)) - (defalias 'gnus-characterp 'numberp) (defalias 'gnus-deactivate-mark 'deactivate-mark) (defalias 'gnus-window-edges 'window-edges) (defalias 'gnus-key-press-event-p 'numberp) @@ -925,7 +917,8 @@ be set in `.emacs' instead." ;;; Gnus buffers ;;; -(defvar gnus-buffers nil) +(defvar gnus-buffers nil + "List of buffers handled by Gnus.") (defun gnus-get-buffer-create (name) "Do the same as `get-buffer-create', but store the created buffer." @@ -957,9 +950,8 @@ be set in `.emacs' instead." ;;; Splash screen. -(defvar gnus-group-buffer "*Group*") - -(autoload 'gnus-play-jingle "gnus-audio") +(defvar gnus-group-buffer "*Group*" + "Name of the Gnus group buffer.") (defface gnus-splash '((((class color) @@ -983,9 +975,7 @@ be set in `.emacs' instead." (erase-buffer) (unless gnus-inhibit-startup-message (gnus-group-startup-message) - (sit-for 0) - (when gnus-play-startup-jingle - (gnus-play-jingle)))))) + (sit-for 0))))) (defun gnus-indent-rigidly (start end arg) "Indent rigidly using only spaces and no tabs." @@ -1000,8 +990,6 @@ be set in `.emacs' instead." (while (search-forward "\t" nil t) (replace-match " " t t)))))) -(defvar gnus-simple-splash nil) - ;;(format "%02x%02x%02x" 114 66 20) "724214" (defvar gnus-logo-color-alist @@ -1041,50 +1029,47 @@ be set in `.emacs' instead." "Insert startup message in current buffer." ;; Insert the message. (erase-buffer) - (cond - ((and - (fboundp 'find-image) - (display-graphic-p) - ;; Make sure the library defining `image-load-path' is loaded - ;; (`find-image' is autoloaded) (and discard the result). Else, we may - ;; get "defvar ignored because image-load-path is let-bound" when calling - ;; `find-image' below. - (or (find-image '(nil (:type xpm :file "gnus.xpm"))) t) - (let* ((data-directory (nnheader-find-etc-directory "images/gnus")) - (image-load-path (cond (data-directory - (list data-directory)) - ((boundp 'image-load-path) - (symbol-value 'image-load-path)) - (t load-path))) - (image (find-image - `((:type svg :file "gnus.svg") - (:type png :file "gnus.png") - (:type xpm :file "gnus.xpm" - :color-symbols - (("thing" . ,(car gnus-logo-colors)) - ("shadow" . ,(cadr gnus-logo-colors)) - ("oort" . "#eeeeee") - ("background" . ,(face-background 'default)))) - (:type pbm :file "gnus.pbm" - ;; Account for the pbm's blackground. - :background ,(face-foreground 'gnus-splash) - :foreground ,(face-background 'default)) - (:type xbm :file "gnus.xbm" - ;; Account for the xbm's blackground. - :background ,(face-foreground 'gnus-splash) - :foreground ,(face-background 'default)))))) - (when image - (let ((size (image-size image))) - (insert-char ?\n (max 0 (round (- (window-height) - (or y (cdr size)) 1) 2))) - (insert-char ?\ (max 0 (round (- (window-width) - (or x (car size))) 2))) - (insert-image image)) - (setq gnus-simple-splash nil) - t)))) - (t + (unless (and + (fboundp 'find-image) + (display-graphic-p) + ;; Make sure the library defining `image-load-path' is + ;; loaded (`find-image' is autoloaded) (and discard the + ;; result). Else, we may get "defvar ignored because + ;; image-load-path is let-bound" when calling `find-image' + ;; below. + (or (find-image '(nil (:type xpm :file "gnus.xpm"))) t) + (let* ((data-directory (nnheader-find-etc-directory "images/gnus")) + (image-load-path (cond (data-directory + (list data-directory)) + ((boundp 'image-load-path) + (symbol-value 'image-load-path)) + (t load-path))) + (image (find-image + `((:type xpm :file "gnus.xpm" + :color-symbols + (("thing" . ,(car gnus-logo-colors)) + ("shadow" . ,(cadr gnus-logo-colors)))) + (:type svg :file "gnus.svg") + (:type png :file "gnus.png") + (:type pbm :file "gnus.pbm" + ;; Account for the pbm's background. + :background ,(face-foreground 'gnus-splash) + :foreground ,(face-background 'default)) + (:type xbm :file "gnus.xbm" + ;; Account for the xbm's background. + :background ,(face-foreground 'gnus-splash) + :foreground ,(face-background 'default)))))) + (when image + (let ((size (image-size image))) + (insert-char ?\n (max 0 (round (- (window-height) + (or y (cdr size)) 1) 2))) + (insert-char ?\ (max 0 (round (- (window-width) + (or x (car size))) 2))) + (insert-image image)) + (goto-char (point-min)) + t))) (insert - (format " %s + (format " _ ___ _ _ _ ___ __ ___ __ _ ___ __ _ ___ __ ___ @@ -1103,8 +1088,7 @@ be set in `.emacs' instead." _ __ -" - "")) +")) ;; And then hack it. (gnus-indent-rigidly (point-min) (point-max) (/ (max (- (window-width) (or x 46)) 0) 2)) @@ -1116,10 +1100,9 @@ be set in `.emacs' instead." (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))) ;; Fontify some. (put-text-property (point-min) (point-max) 'face 'gnus-splash) - (setq gnus-simple-splash t))) - (goto-char (point-min)) - (setq mode-line-buffer-identification (concat " " gnus-version)) - (set-buffer-modified-p t)) + (goto-char (point-min)) + (setq mode-line-buffer-identification (concat " " gnus-version)) + (set-buffer-modified-p t))) (eval-when (load) (let ((command (format "%s" this-command))) @@ -1275,15 +1258,6 @@ by the user. If you want to change servers, you should use `gnus-select-method'. See the documentation to that variable.") -;; Don't touch this variable. -(defvar gnus-nntp-service "nntp" - "NNTP service name (\"nntp\" or 119). -This is an obsolete variable, which is scarcely used. If you use an -nntp server for your newsgroup and want to change the port number -used to 899, you would say something along these lines: - - (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))") - (defcustom gnus-nntpserver-file "/etc/nntpserver" "A file with only the name of the nntp server in it." :group 'gnus-files @@ -1307,20 +1281,11 @@ Check the NNTPSERVER environment variable and the ;;;###autoload (custom-autoload 'gnus-select-method "gnus")) (defcustom gnus-select-method - (condition-case nil - (nconc - (list 'nntp (or (condition-case nil - (gnus-getenv-nntpserver) - (error nil)) - (when (and gnus-default-nntp-server - (not (string= gnus-default-nntp-server ""))) - gnus-default-nntp-server) - "news")) - (if (or (null gnus-nntp-service) - (equal gnus-nntp-service "nntp")) - nil - (list gnus-nntp-service))) - (error nil)) + (list 'nntp (or (gnus-getenv-nntpserver) + (when (and gnus-default-nntp-server + (not (string= gnus-default-nntp-server ""))) + gnus-default-nntp-server) + "news")) "Default method for selecting a newsgroup. This variable should be a list, where the first element is how the news is to be fetched, the second is the address. @@ -1364,12 +1329,12 @@ updated if the value of this variable is nil, even if you change the value of `gnus-message-archive-method' afterward. If you want the saved \"archive\" method to be updated whenever you change the value of `gnus-message-archive-method', set this variable to a non-nil value." - :version "23.1" ;; No Gnus + :version "23.1" :group 'gnus-server :group 'gnus-message :type 'boolean) -(defcustom gnus-message-archive-group nil +(defcustom gnus-message-archive-group '((format-time-string "sent.%Y-%m")) "*Name of the group in which to save the messages you've written. This can either be a string; a list of strings; or an alist of regexps/functions/forms to be evaluated to return a string (or a list @@ -1389,8 +1354,12 @@ unprefixed -- which implicitly means \"store on the archive server\". However, you may wish to store the message on some other server. In that case, just return a fully prefixed name of the group -- \"nnml+private:mail.misc\", for instance." + :version "24.1" :group 'gnus-message :type '(choice (const :tag "none" nil) + (const :tag "Weekly" ((format-time-string "sent.%Yw%U"))) + (const :tag "Monthly" ((format-time-string "sent.%Y-%m"))) + (const :tag "Yearly" ((format-time-string "sent.%Y"))) function sexp string)) @@ -1401,14 +1370,14 @@ To make Gnus query you for a server, you have to give `gnus' a non-numeric prefix - `C-u M-x gnus', in short." :group 'gnus-server :type '(repeat string)) +(make-obsolete-variable 'gnus-secondary-servers 'gnus-select-method "24.1") (defcustom gnus-nntp-server nil - "*The name of the host running the NNTP server. -This variable is semi-obsolete. Use the `gnus-select-method' -variable instead." + "The name of the host running the NNTP server." :group 'gnus-server :type '(choice (const :tag "disable" nil) string)) +(make-obsolete-variable 'gnus-nntp-server 'gnus-select-method "24.1") (defcustom gnus-secondary-select-methods nil "A list of secondary methods that will be used for reading news. @@ -1422,11 +1391,6 @@ you could set this variable: :group 'gnus-server :type '(repeat gnus-select-method)) -(defvar gnus-backup-default-subscribed-newsgroups - '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus") - "Default default new newsgroups the first time Gnus is run. -Should be set in paths.el, and shouldn't be touched by the user.") - (defcustom gnus-local-domain nil "Local domain name without a host name. The DOMAINNAME environment variable is used instead if it is defined. @@ -1435,14 +1399,11 @@ no need to set this variable." :group 'gnus-message :type '(choice (const :tag "default" nil) string)) - -(defvar gnus-local-organization nil - "String with a description of what organization (if any) the user belongs to. -Obsolete variable; use `message-user-organization' instead.") +(make-obsolete-variable 'gnus-local-domain nil "Emacs 24.1") ;; Customization variables -(defcustom gnus-refer-article-method nil +(defcustom gnus-refer-article-method 'current "Preferred method for fetching an article by Message-ID. If you are reading news from the local spool (with nnspool), fetching articles by Message-ID is painfully slow. By setting this method to an @@ -1454,6 +1415,7 @@ in the documentation of `gnus-select-method'. It can also be a list of select methods, as well as the special symbol `current', which means to use the current select method. If it is a list, Gnus will try all the methods in the list until it finds a match." + :version "24.1" :group 'gnus-server :type '(choice (const :tag "default" nil) (const current) @@ -1468,83 +1430,6 @@ list, Gnus will try all the methods in the list until it finds a match." (nnweb "refer" (nnweb-type google))) gnus-select-method)))) -(defcustom gnus-group-faq-directory - '("/[email protected]:/pub/rtfm/usenet/" - "/[email protected]:/pub/usenet/news-faqs/" - "/[email protected]:/usenet/news-FAQS/" - "/[email protected]:/pub/rtfm/" - "/[email protected]:/pub/FAQ/" - "/[email protected]:/pub/usenet/" - "/[email protected]:/pub/FAQ/" - "/[email protected]:/pub/usenet/" - "/[email protected]:/pub/Documents/rtfm/usenet-by-group/" - "/[email protected]:/pub/usenet/" - "/[email protected]:/mirror/faqs/") - "*Directory where the group FAQs are stored. -This will most commonly be on a remote machine, and the file will be -fetched by ange-ftp. - -This variable can also be a list of directories. In that case, the -first element in the list will be used by default. The others can -be used when being prompted for a site. - -Note that Gnus uses an aol machine as the default directory. If this -feels fundamentally unclean, just think of it as a way to finally get -something of value back from them. - -If the default site is too slow, try one of these: - - North America: mirrors.aol.com /pub/rtfm/usenet - ftp.seas.gwu.edu /pub/rtfm - rtfm.mit.edu /pub/usenet - Europe: ftp.uni-paderborn.de /pub/FAQ - src.doc.ic.ac.uk /usenet/news-FAQS - ftp.sunet.se /pub/usenet - ftp.pasteur.fr /pub/FAQ - Asia: nctuccca.nctu.edu.tw /pub/Documents/rtfm/usenet-by-group/ - hwarang.postech.ac.kr /pub/usenet - ftp.hk.super.net /mirror/faqs" - :group 'gnus-group-various - :type '(choice directory - (repeat directory))) - -(defcustom gnus-group-charter-alist - '(("no" . (concat "http://no.news-admin.org/charter/" name ".txt")) - ("de" . (concat "http://purl.net/charta/" name ".html")) - ("dk" . (concat "http://www.usenet.dk/grupper.pl?get=" name)) - ("england" . (concat "http://england.news-admin.org/charters/" name)) - ("fr" . (concat "http://www.usenet-fr.net/fur/chartes/" name ".html")) - ("europa" . (concat "http://www.europa.usenet.eu.org/chartas/charta-en-" - (gnus-replace-in-string name "europa\\." "") ".html")) - ("nl" . (concat "http://www.xs4all.nl/~sister/usenet/charters/" name)) - ("aus" . (concat "http://aus.news-admin.org/groupinfo.cgi/" name)) - ("pl" . (concat "http://www.usenet.pl/opisy/" name)) - ("ch" . (concat "http://www.use-net.ch/Usenet/charter.html#" name)) - ("at" . (concat "http://www.usenet.at/chartas/" name "/charta")) - ("uk" . (concat "http://www.usenet.org.uk/" name ".html")) - ("dfw" . (concat "http://www.cirr.com/dfw/charters/" name ".html")) - ("se" . (concat "http://www.usenet-se.net/Reglementen/" - (gnus-replace-in-string name "\\." "_") ".html")) - ("milw" . (concat "http://usenet.mil.wi.us/" - (gnus-replace-in-string name "milw\\." "") "-charter")) - ("ca" . (concat "http://www.sbay.org/ca/charter-" name ".html")) - ("netins" . (concat "http://www.netins.net/usenet/charter/" - (gnus-replace-in-string name "\\." "-") "-charter.html"))) - "*An alist of (HIERARCHY . FORM) pairs used to construct the URL of a charter. -When FORM is evaluated `name' is bound to the name of the group." - :version "22.1" - :group 'gnus-group-various - :type '(repeat (cons (string :tag "Hierarchy") (sexp :tag "Form")))) -(put 'gnus-group-charter-alist 'risky-local-variable t) - -(defcustom gnus-group-fetch-control-use-browse-url nil - "*Non-nil means that control messages are displayed using `browse-url'. -Otherwise they are fetched with ange-ftp and displayed in an ephemeral -group." - :version "22.1" - :group 'gnus-group-various - :type 'boolean) - (defcustom gnus-use-cross-reference t "*Non-nil means that cross referenced articles will be marked as read. If nil, ignore cross references. If t, mark articles as read in @@ -1566,13 +1451,15 @@ newsgroups." "*The number of articles which indicates a large newsgroup. If the number of articles in a newsgroup is greater than this value, confirmation is required for selecting the newsgroup. -If it is nil, no confirmation is required." +If it is nil, no confirmation is required. + +Also see `gnus-large-ephemeral-newsgroup'." :group 'gnus-group-select :type '(choice (const :tag "No limit" nil) integer)) (defcustom gnus-use-long-file-name (not (memq system-type '(usg-unix-v))) - "*Non-nil means that the default name of a file to save articles in is the group name. + "Non-nil means that the default name of a file to save articles in is the group name. If it's nil, the directory form of the group name is used instead. If this variable is a list, and the list contains the element @@ -1582,8 +1469,8 @@ saving; and if it contains the element `not-kill', long file names will not be used for kill files. Note that the default for this variable varies according to what system -type you're using. On `usg-unix-v' and `xenix' this variable defaults -to nil while on all other systems it defaults to t." +type you're using. On `usg-unix-v' this variable defaults to nil while +on all other systems it defaults to t." :group 'gnus-start :type '(radio (sexp :format "Non-nil\n" :match (lambda (widget value) @@ -1647,25 +1534,6 @@ articles. This is not a good idea." (sexp :format "all" :value t))) -(defcustom gnus-use-nocem nil - "*If non-nil, Gnus will read NoCeM cancel messages. -You can also set this variable to a positive number as a group level. -In that case, Gnus scans NoCeM messages when checking new news if this -value is not exceeding a group level that you specify as the prefix -argument to some commands, e.g. `gnus', `gnus-group-get-new-news', etc. -Otherwise, Gnus does not scan NoCeM messages if you specify a group -level to those commands." - :group 'gnus-meta - :type '(choice - (const :tag "off" nil) - (const :tag "on" t) - (list :convert-widget - (lambda (widget) - (list 'integer :tag "group level" - :value (if (boundp 'gnus-level-default-subscribed) - gnus-level-default-subscribed - 3)))))) - (defcustom gnus-suppress-duplicates nil "*If non-nil, Gnus will mark duplicate copies of the same article as read." :group 'gnus-meta @@ -1718,11 +1586,6 @@ slower." (function-item mail-extract-address-components) (function :tag "Other"))) -(defcustom gnus-carpal nil - "*If non-nil, display clickable icons." - :group 'gnus-meta - :type 'boolean) - (defcustom gnus-shell-command-separator ";" "String used to separate shell commands." :group 'gnus-files @@ -1739,21 +1602,13 @@ slower." ("nneething" none address prompt-address physical-address) ("nndoc" none address prompt-address) ("nnbabyl" mail address respool) - ("nnkiboze" post virtual) - ("nnsoup" post-mail address) ("nndraft" post-mail) ("nnfolder" mail respool address) ("nngateway" post-mail address prompt-address physical-address) ("nnweb" none) - ("nngoogle" post) - ("nnslashdot" post) - ("nnultimate" none) ("nnrss" none) - ("nnwfm" none) - ("nnwarchive" none) - ("nnlistserv" none) ("nnagent" post-mail) - ("nnimap" post-mail address prompt-address physical-address) + ("nnimap" post-mail address prompt-address physical-address respool) ("nnmaildir" mail respool address) ("nnnil" none)) "*An alist of valid select methods. @@ -1774,7 +1629,8 @@ this variable. I think." (const :format "%v " prompt-address) (const :format "%v " physical-address) (const :format "%v " virtual) - (const respool))))) + (const respool)))) + :version "24.1") (defun gnus-redefine-select-method-widget () "Recomputes the select-method widget based on the value of @@ -1810,12 +1666,11 @@ If this variable is nil, screen refresh may be quicker." (const summary) (const tree))) -;; Added by Keinonen Kari <[email protected]>. -(defcustom gnus-mode-non-string-length nil +(defcustom gnus-mode-non-string-length 30 "*Max length of mode-line non-string contents. If this is nil, Gnus will take space as is needed, leaving the rest -of the mode line intact. Note that the default of nil is unlikely -to be desirable; see the manual for further details." +of the mode line intact." + :version "24.1" :group 'gnus-various :type '(choice (const nil) integer)) @@ -2688,6 +2543,12 @@ a string, be sure to use a valid format, see RFC 2616." (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) (defvar gnus-server-method-cache nil) +(defvar gnus-extended-servers nil) + +;; The carpal mode has been removed, but define the variable for +;; backwards compatability. +(defvar gnus-carpal nil) +(make-obsolete-variable 'gnus-carpal nil "Emacs 24.1") (defvar gnus-agent-fetching nil "Whether Gnus agent is in fetching mode.") @@ -2704,9 +2565,6 @@ a string, be sure to use a valid format, see RFC 2616." (defvar gnus-tree-buffer "*Tree*" "Buffer where Gnus thread trees are displayed.") -;; Dummy variable. -(defvar gnus-use-generic-from nil) - ;; Variable holding the user answers to all method prompts. (defvar gnus-method-history nil) @@ -2734,8 +2592,6 @@ a string, be sure to use a valid format, see RFC 2616." ,(nnheader-concat gnus-cache-directory "active")))) "List of predefined (convenience) servers.") -(defvar gnus-topic-indentation "") ;; Obsolete variable. - (defconst gnus-article-mark-lists '((marked . tick) (replied . reply) (expirable . expire) (killed . killed) @@ -2749,6 +2605,8 @@ a string, be sure to use a valid format, see RFC 2616." '((seen range) (killed range) (bookmark tuple) + (uid tuple) + (active tuple) (score tuple))) ;; Propagate flags to server, with the following exceptions: @@ -2890,17 +2748,12 @@ gnus-registry.el will populate this if it's loaded.") rmail-summary-exists rmail-select-summary) ;; Only used in gnus-util, which has an autoload. ("rmailsum" rmail-update-summary) - ("gnus-audio" :interactive t gnus-audio-play) ("gnus-xmas" gnus-xmas-splash) - ("gnus-soup" :interactive t - gnus-group-brew-soup gnus-brew-soup gnus-soup-add-article - gnus-soup-send-replies gnus-soup-save-areas gnus-soup-pack-packet) - ("nnsoup" nnsoup-pack-replies) ("score-mode" :interactive t gnus-score-mode) ("gnus-mh" gnus-summary-save-article-folder gnus-Folder-save-name gnus-folder-save-name) ("gnus-mh" :interactive t gnus-summary-save-in-folder) - ("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail + ("gnus-demon" gnus-demon-add-scanmail gnus-demon-add-rescan gnus-demon-add-scan-timestamps gnus-demon-add-disconnection gnus-demon-add-handler gnus-demon-remove-handler) @@ -2910,16 +2763,15 @@ gnus-registry.el will populate this if it's loaded.") gnus-convert-image-to-gray-x-face gnus-convert-face-to-png gnus-face-from-file) ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree - gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) - ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close - gnus-nocem-unwanted-article-p) + gnus-tree-open gnus-tree-close) ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info gnus-server-server-name) ("gnus-srvr" gnus-browse-foreign-server) ("gnus-cite" :interactive t gnus-article-highlight-citation gnus-article-hide-citation-maybe gnus-article-hide-citation gnus-article-fill-cited-article - gnus-article-hide-citation-in-followups) + gnus-article-hide-citation-in-followups + gnus-article-fill-cited-long-lines) ("gnus-kill" gnus-kill gnus-apply-kill-file-internal gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author gnus-execute gnus-expunge gnus-batch-kill gnus-batch-score) @@ -3027,8 +2879,6 @@ gnus-registry.el will populate this if it's loaded.") gnus-dup-enter-articles) ("gnus-range" gnus-copy-sequence) ("gnus-eform" gnus-edit-form) - ("gnus-move" :interactive t - gnus-group-move-group-to-server gnus-change-server) ("gnus-logic" gnus-score-advanced) ("gnus-undo" gnus-undo-mode gnus-undo-register) ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next @@ -3298,12 +3148,12 @@ with a `subscribed' parameter." (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. STRINGS will be evaluated in normal `or' order." - `(gnus-string-or-1 ',strings)) + `(gnus-string-or-1 (list ,@strings))) (defun gnus-string-or-1 (strings) (let (string) (while strings - (setq string (eval (pop strings))) + (setq string (pop strings)) (if (string-match "^[ \t]*$" string) (setq string nil) (setq strings nil))) @@ -3319,7 +3169,6 @@ If ARG, insert string at point." (defun gnus-continuum-version (&optional version) "Return VERSION as a floating point number." - (interactive) (unless version (setq version gnus-version)) (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) @@ -3503,14 +3352,14 @@ that that variable is buffer-local to the summary buffers." (defun gnus-news-group-p (group &optional article) "Return non-nil if GROUP (and ARTICLE) come from a news server." (cond ((gnus-member-of-valid 'post group) ;Ordinary news group - t) ;is news of course. + t) ;is news of course. ((not (gnus-member-of-valid 'post-mail group)) ;Non-combined. nil) ;must be mail then. ((vectorp article) ;Has header info. (eq (gnus-request-type group (mail-header-id article)) 'news)) - ((null article) ;Hasn't header info + ((null article) ;Hasn't header info (eq (gnus-request-type group) 'news)) ;(unknown ==> mail) - ((< article 0) ;Virtual message + ((< article 0) ;Virtual message nil) ;we don't know, guess mail. (t ;Has positive number (eq (gnus-request-type group article) 'news)))) ;use it. @@ -3575,7 +3424,7 @@ that that variable is buffer-local to the summary buffers." (nth 1 method)))) method))) -(defsubst gnus-method-to-server (method &optional nocache) +(defsubst gnus-method-to-server (method &optional nocache no-enter-cache) (catch 'server-name (setq method (or method gnus-select-method)) @@ -3601,7 +3450,9 @@ that that variable is buffer-local to the summary buffers." (format "%s" (car method)) (format "%s:%s" (car method) (cadr method)))) (name-method (cons name method))) - (unless (member name-method gnus-server-method-cache) + (when (and (not (member name-method gnus-server-method-cache)) + (not no-enter-cache) + (not (assoc (car name-method) gnus-server-method-cache))) (push name-method gnus-server-method-cache)) name))) @@ -3643,11 +3494,13 @@ that that variable is buffer-local to the summary buffers." (while alist (setq method (gnus-info-method (pop alist))) (when (and (not (stringp method)) - (equal server (gnus-method-to-server method))) + (equal server + (gnus-method-to-server method nil t))) (setq match method alist nil))) match)))) - (when result + (when (and result + (not (assoc server gnus-server-method-cache))) (push (cons server result) gnus-server-method-cache)) result))) @@ -3688,6 +3541,44 @@ that that variable is buffer-local to the summary buffers." gnus-valid-select-methods))) (equal (nth 1 m1) (nth 1 m2))))))) +(defsubst gnus-sloppily-equal-method-parameters (m1 m2) + ;; Check parameters for sloppy equalness. + (let ((p1 (copy-sequence (cddr m1))) + (p2 (copy-sequence (cddr m2))) + e1 e2) + (block nil + (while (setq e1 (pop p1)) + (unless (setq e2 (assq (car e1) p2)) + ;; The parameter doesn't exist in p2. + (return nil)) + (setq p2 (delq e2 p2)) + (unless (equal e1 e2) + (if (not (and (stringp (cadr e1)) + (stringp (cadr e2)))) + (return nil) + ;; Special-case string parameter comparison so that we + ;; can uniquify them. + (let ((s1 (cadr e1)) + (s2 (cadr e2))) + (when (string-match "/$" s1) + (setq s1 (directory-file-name s1))) + (when (string-match "/$" s2) + (setq s2 (directory-file-name s2))) + (unless (equal s1 s2) + (return nil)))))) + ;; If p2 now is empty, they were equal. + (null p2)))) + +(defun gnus-methods-sloppily-equal (m1 m2) + ;; Same method. + (or + (eq m1 m2) + ;; Type and name are equal. + (and + (eq (car m1) (car m2)) + (equal (cadr m1) (cadr m2)) + (gnus-sloppily-equal-method-parameters m1 m2)))) + (defun gnus-server-equal (m1 m2) "Say whether two methods are equal." (let ((m1 (cond ((null m1) gnus-select-method) @@ -3885,12 +3776,13 @@ You should probably use `gnus-find-method-for-group' instead." (defun gnus-expand-group-parameter (match value group) "Use MATCH to expand VALUE in GROUP." - (with-temp-buffer - (insert group) - (goto-char (point-min)) - (while (re-search-forward match nil t) - (replace-match value)) - (buffer-string))) + (let ((start (string-match match group))) + (if start + (let ((matched-string (substring group start (match-end 0)))) + ;; Build match groups + (string-match match matched-string) + (replace-match value nil nil matched-string)) + group))) (defun gnus-expand-group-parameters (match parameters group) "Go through PARAMETERS and expand them according to the match data." @@ -3934,9 +3826,7 @@ The function `gnus-group-find-parameter' will do that for you." ;; Expand if necessary. (if (and (stringp result) (string-match "\\\\[0-9&]" result)) (setq result (gnus-expand-group-parameter (car head) - result group))) - ;; Exit the loop early. - (setq tail nil)))) + result group)))))) ;; Done. result)))) @@ -3946,8 +3836,7 @@ If SYMBOL, return the value of that symbol in the group parameters. If you call this function inside a loop, consider using the faster `gnus-group-fast-parameter' instead." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (if symbol (gnus-group-fast-parameter group symbol allow-list) (nconc @@ -3995,8 +3884,11 @@ If ALLOW-LIST, also allow list as a result." group 'params)))) (defun gnus-group-set-parameter (group name value) - "Set parameter NAME to VALUE in GROUP." - (let ((info (gnus-get-info group))) + "Set parameter NAME to VALUE in GROUP. +GROUP can also be an INFO structure." + (let ((info (if (listp group) + group + (gnus-get-info group)))) (when info (gnus-group-remove-parameter group name) (let ((old-params (gnus-info-params info)) @@ -4006,17 +3898,22 @@ If ALLOW-LIST, also allow list as a result." (not (eq (caar old-params) name))) (setq new-params (append new-params (list (car old-params))))) (setq old-params (cdr old-params))) - (gnus-group-set-info new-params group 'params))))) + (if (listp group) + (gnus-info-set-params info new-params t) + (gnus-group-set-info new-params (gnus-info-group info) 'params)))))) (defun gnus-group-remove-parameter (group name) - "Remove parameter NAME from GROUP." - (let ((info (gnus-get-info group))) + "Remove parameter NAME from GROUP. +GROUP can also be an INFO structure." + (let ((info (if (listp group) + group + (gnus-get-info group)))) (when info (let ((params (gnus-info-params info))) (when params (setq params (delq name params)) (while (assq name params) - (gnus-pull name params)) + (gnus-alist-pull name params)) (gnus-info-set-params info params)))))) (defun gnus-group-add-score (group &optional score) @@ -4106,8 +4003,7 @@ Returns the number of articles marked as read." (defun gnus-kill-save-kill-buffer () (let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name))) (when (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) + (with-current-buffer (get-file-buffer file) (when (buffer-modified-p) (save-buffer)) (kill-buffer (current-buffer)))))) @@ -4154,13 +4050,19 @@ If NEWSGROUP is nil, return the global kill file name instead." gnus-valid-select-methods))) (defun gnus-similar-server-opened (method) - (let ((opened gnus-opened-servers)) + "Return non-nil if we have a similar server opened. +This is defined as a server with the same name, but different +parameters." + (let ((opened gnus-opened-servers) + open) (while (and method opened) - (when (and (equal (cadr method) (cadaar opened)) - (equal (car method) (caaar opened)) - (not (equal method (caar opened)))) - (setq method nil)) - (pop opened)) + (setq open (car (pop opened))) + ;; Type and name are the same... + (when (and (equal (car method) (car open)) + (equal (cadr method) (cadr open)) + ;; ... but the rest of the parameters differ. + (not (gnus-methods-sloppily-equal method open))) + (setq method nil))) (not method))) (defun gnus-server-extend-method (group method) @@ -4171,9 +4073,12 @@ If NEWSGROUP is nil, return the global kill file name instead." (if (or (not (inline (gnus-similar-server-opened method))) (not (cddr method))) method - `(,(car method) ,(concat (cadr method) "+" group) - (,(intern (format "%s-address" (car method))) ,(cadr method)) - ,@(cddr method)))) + (setq method + `(,(car method) ,(concat (cadr method) "+" group) + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method))) + (push method gnus-extended-servers) + method)) (defun gnus-server-status (method) "Return the status of METHOD." @@ -4198,6 +4103,20 @@ If NEWSGROUP is nil, return the global kill file name instead." (format "%s using %s" address (car server)) (format "%s" (car server))))) +(defun gnus-same-method-different-name (method) + (let ((slot (intern (concat (symbol-name (car method)) "-address")))) + (unless (assq slot (cddr method)) + (setq method + (append method (list (list slot (nth 1 method))))))) + (let ((methods gnus-extended-servers) + open found) + (while (and (not found) + (setq open (pop methods))) + (when (and (eq (car method) (car open)) + (gnus-sloppily-equal-method-parameters method open)) + (setq found open))) + found)) + (defun gnus-find-method-for-group (group &optional info) "Find the select method that GROUP uses." (or gnus-override-method @@ -4220,7 +4139,10 @@ If NEWSGROUP is nil, return the global kill file name instead." (cond ((stringp method) (inline (gnus-server-to-method method))) ((stringp (cadr method)) - (inline (gnus-server-extend-method group method))) + (or + (inline + (gnus-same-method-different-name method)) + (inline (gnus-server-extend-method group method)))) (t method))) (cond ((equal (cadr method) "") @@ -4291,9 +4213,9 @@ Allow completion over sensible values." gnus-predefined-server-alist gnus-server-alist)) (method - (completing-read - prompt servers - nil t nil 'gnus-method-history))) + (gnus-completing-read + prompt (mapcar 'car servers) + t nil 'gnus-method-history))) (cond ((equal method "") (setq method gnus-select-method)) @@ -4409,10 +4331,16 @@ If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use." (interactive "P") + ;; When using the development version of Gnus, load the gnus-load + ;; file. + (unless (string-match "^Gnus" gnus-version) + (load "gnus-load" nil t)) (unless (byte-code-function-p (symbol-function 'gnus)) (message "You should byte-compile Gnus") (sit-for 2)) - (gnus-1 arg dont-connect slave)) + (let ((gnus-action-message-log (list nil))) + (gnus-1 arg dont-connect slave) + (gnus-final-warning))) ;; Allow redefinition of Gnus functions. @@ -4420,5 +4348,4 @@ prompt the user for the name of an NNTP server to use." (provide 'gnus) -;; arch-tag: acebeeab-f331-4f8f-a7ea-89c58c84f636 ;;; gnus.el ends here diff --git a/lisp/gnus/gravatar.el b/lisp/gnus/gravatar.el new file mode 100644 index 0000000000..c17bd201d2 --- /dev/null +++ b/lisp/gnus/gravatar.el @@ -0,0 +1,151 @@ +;;; gravatar.el --- Get Gravatars + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Julien Danjou <[email protected]> +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'url) +(require 'url-cache) + +(defgroup gravatar nil + "Gravatar." + :group 'comm) + +(defcustom gravatar-automatic-caching t + "Whether cache retrieved gravatar." + :group 'gravatar) + +(defcustom gravatar-cache-ttl (days-to-time 30) + "Time to live for gravatar cache entries." + :group 'gravatar) + +(defcustom gravatar-rating "g" + "Default rating for gravatar." + :group 'gravatar) + +(defcustom gravatar-size 32 + "Default size in pixels for gravatars." + :group 'gravatar) + +(defconst gravatar-base-url + "http://www.gravatar.com/avatar" + "Base URL for getting gravatars.") + +(defun gravatar-hash (mail-address) + "Create an hash from MAIL-ADDRESS." + (md5 (downcase mail-address))) + +(defun gravatar-build-url (mail-address) + "Return an URL to retrieve MAIL-ADDRESS gravatar." + (format "%s/%s?d=404&r=%s&s=%d" + gravatar-base-url + (gravatar-hash mail-address) + gravatar-rating + gravatar-size)) + +(defun gravatar-cache-expired (url) + "Check if URL is cached for more than `gravatar-cache-ttl'." + (cond (url-standalone-mode + (not (file-exists-p (url-cache-create-filename url)))) + (t (let ((cache-time (url-is-cached url))) + (if cache-time + (time-less-p + (time-add + cache-time + gravatar-cache-ttl) + (current-time)) + t))))) + +(defun gravatar-get-data () + "Get data from current buffer." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) + (when (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max)))))) + +(eval-and-compile + (cond ((featurep 'xemacs) + (require 'gnus-xmas) + (defalias 'gravatar-create-image 'gnus-xmas-create-image)) + ((featurep 'gnus-ems) + (defalias 'gravatar-create-image 'gnus-create-image)) + (t + (require 'image) + (defalias 'gravatar-create-image 'create-image)))) + +(defun gravatar-data->image () + "Get data of current buffer and return an image. +If no image available, return 'error." + (let ((data (gravatar-get-data))) + (if data + (gravatar-create-image data nil t) + 'error))) + +;;;###autoload +(defun gravatar-retrieve (mail-address cb &optional cbargs) + "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval. +You can provide a list of argument to pass to CB in CBARGS." + (let ((url (gravatar-build-url mail-address))) + (if (gravatar-cache-expired url) + (url-retrieve url + 'gravatar-retrieved + (list cb (when cbargs cbargs))) + (apply cb + (with-temp-buffer + (mm-disable-multibyte) + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image)) + cbargs)))) + +;;;###autoload +(defun gravatar-retrieve-synchronously (mail-address) + "Retrieve MAIL-ADDRESS gravatar and returns it." + (let ((url (gravatar-build-url mail-address))) + (if (gravatar-cache-expired url) + (with-current-buffer (url-retrieve-synchronously url) + (when gravatar-automatic-caching + (url-store-in-cache (current-buffer))) + (let ((data (gravatar-data->image))) + (kill-buffer (current-buffer)) + data)) + (with-temp-buffer + (mm-disable-multibyte) + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image))))) + + +(defun gravatar-retrieved (status cb &optional cbargs) + "Callback function used by `gravatar-retrieve'." + ;; Store gravatar? + (when gravatar-automatic-caching + (url-store-in-cache (current-buffer))) + (if (plist-get status :error) + ;; Error happened. + (apply cb 'error cbargs) + (apply cb (gravatar-data->image) cbargs)) + (kill-buffer (current-buffer))) + +(provide 'gravatar) + +;;; gravatar.el ends here diff --git a/lisp/gnus/html2text.el b/lisp/gnus/html2text.el index 17379ff33a..8a7d14bcb5 100644 --- a/lisp/gnus/html2text.el +++ b/lisp/gnus/html2text.el @@ -508,5 +508,5 @@ See the documentation for that variable." ;; </Interactive functions> ;; (provide 'html2text) -;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e + ;;; html2text.el ends here diff --git a/lisp/gnus/ietf-drums.el b/lisp/gnus/ietf-drums.el index e1ee3b123b..af644da687 100644 --- a/lisp/gnus/ietf-drums.el +++ b/lisp/gnus/ietf-drums.el @@ -39,7 +39,6 @@ ;;; Code: (eval-when-compile (require 'cl)) -(require 'time-date) (require 'mm-util) (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" @@ -296,5 +295,4 @@ a list of address strings." (provide 'ietf-drums) -;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9 ;;; ietf-drums.el ends here diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el index 268c03bbe8..dff2c070b9 100644 --- a/lisp/gnus/legacy-gnus-agent.el +++ b/lisp/gnus/legacy-gnus-agent.el @@ -250,5 +250,4 @@ possible that the hook was persistently saved." (provide 'legacy-gnus-agent) -;; arch-tag: 845c7b8a-88f7-4468-b8d7-94e8fc72cf1a ;;; legacy-gnus-agent.el ends here diff --git a/lisp/gnus/mail-parse.el b/lisp/gnus/mail-parse.el index c3808a8107..801b94e851 100644 --- a/lisp/gnus/mail-parse.el +++ b/lisp/gnus/mail-parse.el @@ -45,8 +45,7 @@ (defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) (defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) (defalias 'mail-content-type-get 'rfc2231-get-value) -;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) -(defalias 'mail-header-encode-parameter 'rfc2231-encode-string) +(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) (defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) (defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) @@ -74,5 +73,4 @@ (provide 'mail-parse) -;; arch-tag: 3e63d75c-c962-4784-ab01-7ba07ca9d2d4 ;;; mail-parse.el ends here diff --git a/lisp/gnus/mail-prsvr.el b/lisp/gnus/mail-prsvr.el index 1a0cbe1acc..78bda272f0 100644 --- a/lisp/gnus/mail-prsvr.el +++ b/lisp/gnus/mail-prsvr.el @@ -41,5 +41,4 @@ what the desired charsets is to be ignored.") (provide 'mail-prsvr) -;; arch-tag: 9ba878cc-8b43-4f7a-85b1-69b1a9a5d9f5 ;;; mail-prsvr.el ends here diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index dd7cd5cfe6..a3ba781c6c 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -219,34 +219,6 @@ See Info node `(gnus)Mail Source Specifiers'." (boolean :tag "Dontexpunge")) (group :inline t (const :format "" :value :plugged) - (boolean :tag "Plugged")))) - (cons :tag "Webmail server" - (const :format "" webmail) - (checklist :tag "Options" :greedy t - (group :inline t - (const :format "" :value :subtype) - ;; Should be generated from - ;; `webmail-type-definition', but we - ;; can't require webmail without W3. - (choice :tag "Subtype" - :value hotmail - (const hotmail) - (const yahoo) - (const netaddress) - (const netscape) - (const my-deja))) - (group :inline t - (const :format "" :value :user) - (string :tag "User")) - (group :inline t - (const :format "" :value :password) - (string :tag "Password")) - (group :inline t - (const :format "" - :value :dontexpunge) - (boolean :tag "Dontexpunge")) - (group :inline t - (const :format "" :value :plugged) (boolean :tag "Plugged")))))))) (defcustom mail-source-ignore-errors nil @@ -387,13 +359,7 @@ Common keywords should be listed here.") (:prescript) (:prescript-delay) (:postscript) - (:dontexpunge)) - (webmail - (:subtype hotmail) - (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) - (:password) - (:dontexpunge) - (:authentication password))) + (:dontexpunge))) "Mapping from keywords to default values. All keywords that can be used must be listed here.")) @@ -402,8 +368,7 @@ All keywords that can be used must be listed here.")) (directory mail-source-fetch-directory) (pop mail-source-fetch-pop) (maildir mail-source-fetch-maildir) - (imap mail-source-fetch-imap) - (webmail mail-source-fetch-webmail)) + (imap mail-source-fetch-imap)) "A mapping from source type to fetcher function.") (defvar mail-source-password-cache nil) @@ -466,10 +431,10 @@ the `mail-source-keyword-map' variable." ;; 1) the auth-sources user and password override everything ;; 2) it avoids macros, so it's cleaner ;; 3) it falls through to the mail-sources and then default values - (cond + (cond ((and (eq keyword :user) - (setq user-auth + (setq user-auth (nth 0 (auth-source-user-or-password '("login" "password") ;; this is "host" in auth-sources @@ -536,7 +501,9 @@ See `mail-source-bind'." (t value))) -(defun mail-source-fetch (source callback) +(autoload 'nnheader-message "nnheader") + +(defun mail-source-fetch (source callback &optional method) "Fetch mail from SOURCE and call CALLBACK zero or more times. CALLBACK will be called with the name of the file where (some of) the mail from SOURCE is put. @@ -544,6 +511,16 @@ Return the number of files that were found." (mail-source-bind-common source (if (or mail-source-plugged plugged) (save-excursion + ;; Special-case the `file' handler since it's so common and + ;; just adds noise. + (when (or (not (eq (car source) 'file)) + (mail-source-bind (file source) + (file-exists-p path))) + (nnheader-message 4 "%sReading incoming mail from %s..." + (if method + (format "%s: " method) + "") + (car source))) (let ((function (cadr (assq (car source) mail-source-fetcher-alist))) (found 0)) (unless function @@ -574,10 +551,13 @@ Return the number of files that were found." (error "Cannot get new mail")) 0))))))))) +(declare-function gnus-message "gnus-util" (level &rest args)) + (defun mail-source-delete-old-incoming (&optional age confirm) "Remove incoming files older than AGE days. If CONFIRM is non-nil, ask for confirmation before removing a file." (interactive "P") + (require 'gnus-util) (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days (low2days (/ 1.0 65536.0)) ;; convert low bits to days (diff (if (natnump age) age 30));; fallback, if no valid AGE given @@ -616,6 +596,10 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) 0) (funcall callback mail-source-crash-box info))) +(autoload 'gnus-float-time "gnus-util") + +(defvar mail-source-incoming-last-checked-time nil) + (defun mail-source-delete-crash-box () (when (file-exists-p mail-source-crash-box) ;; Delete or move the incoming mail out of the way. @@ -631,9 +615,16 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (rename-file mail-source-crash-box incoming t) ;; remove old incoming files? (when (natnump mail-source-delete-incoming) - (mail-source-delete-old-incoming - mail-source-delete-incoming - mail-source-delete-old-incoming-confirm)))))) + ;; Don't check for old incoming files more than once per day to + ;; save a lot of file accesses. + (when (or (null mail-source-incoming-last-checked-time) + (> (gnus-float-time + (time-since mail-source-incoming-last-checked-time)) + (* 24 60 60))) + (setq mail-source-incoming-last-checked-time (current-time)) + (mail-source-delete-old-incoming + mail-source-delete-incoming + mail-source-delete-old-incoming-confirm))))))) (defun mail-source-movemail (from to) "Move FROM to TO using movemail." @@ -971,7 +962,7 @@ This only works when `display-time' is enabled." (if on (progn (require 'time) - ;; display-time-mail-function is an Emacs 21 feature. + ;; display-time-mail-function is an Emacs feature. (setq display-time-mail-function #'mail-source-new-mail-p) ;; Set up the main timer. (setq mail-source-report-new-mail-timer @@ -1116,31 +1107,6 @@ This only works when `display-time' is enabled." ?s server ?P port ?u user)) found))) -(autoload 'webmail-fetch "webmail") - -(defun mail-source-fetch-webmail (source callback) - "Fetch for webmail source." - (mail-source-bind (webmail source) - (let ((mail-source-string (format "webmail:%s:%s" subtype user)) - (webmail-newmail-only dontexpunge) - (webmail-move-to-trash-can (not dontexpunge))) - (when (eq authentication 'password) - (setq password - (or password - (cdr (assoc (format "webmail:%s:%s" subtype user) - mail-source-password-cache)) - (read-passwd - (format "Password for %s at %s: " user subtype)))) - (when (and password - (not (assoc (format "webmail:%s:%s" subtype user) - mail-source-password-cache))) - (push (cons (format "webmail:%s:%s" subtype user) password) - mail-source-password-cache))) - (webmail-fetch mail-source-crash-box subtype user password) - (mail-source-callback callback (symbol-name subtype)) - (mail-source-delete-crash-box)))) - (provide 'mail-source) -;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd ;;; mail-source.el ends here diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el index 12fbea7835..b6cef39203 100644 --- a/lisp/gnus/mailcap.el +++ b/lisp/gnus/mailcap.el @@ -335,7 +335,7 @@ nil means your home directory." :group 'mailcap) (defvar mailcap-poor-system-types - '(ms-dos ms-windows windows-nt win32 w32 mswindows) + '(ms-dos windows-nt) "Systems that don't have a Unix-like directory hierarchy.") ;;; @@ -423,7 +423,7 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus "/usr/local/etc/mailcap")))) (let ((fnames (reverse (if (stringp path) - (delete "" (split-string path path-separator)) + (split-string path path-separator t) path))) fname) (while fnames @@ -812,7 +812,10 @@ If NO-DECODE is non-nil, don't decode STRING." ;;; (defvar mailcap-mime-extensions - '(("" . "text/plain") + '(("" . "text/plain") + (".1" . "text/plain") ;; Manual pages + (".3" . "text/plain") + (".8" . "text/plain") (".abs" . "audio/x-mpeg") (".aif" . "audio/aiff") (".aifc" . "audio/aiff") @@ -828,6 +831,7 @@ If NO-DECODE is non-nil, don't decode STRING." (".css" . "text/css") (".dvi" . "application/x-dvi") (".diff" . "text/x-patch") + (".dpatch". "test/x-patch") (".el" . "application/emacs-lisp") (".eps" . "application/postscript") (".etx" . "text/x-setext") @@ -869,6 +873,7 @@ If NO-DECODE is non-nil, don't decode STRING." (".pict" . "image/pict") (".png" . "image/png") (".pnm" . "image/x-portable-anymap") + (".pod" . "text/plain") (".ppm" . "image/portable-pixmap") (".ps" . "application/postscript") (".qt" . "video/quicktime") @@ -941,7 +946,7 @@ If FORCE, re-parse even if already parsed." "/usr/local/etc/mime-types" "/usr/local/www/conf/mime-types")))) (let ((fnames (reverse (if (stringp path) - (delete "" (split-string path path-separator)) + (split-string path path-separator t) path))) fname) (while fnames @@ -1069,5 +1074,4 @@ If FORCE, re-parse even if already parsed." (provide 'mailcap) -;; arch-tag: 1fd4f9c9-c305-4d2e-9747-3a4d45baa0bd ;;; mailcap.el ends here diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 867798f9dc..6ebcdc2876 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -29,16 +29,18 @@ ;;; Code: +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) -(require 'hashcash) -(require 'canlock) (require 'mailheader) (require 'gmm-utils) -(require 'nnheader) +(require 'mail-utils) +;; Only for the trivial macros mail-header-from, mail-header-date +;; mail-header-references, mail-header-subject, mail-header-id +(eval-when-compile (require 'nnheader)) ;; This is apparently necessary even though things are autoloaded. ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better ;; require mailabbrev here. @@ -48,7 +50,6 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'ecomplete) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ @@ -160,9 +161,7 @@ If this variable is nil, no such courtesy message will be added." :type 'regexp) (defcustom message-from-style mail-from-style -;; Default to the value of `mail-from-style', available in all Emacsen -;; that Gnus supports. - "*Specifies how \"From\" headers look. + "Specifies how \"From\" headers look. If nil, they contain just the return address like: @@ -249,6 +248,15 @@ included. Organization and User-Agent are optional." :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) +(defcustom message-prune-recipient-rules nil + "Rules for how to prune the list of recipients when doing wide replies. +This is a list of regexps and regexp matches." + :version "24.1" + :group 'message-mail + :group 'message-headers + :link '(custom-manual "(message)Wide Reply") + :type '(repeat regexp)) + (defcustom message-deletable-headers '(Message-ID Date Lines) "Headers to be deleted if they already exist and were generated by message previously." :group 'message-headers @@ -269,14 +277,14 @@ included. Organization and User-Agent are optional." regexp)) (defcustom message-ignored-mail-headers - "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" + "^\\([GF]cc\\|Resent-Fcc\\|Xref\\|X-Draft-From\\|X-Gnus-Agent-Meta-Information\\):" "*Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type 'regexp) -(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:\\|^Injection-Date:\\|^Injection-Info:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." @@ -298,7 +306,7 @@ any confusion." ;;; Start of variables adopted from `message-utils.el'. -(defcustom message-subject-trailing-was-query 'ask +(defcustom message-subject-trailing-was-query t "*What to do with trailing \"(was: <old subject>)\" in subject lines. If nil, leave the subject unchanged. If it is the symbol `ask', query the user what do do. In this case, the subject is matched against @@ -306,7 +314,7 @@ the user what do do. In this case, the subject is matched against `message-subject-trailing-was-query' is t, always strip the trailing old subject. In this case, `message-subject-trailing-was-regexp' is used." - :version "22.1" + :version "24.1" :type '(choice (const :tag "never" nil) (const :tag "always strip" t) (const ask)) @@ -314,7 +322,7 @@ used." :group 'message-various) (defcustom message-subject-trailing-was-ask-regexp - "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)" + "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)" "*Regexp matching \"(was: <old subject>)\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if @@ -437,8 +445,6 @@ whitespace)." :group 'message-various) (defcustom message-interactive mail-interactive -;; Default to the value of `mail-interactive', available in all Emacsen -;; that Gnus supports. "Non-nil means when sending a message wait for and display errors. A value of nil means let mailer mail back a message to report errors." :version "23.2" @@ -455,7 +461,7 @@ A value of nil means let mailer mail back a message to report errors." :link '(custom-manual "(message)Sending Variables") :type 'boolean) -(defcustom message-generate-new-buffers 'unique +(defcustom message-generate-new-buffers 'unsent "*Say whether to create a new message buffer to compose a message. Valid values include: @@ -478,6 +484,7 @@ function If this is a function, call that function with three parameters: The type, the To address and the group name (any of these may be nil). The function should return the new buffer name." + :version "24.1" :group 'message-buffers :link '(custom-manual "(message)Message Buffers") :type '(choice (const nil) @@ -500,14 +507,9 @@ This is used by `message-kill-buffer'." :group 'message-buffers :type 'boolean) -(defvar gnus-local-organization) (defcustom message-user-organization - (or (and (boundp 'gnus-local-organization) - (stringp gnus-local-organization) - gnus-local-organization) - (getenv "ORGANIZATION") - t) - "*String to be used as an Organization header. + (or (getenv "ORGANIZATION") t) + "String to be used as an Organization header. If t, use `message-user-organization-file'." :group 'message-headers :type '(choice string @@ -615,30 +617,9 @@ Done before generating the new subject of a forward." :link '(custom-manual "(message)Insertion Variables") :type 'regexp) -(defcustom message-cite-prefix-regexp - ;; Default to the value of `mail-citation-prefix-regexp' if available. - ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is unavailable - ;; unless sendmail.el is loaded. - (cond ((boundp 'mail-citation-prefix-regexp) - mail-citation-prefix-regexp) - ((string-match "[[:digit:]]" "1") - ;; Support POSIX? XEmacs 21.5.27 doesn't. - "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+") - (t - ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. - (let (non-word-constituents) - (with-syntax-table text-mode-syntax-table - (setq non-word-constituents - (concat - (if (string-match "\\w" "_") "" "_") - (if (string-match "\\w" ".") "" ".")))) - (if (equal non-word-constituents "") - "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+" - (concat "\\([ \t]*\\(\\w\\|[" - non-word-constituents - "]\\)+>+\\|[ \t]*[]>|}]\\)+"))))) +(defcustom message-cite-prefix-regexp mail-citation-prefix-regexp "*Regexp matching the longest possible citation prefix on a line." - :version "23.2" + :version "24.1" :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") :type 'regexp @@ -655,8 +636,6 @@ Done before generating the new subject of a forward." :link '(custom-manual "(message)Canceling News") :type 'string) -(defvar smtpmail-default-smtp-server) - (defun message-send-mail-function () "Return suitable value for the variable `message-send-mail-function'." (cond ((and (require 'sendmail) @@ -665,14 +644,13 @@ Done before generating the new subject of a forward." (executable-find sendmail-program)) 'message-send-mail-with-sendmail) ((and (locate-library "smtpmail") - (require 'smtpmail) + (boundp 'smtpmail-default-smtp-server) smtpmail-default-smtp-server) 'message-smtpmail-send-it) ((locate-library "mailclient") 'message-send-mail-with-mailclient) (t - (lambda () - (error "Don't know how to send mail. Please customize `message-send-mail-function'"))))) + (error "Don't know how to send mail. Please customize `message-send-mail-function'")))) ;; Useful to set in site-init.el (defcustom message-send-mail-function @@ -833,9 +811,7 @@ Doing so would be even more evil than leaving it out." :type 'boolean) (defcustom message-sendmail-envelope-from - ;; Default to the value of `mail-envelope-from' if available. - ;; Note: as for Emacsen that Gnus supports, except for SXEmacs, it is - ;; unavailable unless sendmail.el is loaded. + ;; `mail-envelope-from' is unavailable unless sendmail.el is loaded. (if (boundp 'mail-envelope-from) mail-envelope-from) "*Envelope-from when sending mail with sendmail. If this is nil, use `user-mail-address'. If it is the symbol @@ -1013,10 +989,7 @@ Please also read the note in the documentation of :version "23.1" ;; No Gnus :group 'message-insertion) -(defcustom message-yank-prefix - ;; Default to the value of `mail-yank-prefix' if available. - ;; Note: as for Emacs 21, it is unavailable unless sendmail.el is loaded. - (if (boundp 'mail-yank-prefix) mail-yank-prefix "> ") +(defcustom message-yank-prefix mail-yank-prefix "*Prefix inserted on the lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. See also `message-yank-cited-prefix' and `message-yank-empty-prefix'." @@ -1042,11 +1015,7 @@ See also `message-yank-prefix' and `message-yank-cited-prefix'." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -(defcustom message-indentation-spaces - ;; Default to the value of `mail-indentation-spaces' if available. - ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is unavailable - ;; unless sendmail.el is loaded. - (if (boundp 'mail-indentation-spaces) mail-indentation-spaces 3) +(defcustom message-indentation-spaces mail-indentation-spaces "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." :version "23.2" @@ -1077,8 +1046,6 @@ point and mark around the citation text as modified." :group 'message-insertion) (defcustom message-signature mail-signature - ;; Default to the value of `mail-signature', available in all Emacsen - ;; that Gnus supports. "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. @@ -1088,11 +1055,7 @@ If a form, the result from the form will be used instead." :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -(defcustom message-signature-file - ;; Default to the value of `mail-signature-file' if available. - ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is unavailable - ;; unless sendmail.el is loaded. - (if (boundp 'mail-signature-file) mail-signature-file "~/.signature") +(defcustom message-signature-file mail-signature-file "*Name of file containing the text inserted at end of message buffer. Ignored if the named file doesn't exist. If nil, don't insert a signature. @@ -1157,6 +1120,8 @@ It is a vector of the following headers: (defvar message-checksum nil) (defvar message-send-actions nil "A list of actions to be performed upon successful sending of a message.") +(defvar message-return-action nil + "Action to return to the caller after sending or postphoning a message.") (defvar message-exit-actions nil "A list of actions to be performed upon exiting after sending a message.") (defvar message-kill-actions nil @@ -1171,13 +1136,17 @@ It is a vector of the following headers: :error "All header lines must be newline terminated") (defcustom message-default-headers "" - "*A string containing header lines to be inserted in outgoing messages. -It is inserted before you edit the message, so you can edit or delete -these lines." + "Header lines to be inserted in outgoing messages. +This can be set to a string containing or a function returning +header lines to be inserted before you edit the message, so you +can edit or delete these lines. If set to a function, it is +called and its result is inserted." :version "23.2" :group 'message-headers :link '(custom-manual "(message)Message Headers") - :type 'message-header-lines) + :type '(choice + (message-header-lines :tag "String") + (function :tag "Function"))) (defcustom message-default-mail-headers ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555. @@ -1191,8 +1160,8 @@ these lines." (stringp mail-archive-file-name)) (format "FCC: %s\n" mail-archive-file-name)) ;; Use the value of `mail-default-headers' if available. - ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is - ;; unavailable unless sendmail.el is loaded. + ;; Note: as for XEmacs 21.4 and 21.5, it is unavailable + ;; unless sendmail.el is loaded. (if (boundp 'mail-default-headers) mail-default-headers)) "*A string of header lines to be inserted in outgoing mails." @@ -1280,7 +1249,7 @@ text and it replaces `self-insert-command' with the other command, e.g. :type '(repeat function)) (defcustom message-auto-save-directory - (file-name-as-directory (nnheader-concat message-directory "drafts")) + (file-name-as-directory (expand-file-name "drafts" message-directory)) "*Directory where Message auto-saves buffers if Gnus isn't running. If nil, Message won't auto-save." :group 'message-buffers @@ -1623,11 +1592,11 @@ If you'd like to make it possible to share draft files between XEmacs and Emacs, you may use `iso-2022-7bit' for this value at your own risk. Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") -(defcustom message-send-mail-partially-limit 1000000 +(defcustom message-send-mail-partially-limit nil "The limitation of messages sent as message/partial. The lower bound of message size in characters, beyond which the message should be sent in several parts. If it is nil, the size is unlimited." - :version "21.1" + :version "24.1" :group 'message-buffers :link '(custom-manual "(message)Mail Variables") :type '(choice (const :tag "unlimited" nil) @@ -1719,13 +1688,14 @@ functionality to work." (const :tag "Never" nil) (const :tag "Always" t))) -(defcustom message-generate-hashcash (if (executable-find "hashcash") t) +(defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic) "*Whether to generate X-Hashcash: headers. If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). You must have the \"hashcash\" binary installed, see `hashcash-path'." + :version "24.1" :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type '(choice (const :tag "Always" t) @@ -1742,6 +1712,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-mime-part nil) (defvar message-posting-charset nil) (defvar message-inserted-headers nil) +(defvar message-inhibit-ecomplete nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -1956,6 +1927,8 @@ is used by default." (setq paren nil)))) (nreverse elems))))) +(autoload 'nnheader-insert-file-contents "nnheader") + (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." (when (and (file-exists-p file) @@ -2180,7 +2153,6 @@ Leading \"Re: \" is not stripped by this function. Use the function (defun message-change-subject (new-subject) "Ask for NEW-SUBJECT header, append (was: <Old Subject>)." - ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged> (interactive (list (read-from-minibuffer "New subject: "))) @@ -2668,7 +2640,6 @@ PGG manual, depending on the value of `mml2015-use'." (define-key message-mode-map "\C-a" 'message-beginning-of-line) (define-key message-mode-map "\t" 'message-tab) - (define-key message-mode-map "\M-;" 'comment-region) (define-key message-mode-map "\M-n" 'message-display-abbrev)) @@ -2849,6 +2820,8 @@ See also `message-forbidden-properties'." (inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) +(autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23. + ;;;###autoload (define-derived-mode message-mode text-mode "Message" "Major mode for editing mail and news to be sent. @@ -2892,6 +2865,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'message-reply-buffer) nil) (set (make-local-variable 'message-inserted-headers) nil) (set (make-local-variable 'message-send-actions) nil) + (set (make-local-variable 'message-return-action) nil) (set (make-local-variable 'message-exit-actions) nil) (set (make-local-variable 'message-kill-actions) nil) (set (make-local-variable 'message-postpone-actions) nil) @@ -2943,6 +2917,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (mail-aliases-setup)))) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) + (add-hook 'completion-at-point-functions 'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) (unless (buffer-base-buffer) @@ -3071,10 +3046,22 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (interactive) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body (&optional interactivep) +(eval-when-compile + (defmacro message-called-interactively-p (kind) + (condition-case nil + (progn + (eval '(called-interactively-p 'any)) + ;; Emacs >=23.2 + `(called-interactively-p ,kind)) + ;; Emacs <23.2 + (wrong-number-of-arguments '(called-interactively-p)) + ;; XEmacs + (void-function '(interactive-p))))) + +(defun message-goto-body () "Move point to the beginning of the message body." - (interactive (list t)) - (when (and interactivep + (interactive) + (when (and (message-called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) (goto-char (point-min)) @@ -3083,7 +3070,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (defun message-in-body-p () "Return t if point is in the message body." - (let ((body (save-excursion (message-goto-body) (point)))) + (let ((body (save-excursion (message-goto-body)))) (>= (point) body))) (defun message-goto-eoh () @@ -3408,8 +3395,8 @@ Message buffers and is not meant to be called directly." ;; if message-signature-file contains a path. (not (file-name-directory message-signature-file))) - (nnheader-concat message-signature-directory - message-signature-file) + (expand-file-name message-signature-file + message-signature-directory) message-signature-file)) (file-exists-p signature-file)))) (when signature @@ -3971,11 +3958,9 @@ The text will also be indented the normal way." (actions message-exit-actions)) (when (and (message-send arg) (buffer-name buf)) + (message-bury buf) (if message-kill-buffer-on-exit - (kill-buffer buf) - (bury-buffer buf) - (when (eq buf (current-buffer)) - (message-bury buf))) + (kill-buffer buf)) (message-do-actions actions) t))) @@ -4025,9 +4010,8 @@ Instead, just auto-save the buffer and then bury it." "Bury this mail BUFFER." (let ((newbuf (other-buffer buffer))) (bury-buffer buffer) - (if (and (window-dedicated-p (selected-window)) - (not (null (delq (selected-frame) (visible-frame-list))))) - (delete-frame (selected-frame)) + (if message-return-action + (apply (car message-return-action) (cdr message-return-action)) (switch-to-buffer newbuf)))) (defun message-send (&optional arg) @@ -4090,7 +4074,8 @@ It should typically alter the sending method in some way or other." (run-hooks 'message-sent-hook)) (message "Sending...done") ;; Do ecomplete address snarfing. - (when (message-mail-alias-type-p 'ecomplete) + (when (and (message-mail-alias-type-p 'ecomplete) + (not message-inhibit-ecomplete)) (message-put-addresses-in-ecomplete)) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) @@ -4232,7 +4217,7 @@ conformance." (?r ,(format "Replace non-printable characters with \"%s\" and send" message-replacement-char)) - (?i "Ignore non-printable characters and send") + (?s "Send as is without removing anything") (?e "Continue editing")))) (if (eq choice ?e) (error "Non-printable characters")) @@ -4276,9 +4261,10 @@ matching entry in `message-bogus-addresses'." ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? (let (found) (mapc (lambda (address) - (setq address (cadr address)) + (setq address (or (cadr address) "")) (when - (or (not + (or (string= "" address) + (not (or (not (string-match "@" address)) (string-match @@ -4292,7 +4278,7 @@ matching entry in `message-bogus-addresses'." "\\|") message-bogus-addresses))) (string-match re address)))) - (push address found))) + (push address found))) ;; (mail-extract-address-components recipients t)) found)) @@ -4412,6 +4398,8 @@ This function could be useful in `message-setup-hook'." (erase-buffer))) (kill-buffer tembuf)))) +(declare-function hashcash-wait-async "hashcash" (&optional buffer)) + (defun message-send-mail (&optional arg) (require 'mail-utils) (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) @@ -4419,14 +4407,26 @@ This function could be useful in `message-setup-hook'." (news (message-news-p)) (mailbuf (current-buffer)) (message-this-is-mail t) + ;; gnus-setup-posting-charset is autoloaded in mml.el (FIXME + ;; maybe it should not be), which this file requires. Hence + ;; the fboundp test is always true. Loading it from gnus-msg + ;; loads many Gnus files (Bug#5642). If + ;; gnus-group-posting-charset-alist hasn't been customized, + ;; this is just going to return nil anyway. FIXME it would + ;; be good to improve this further, because even if g-g-p-c-a + ;; has been customized, that is likely to just be for news. + ;; Eg either move the definition from gnus-msg, or separate out + ;; the mail and news parts. (message-posting-charset - (if (fboundp 'gnus-setup-posting-charset) + (if (and (fboundp 'gnus-setup-posting-charset) + (boundp 'gnus-group-posting-charset-alist)) (gnus-setup-posting-charset nil) message-posting-charset)) (headers message-required-mail-headers)) (when (and message-generate-hashcash (not (eq message-generate-hashcash 'opportunistic))) (message "Generating hashcash...") + (require 'hashcash) ;; Wait for calculations already started to finish... (hashcash-wait-async) ;; ...and do calculations not already done. mail-add-payment @@ -4491,6 +4491,8 @@ This function could be useful in `message-setup-hook'." (save-restriction (message-narrow-to-headers) (and news + (not (message-fetch-field "List-Post")) + (not (message-fetch-field "List-ID")) (or (message-fetch-field "cc") (message-fetch-field "bcc") (message-fetch-field "to")) @@ -4507,7 +4509,9 @@ This function could be useful in `message-setup-hook'." (string= "base64" (message-fetch-field "content-transfer-encoding"))))))) - (message-insert-courtesy-copy)) + (message-insert-courtesy-copy + (with-current-buffer mailbuf + message-courtesy-message))) ;; Let's make sure we encoded all the body. (assert (save-excursion (goto-char (point-min)) @@ -4548,6 +4552,7 @@ If you always want Gnus to send messages in one piece, set (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." + (require 'sendmail) (let ((errbuf (if message-interactive (message-generate-new-buffer-clone-locals " sendmail errors") @@ -4711,10 +4716,14 @@ Do not use this for anything important, it is cryptographically weak." (prin1-to-string (recent-keys)) (prin1-to-string (garbage-collect)))))) +(defvar canlock-password) +(defvar canlock-password-for-verify) + (defun message-canlock-password () "The password used by message for cancel locks. This is the value of `canlock-password', if that option is non-nil. Otherwise, generate and save a value for `canlock-password' first." + (require 'canlock) (unless canlock-password (customize-save-variable 'canlock-password (message-canlock-generate)) (setq canlock-password-for-verify canlock-password)) @@ -4725,7 +4734,12 @@ Otherwise, generate and save a value for `canlock-password' first." (message-canlock-password) (canlock-insert-header))) +(autoload 'nnheader-get-report "nnheader") + +(declare-function gnus-setup-posting-charset "gnus-msg" (group)) + (defun message-send-news (&optional arg) + (require 'gnus-msg) (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (functionp message-post-method) @@ -5412,7 +5426,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (* 25 25))) (let ((tm (current-time))) (concat - (if (or (memq system-type '(ms-dos emx)) + (if (or (eq system-type 'ms-dos) ;; message-number-base36 doesn't handle bigints. (floatp (user-uid))) (let ((user (downcase (user-login-name)))) @@ -5470,7 +5484,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (defun message-make-references () "Return the References header for this message." (when message-reply-headers - (let ((message-id (mail-header-message-id message-reply-headers)) + (let ((message-id (mail-header-id message-reply-headers)) (references (mail-header-references message-reply-headers))) (if (or references message-id) (concat (or references "") (and references " ") @@ -5482,7 +5496,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (when message-reply-headers (let ((from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers)) - (msg-id (mail-header-message-id message-reply-headers))) + (msg-id (mail-header-id message-reply-headers))) (when from (let ((name (mail-extract-address-components from))) (concat @@ -5738,7 +5752,9 @@ subscribed address (and not the additional To and Cc header contents)." (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) "")) (mapcar 'downcase (mapcar - 'cadr + (lambda (elem) + (or (cadr elem) + "")) (mail-extract-address-components field t)))))) ;; Note that `rhs' will be "" if the address does not have ;; the domain part, i.e., if it is a local user's address. @@ -5936,7 +5952,7 @@ Headers already prepared in the buffer are not modified." ;; Check for IDNA (message-idna-to-ascii-rhs)))) -(defun message-insert-courtesy-copy () +(defun message-insert-courtesy-copy (message) "Insert a courtesy message in mail copies of combined messages." (let (newsgroups) (save-excursion @@ -5946,12 +5962,12 @@ Headers already prepared in the buffer are not modified." (goto-char (point-max)) (insert "Posted-To: " newsgroups "\n"))) (forward-line 1) - (when message-courtesy-message + (when message (cond - ((string-match "%s" message-courtesy-message) - (insert (format message-courtesy-message newsgroups))) + ((string-match "%s" message) + (insert (format message newsgroups))) (t - (insert message-courtesy-message))))))) + (insert message))))))) ;;; ;;; Setting up a message buffer @@ -6051,6 +6067,7 @@ If the current line has `message-yank-prefix', insert it on the new line." When sending via news, also check that the REFERENCES are less than 988 characters long, and if they are not, trim them until they are." + ;; 21 is the number suggested by USEAGE. (let ((maxcount 21) (count 0) (cut 2) @@ -6287,11 +6304,11 @@ between beginning of field and beginning of line." ;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the ;; form (FUNCTION . ARGS). (defun message-setup (headers &optional yank-action actions - continue switch-function) + continue switch-function return-action) (let ((mua (message-mail-user-agent)) subject to field) (if (not (and message-this-is-mail mua)) - (message-setup-1 headers yank-action actions) + (message-setup-1 headers yank-action actions return-action) (setq headers (copy-sequence headers)) (setq field (assq 'Subject headers)) (when field @@ -6339,11 +6356,12 @@ are not included." (push header result))) (nreverse result))) -(defun message-setup-1 (headers &optional yank-action actions) +(defun message-setup-1 (headers &optional yank-action actions return-action) (dolist (action actions) (condition-case nil (add-to-list 'message-send-actions `(apply ',(car action) ',(cdr action))))) + (setq message-return-action return-action) (setq message-reply-buffer (if (and (consp yank-action) (eq (car yank-action) 'insert-buffer)) @@ -6362,7 +6380,10 @@ are not included." headers) (delete-region (point) (progn (forward-line -1) (point))) (when message-default-headers - (insert message-default-headers) + (insert + (if (functionp message-default-headers) + (funcall message-default-headers) + message-default-headers)) (or (bolp) (insert ?\n))) (insert mail-header-separator "\n") (forward-line -1) @@ -6430,9 +6451,7 @@ are not included." (setq buffer-file-name (expand-file-name (concat (if (memq system-type - '(ms-dos ms-windows windows-nt - cygwin cygwin32 win32 w32 - mswindows)) + '(ms-dos windows-nt cygwin)) "message" "*message*") (format-time-string "-%Y%m%d-%H%M%S")) @@ -6471,9 +6490,9 @@ are not included." ;;; ;;;###autoload -(defun message-mail (&optional to subject - other-headers continue switch-function - yank-action send-actions) +(defun message-mail (&optional to subject other-headers continue + switch-function yank-action send-actions + return-action &rest ignored) "Start editing a mail message to be sent. OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether to continue editing a message already being composed. SWITCH-FUNCTION @@ -6494,7 +6513,8 @@ is a function used to switch to and display the mail buffer." (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - yank-action send-actions continue switch-function) + yank-action send-actions continue switch-function + return-action) ;; FIXME: Should return nil if failure. t)) @@ -6532,7 +6552,7 @@ The function is called with one parameter, a cons cell ..." (defun message-get-reply-headers (wide &optional to-address address-headers) (let (follow-to mct never-mct to cc author mft recipients extra) - ;; Find all relevant headers we need. + ;; Find all relevant headers we need. (save-restriction (message-narrow-to-headers-or-head) ;; Gmane renames "To". Look at "Original-To", too, if it is present in @@ -6569,6 +6589,10 @@ The function is called with one parameter, a cons cell ..." (save-match-data ;; Build (textual) list of new recipient addresses. (cond + (to-address + (setq recipients (concat ", " to-address)) + ;; If the author explicitly asked for a copy, we don't deny it to them. + (if mct (setq recipients (concat recipients ", " mct)))) ((not wide) (setq recipients (concat ", " author))) (address-headers @@ -6604,10 +6628,6 @@ responses here are directed to other addresses. You may customize the variable `message-use-mail-followup-to', if you want to get rid of this query permanently."))) (setq recipients (concat ", " mft))) - (to-address - (setq recipients (concat ", " to-address)) - ;; If the author explicitly asked for a copy, we don't deny it to them. - (if mct (setq recipients (concat recipients ", " mct)))) (t (setq recipients (if never-mct "" (concat ", " author))) (if to (setq recipients (concat recipients ", " to))) @@ -6658,6 +6678,8 @@ want to get rid of this query permanently."))) (if recip (setq recipients (delq recip recipients)))))))) + (setq recipients (message-prune-recipients recipients)) + ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. (setq follow-to (list (cons 'To (cdr (pop recipients))))) @@ -6671,6 +6693,22 @@ want to get rid of this query permanently."))) (push (cons 'Cc recipients) follow-to))) follow-to)) +(defun message-prune-recipients (recipients) + (dolist (rule message-prune-recipient-rules) + (let ((match (car rule)) + dup-match + address) + (dolist (recipient recipients) + (setq address (car recipient)) + (when (string-match match address) + (setq dup-match (replace-match (cadr rule) nil nil address)) + (dolist (recipient recipients) + ;; Don't delete the address that triggered this. + (when (and (not (eq address (car recipient))) + (string-match dup-match (car recipient))) + (setq recipients (delq recipient recipients)))))))) + recipients) + (defcustom message-simplify-subject-functions '(message-strip-list-identifiers message-strip-subject-re @@ -7142,22 +7180,28 @@ Optional DIGEST will use digest to forward." (defun message-forward-make-body-plain (forward-buffer) (insert "\n-------------------- Start of forwarded message --------------------\n") - (let ((b (point)) e) - (insert - (with-temp-buffer - (mm-disable-multibyte) - (insert - (with-current-buffer forward-buffer - (mm-with-unibyte-current-buffer (buffer-string)))) - (mm-enable-multibyte) - (mime-to-mml) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (buffer-string))) + (let ((b (point)) + (contents (with-current-buffer forward-buffer (buffer-string))) + e) + (unless (featurep 'xemacs) + (unless (mm-multibyte-string-p contents) + (error "Attempt to insert unibyte string from the buffer \"%s\"\ + to the multibyte buffer \"%s\"" + (if (bufferp forward-buffer) + (buffer-name forward-buffer) + forward-buffer) + (buffer-name)))) + (insert (mm-with-multibyte-buffer + (insert contents) + (mime-to-mml) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (buffer-string))) + (unless (bolp) (insert "\n")) (setq e (point)) (insert - "\n-------------------- End of forwarded message --------------------\n") + "-------------------- End of forwarded message --------------------\n") (message-remove-ignored-headers b e))) (defun message-remove-ignored-headers (b e) @@ -7193,18 +7237,22 @@ Optional DIGEST will use digest to forward." (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") (let ((b (point)) e) (if (not message-forward-decoded-p) - (insert - (with-temp-buffer - (mm-disable-multibyte) - (insert - (with-current-buffer forward-buffer - (mm-with-unibyte-current-buffer (buffer-string)))) - (mm-enable-multibyte) - (mime-to-mml) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (buffer-string))) + (let ((contents (with-current-buffer forward-buffer (buffer-string)))) + (unless (featurep 'xemacs) + (unless (mm-multibyte-string-p contents) + (error "Attempt to insert unibyte string from the buffer \"%s\"\ + to the multibyte buffer \"%s\"" + (if (bufferp forward-buffer) + (buffer-name forward-buffer) + forward-buffer) + (buffer-name)))) + (insert (mm-with-multibyte-buffer + (insert contents) + (mime-to-mml) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (buffer-string)))) (save-restriction (narrow-to-region (point) (point)) (mml-insert-buffer forward-buffer) @@ -7395,7 +7443,12 @@ is for the internal use." (when (looking-at "From ") (replace-match "X-From-Line: ")) ;; Send it. - (let ((message-inhibit-body-encoding t) + (let ((message-inhibit-body-encoding + ;; Don't do any further encoding if it looks like the + ;; message has already been encoded. + (let ((case-fold-search t)) + (re-search-forward "^mime-version:" nil t))) + (message-inhibit-ecomplete t) message-required-mail-headers message-generate-hashcash rfc2047-encode-encoded-words) @@ -7591,24 +7644,22 @@ Pre-defined symbols include `message-tool-bar-gnome' and (defcustom message-tool-bar-gnome '((ispell-message "spell" nil + :vert-only t :visible (or (not (boundp 'flyspell-mode)) (not flyspell-mode))) (flyspell-buffer "spell" t + :vert-only t :visible (and (boundp 'flyspell-mode) flyspell-mode) :help "Flyspell whole buffer") - (gmm-ignore "separator") - (message-send-and-exit "mail/send") + (message-send-and-exit "mail/send" t :label "Send") (message-dont-send "mail/save-draft") - (message-kill-buffer "close") ;; stock_cancel - (mml-attach-file "attach" mml-mode-map) + (mml-attach-file "attach" mml-mode-map :vert-only t) (mml-preview "mail/preview" mml-mode-map) (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) (message-insert-importance-high "important" nil :visible nil) (message-insert-importance-low "unimportant" nil :visible nil) - (message-insert-disposition-notification-to "receipt" nil :visible nil) - (gmm-customize-mode "preferences" t :help "Edit mode preferences") - (message-info "help" t :help "Message manual")) + (message-insert-disposition-notification-to "receipt" nil :visible nil)) "List of items for the message tool bar (GNOME style). See `gmm-tool-bar-from-list' for details on the format of the list." @@ -7694,7 +7745,7 @@ When FORCE, rebuild the tool bar." :type '(alist :key-type regexp :value-type function)) (defcustom message-expand-name-databases - (list 'bbdb 'eudc) + '(bbdb eudc) "List of databases to try for name completion (`message-expand-name'). Each element is a symbol and can be `bbdb' or `eudc'." :group 'message @@ -7716,15 +7767,25 @@ If nil, the function bound in `text-mode-map' or `global-map' is executed." Execute function specified by `message-tab-body-function' when not in those headers." (interactive) + (cond + ((if (and (boundp 'completion-fail-discreetly) + (fboundp 'completion-at-point)) + (let ((completion-fail-discreetly t)) (completion-at-point)) + (funcall (or (message-completion-function) #'ignore))) + ;; Completion was performed; nothing else to do. + nil) + (message-tab-body-function (funcall message-tab-body-function)) + (t (funcall (or (lookup-key text-mode-map "\t") + (lookup-key global-map "\t") + 'indent-relative))))) + +(defun message-completion-function () (let ((alist message-completion-alist)) (while (and alist (let ((mail-abbrev-mode-regexp (caar alist))) (not (mail-abbrev-in-expansion-header-p)))) (setq alist (cdr alist))) - (funcall (or (cdar alist) message-tab-body-function - (lookup-key text-mode-map "\t") - (lookup-key global-map "\t") - 'indent-relative)))) + (cdar alist))) (eval-and-compile (condition-case nil @@ -8008,7 +8069,11 @@ From headers in the original article." (not result) result))) +(declare-function ecomplete-add-item "ecomplete" (type key text)) +(declare-function ecomplete-save "ecomplete" ()) + (defun message-put-addresses-in-ecomplete () + (require 'ecomplete) (dolist (header '("to" "cc" "from" "reply-to")) (let ((value (message-field-value header))) (dolist (string (mail-header-parse-addresses value 'raw)) @@ -8019,6 +8084,8 @@ From headers in the original article." string)))) (ecomplete-save)) +(autoload 'ecomplete-display-matches "ecomplete") + (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) @@ -8195,5 +8262,4 @@ Used in `message-simplify-recipients'." ;; coding: iso-8859-1 ;; End: -;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0 ;;; message.el ends here diff --git a/lisp/gnus/messcompat.el b/lisp/gnus/messcompat.el index a3ae50d96b..e4dd65aa47 100644 --- a/lisp/gnus/messcompat.el +++ b/lisp/gnus/messcompat.el @@ -89,5 +89,4 @@ variable `mail-header-separator'.") (provide 'messcompat) -;; arch-tag: a76673be-905e-4bbd-8966-615370494a7b ;;; messcompat.el ends here diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index f4fff57fcc..30f04097a5 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -24,7 +24,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -302,5 +302,4 @@ decoding. If it is nil, default to `mail-parse-charset'." (provide 'mm-bodies) -;; arch-tag: 41104bb6-4443-4ca9-8d5c-ff87ecf27d8d ;;; mm-bodies.el ends here diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 4775abe364..5a3972e919 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -24,17 +24,19 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'mail-parse) -(require 'mailcap) (require 'mm-bodies) -(require 'gnus-util) (eval-when-compile (require 'cl) (require 'term)) +(autoload 'gnus-map-function "gnus-util") +(autoload 'gnus-replace-in-string "gnus-util") +(autoload 'gnus-read-shell-command "gnus-util") + (autoload 'mm-inline-partial "mm-partial") (autoload 'mm-inline-external-body "mm-extern") (autoload 'mm-extern-cache-contents "mm-extern") @@ -103,10 +105,8 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((executable-find "w3m") - (if (locate-library "w3m") - 'w3m - 'w3m-standalone)) + (cond ((fboundp 'libxml-parse-html-region) 'shr) + ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) ((locate-library "w3") 'w3) @@ -115,6 +115,8 @@ "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: +`shr': use Gnus simple HTML renderer; +`gnus-w3m' : use Gnus renderer based on w3m; `w3m' : use emacs-w3m; `w3m-standalone': use w3m; `links': use links; @@ -122,9 +124,11 @@ The defined renderer types are: `w3' : use Emacs/W3; `html2text' : use html2text; nil : use external viewer (default web browser)." - :version "23.0" ;; No Gnus - :type '(choice (const w3) - (const w3m :tag "emacs-w3m") + :version "24.1" + :type '(choice (const shr) + (const gnus-w3m) + (const w3) + (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) (const links) (const lynx) @@ -133,10 +137,6 @@ nil : use external viewer (default web browser)." (function)) :group 'mime-display) -(defvar mm-inline-text-html-renderer nil - "Function used for rendering inline HTML contents. -It is suggested to customize `mm-text-html-renderer' instead.") - (defcustom mm-inline-text-html-with-images nil "If non-nil, Gnus will allow retrieving images in HTML contents with the <img> tags. It has no effect on Emacs/w3. See also the @@ -241,8 +241,7 @@ before the external MIME handler is invoked." ("text/html" mm-inline-text-html (lambda (handle) - (or mm-inline-text-html-renderer - mm-text-html-renderer))) + mm-text-html-renderer)) ("text/x-vcard" mm-inline-text-vcard (lambda (handle) @@ -367,8 +366,12 @@ enables you to choose manually one of two types those mails include." :group 'mime-display) (defcustom mm-inline-large-images nil - "If non-nil, then all images fit in the buffer." - :type 'boolean + "If t, then all images fit in the buffer. +If 'resize, try to resize the images so they fit." + :type '(radio + (const :tag "Inline large images as they are." t) + (const :tag "Resize large images." resize) + (const :tag "Do not inline large images." nil)) :group 'mime-display) (defcustom mm-file-name-rewrite-functions @@ -550,6 +553,8 @@ Postpone undisplaying of viewers for types in (message "Destroying external MIME viewers") (mm-destroy-parts mm-postponed-undisplay-list))) +(autoload 'message-fetch-field "message") + (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from) "Dissect the current buffer and return a list of MIME handles." (save-excursion @@ -619,7 +624,7 @@ Postpone undisplaying of viewers for types in no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description id) - ctl)))) + ctl from)))) (when id (when (string-match " *<\\(.*\\)> *" id) (setq id (match-string 1 id))) @@ -661,7 +666,7 @@ Postpone undisplaying of viewers for types in (save-restriction (narrow-to-region start end) (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts))))) - (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) + (mm-possibly-verify-or-decrypt (nreverse parts) ctl from))) (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." @@ -688,13 +693,17 @@ Postpone undisplaying of viewers for types in (goto-char (point-max))) (mapcar 'mm-display-parts handle)))) -(defun mm-display-part (handle &optional no-default) +(autoload 'mailcap-parse-mailcaps "mailcap") +(autoload 'mailcap-mime-info "mailcap") + +(defun mm-display-part (handle &optional no-default force) "Display the MIME part represented by HANDLE. Returns nil if the part is removed; inline if displayed inline; external if displayed external." (save-excursion (mailcap-parse-mailcaps) - (if (mm-handle-displayed-p handle) + (if (and (not force) + (mm-handle-displayed-p handle)) (mm-remove-part handle) (let* ((ehandle (if (equal (mm-handle-media-type handle) "message/external-body") @@ -747,6 +756,7 @@ external if displayed external." handle 'mailcap-save-binary-file))))))))) (declare-function gnus-configure-windows "gnus-win" (setting &optional force)) +(defvar mailcap-mime-extensions) ; mailcap-mime-info autoloads (defun mm-display-external (handle method) "Display HANDLE using METHOD." @@ -1140,13 +1150,15 @@ in HANDLE." ;; time to adjust it, since we know at this point that it should ;; be unibyte. `(let* ((handle ,handle)) - (with-temp-buffer - (mm-disable-multibyte) - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - ,@forms))) + (when (and (mm-handle-buffer handle) + (buffer-name (mm-handle-buffer handle))) + (with-temp-buffer + (mm-disable-multibyte) + (insert-buffer-substring (mm-handle-buffer handle)) + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + ,@forms)))) (put 'mm-with-part 'lisp-indent-function 1) (put 'mm-with-part 'edebug-form-spec '(body)) @@ -1239,9 +1251,17 @@ PROMPT overrides the default one used to ask user for a file name." (setq filename (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory filename)))) (setq file - (read-file-name (or prompt "Save MIME part to: ") - (or mm-default-directory default-directory) - nil nil (or filename ""))) + (read-file-name + (or prompt + (format "Save MIME part to (default %s): " + (or filename ""))) + (or mm-default-directory default-directory) + (expand-file-name (or filename "") + (or mm-default-directory default-directory)))) + (if (file-directory-p file) + (setq file (expand-file-name filename file)) + (setq file (expand-file-name + file (or mm-default-directory default-directory)))) (setq mm-default-directory (file-name-directory file)) (and (or (not (file-exists-p file)) (yes-or-no-p (format "File %s already exists; overwrite? " @@ -1250,11 +1270,11 @@ PROMPT overrides the default one used to ask user for a file name." (mm-save-part-to-file handle file) file)))) -(defun mm-add-meta-html-tag (handle &optional charset) +(defun mm-add-meta-html-tag (handle &optional charset force-charset) "Add meta html tag to specify CHARSET of HANDLE in the current buffer. CHARSET defaults to the one HANDLE specifies. Existing meta tag that -specifies charset will not be modified. Return t if meta tag is added -or replaced." +specifies charset will not be modified unless FORCE-CHARSET is non-nil. +Return t if meta tag is added or replaced." (when (equal (mm-handle-media-type handle) "text/html") (when (or charset (setq charset (mail-content-type-get (mm-handle-type handle) @@ -1266,7 +1286,8 @@ or replaced." (if (re-search-forward "\ <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t) - (if (and (match-beginning 2) + (if (and (not force-charset) + (match-beginning 2) (string-match "\\`html\\'" (match-string 1))) ;; Don't modify existing meta tag. nil @@ -1292,27 +1313,30 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t) (mm-write-region (point-min) (point-max) file nil nil nil 'binary t) (set-default-file-modes current-file-modes))))) -(defun mm-pipe-part (handle) - "Pipe HANDLE to a process." - (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command - (gnus-read-shell-command - "Shell command on MIME part: " mm-last-shell-command))) +(defun mm-pipe-part (handle &optional cmd) + "Pipe HANDLE to a process. +Use CMD as the process." + (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) + (command (or cmd + (gnus-read-shell-command + "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer (mm-insert-part handle) (mm-add-meta-html-tag handle) (let ((coding-system-for-write 'binary)) (shell-command-on-region (point-min) (point-max) command nil))))) +(autoload 'gnus-completing-read "gnus-util") + (defun mm-interactively-view-part (handle) "Display HANDLE using METHOD." (let* ((type (mm-handle-media-type handle)) (methods - (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) + (mapcar (lambda (i) (cdr (assoc 'viewer i))) (mailcap-mime-info type 'all))) (method (let ((minibuffer-local-completion-map mm-viewer-completion-map)) - (completing-read "Viewer: " methods)))) + (gnus-completing-read "Viewer" methods)))) (when (string= method "") (error "No method given")) (if (string-match "^[^% \t]+$" method) @@ -1343,13 +1367,18 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t) (defun mm-preferred-alternative-precedence (handles) "Return the precedence based on HANDLES and `mm-discouraged-alternatives'." - (let ((seq (nreverse (mapcar #'mm-handle-media-type - handles)))) - (dolist (disc (reverse mm-discouraged-alternatives)) - (dolist (elem (copy-sequence seq)) - (when (string-match disc elem) - (setq seq (nconc (delete elem seq) (list elem)))))) - seq)) + (setq handles (reverse handles)) + (dolist (disc (reverse mm-discouraged-alternatives)) + (dolist (handle (copy-sequence handles)) + (when (string-match disc (mm-handle-media-type handle)) + (setq handles (nconc (delete handle handles) (list handle)))))) + ;; Remove empty parts. + (dolist (handle (copy-sequence handles)) + (unless (with-current-buffer (mm-handle-buffer handle) + (goto-char (point-min)) + (re-search-forward "[^ \t\n]" nil t)) + (setq handles (nconc (delete handle handles) (list handle))))) + (mapcar #'mm-handle-media-type handles)) (defun mm-get-content-id (id) "Return the handle(s) referred to by ID." @@ -1464,7 +1493,7 @@ be determined." ;; Handle XEmacs ((fboundp 'valid-image-instantiator-format-p) (valid-image-instantiator-format-p format)) - ;; Handle Emacs 21 + ;; Handle Emacs ((fboundp 'image-type-available-p) (and (display-graphic-p) (image-type-available-p format))) @@ -1545,7 +1574,7 @@ If RECURSIVE, search recursively." (autoload 'mm-view-pkcs7 "mm-view") -(defun mm-possibly-verify-or-decrypt (parts ctl) +(defun mm-possibly-verify-or-decrypt (parts ctl &optional from) (let ((type (car ctl)) (subtype (cadr (split-string (car ctl) "/"))) (mm-security-handle ctl) ;; (car CTL) is the type. @@ -1560,7 +1589,7 @@ If RECURSIVE, search recursively." ((eq mm-decrypt-option 'known) t) (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) - (mm-view-pkcs7 parts)) + (mm-view-pkcs7 parts from)) (setq parts (mm-dissect-buffer t))))) ((equal subtype "signed") (unless (and (setq protocol @@ -1659,7 +1688,64 @@ If RECURSIVE, search recursively." (and (eq (mm-body-7-or-8) '7bit) (not (mm-long-lines-p 76)))))) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) +(declare-function shr-insert-document "shr" (dom)) +(defvar shr-blocked-images) +(defvar gnus-inhibit-images) +(autoload 'gnus-blocked-images "gnus-art") + +(defun mm-shr (handle) + ;; Require since we bind its variables. + (require 'shr) + (let ((article-buffer (current-buffer)) + (shr-content-function (lambda (id) + (let ((handle (mm-get-content-id id))) + (when handle + (mm-with-part handle + (buffer-string)))))) + shr-inhibit-images shr-blocked-images charset char) + (if (and (boundp 'gnus-summary-buffer) + (buffer-name gnus-summary-buffer)) + (with-current-buffer gnus-summary-buffer + (setq shr-inhibit-images gnus-inhibit-images + shr-blocked-images (gnus-blocked-images))) + (setq shr-inhibit-images gnus-inhibit-images + shr-blocked-images (gnus-blocked-images))) + (unless handle + (setq handle (mm-dissect-buffer t))) + (setq charset (mail-content-type-get (mm-handle-type handle) 'charset)) + (save-restriction + (narrow-to-region (point) (point)) + (shr-insert-document + (mm-with-part handle + (insert (prog1 + (if (and charset + (setq charset + (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii))) + (mm-decode-coding-string (buffer-string) charset) + (mm-string-as-multibyte (buffer-string))) + (erase-buffer) + (mm-enable-multibyte))) + (goto-char (point-min)) + (setq case-fold-search t) + (while (re-search-forward + "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t) + (when (setq char + (cdr (assq (if (match-beginning 1) + (string-to-number (match-string 1) 16) + (string-to-number (match-string 2))) + mm-extra-numeric-entities))) + (replace-match (char-to-string char)))) + (libxml-parse-html-region (point-min) (point-max)))) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t)) + (delete-region ,(point-min-marker) + ,(point-max-marker)))))))) + (provide 'mm-decode) -;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b ;;; mm-decode.el ends here diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el index 2c8e1e3a0a..dee7c6aba6 100644 --- a/lisp/gnus/mm-encode.el +++ b/lisp/gnus/mm-encode.el @@ -26,7 +26,7 @@ (eval-when-compile (require 'cl)) (require 'mail-parse) -(require 'mailcap) +(autoload 'mailcap-extension-to-mime "mailcap") (autoload 'mm-body-7-or-8 "mm-bodies") (autoload 'mm-long-lines-p "mm-bodies") @@ -42,15 +42,8 @@ If the encoding is `qp-or-base64', then either quoted-printable or base64 will be used, depending on what is more efficient. -`qp-or-base64' has another effect. It will fold long lines so that -MIME parts may not be broken by MTA. So do `quoted-printable' and -`base64'. - -Note: It affects body encoding only when a part is a raw forwarded -message (which will be made by `gnus-summary-mail-forward' with the -arg 2 for example) or is neither the text/* type nor the message/* -type. Even though in those cases, you can use the `encoding' MML tag -to specify encoding of non-ASCII MIME parts." +This list is only consulted when encoding MIME parts in the +bodies -- not for the regular non-MIME-ish messages." :type '(repeat (list (regexp :tag "MIME type") (choice :tag "encoding" (const 7bit) @@ -223,5 +216,4 @@ This is either `base64' or `quoted-printable'." (provide 'mm-encode) -;; arch-tag: 7d01bba4-d469-4851-952b-dc863f84ed66 ;;; mm-encode.el ends here diff --git a/lisp/gnus/mm-extern.el b/lisp/gnus/mm-extern.el index 3912a90806..d1b346745a 100644 --- a/lisp/gnus/mm-extern.el +++ b/lisp/gnus/mm-extern.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -67,9 +67,8 @@ (coding-system-for-read mm-binary-coding-system)) (unless url (error "URL is not specified")) - (mm-with-unibyte-current-buffer - (mm-url-insert-file-contents url)) (mm-disable-multibyte) + (mm-url-insert-file-contents url) (setq buffer-file-name name))) (defun mm-extern-anon-ftp (handle) @@ -92,7 +91,7 @@ (let (mm-extern-anonymous) (mm-extern-anon-ftp handle))) -(declare-function message-goto-body "message" (&optional interactivep)) +(declare-function message-goto-body "message" ()) (defun mm-extern-mail-server (handle) (require 'message) @@ -125,7 +124,7 @@ (or access-type (error "Couldn't find access type")))) mm-extern-function-alist))) - buf handles) + handles) (unless func (error "Access type (%s) is not supported" access-type)) (mm-with-part handle @@ -136,8 +135,7 @@ (unless (bufferp (car handles)) (mm-destroy-parts handles) (error "Multipart external body is not supported")) - (save-excursion - (set-buffer (setq buf (mm-handle-buffer handles))) + (with-current-buffer (mm-handle-buffer handles) (let (good) (unwind-protect (progn @@ -169,5 +167,4 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (provide 'mm-extern) -;; arch-tag: 9653808e-14d9-4172-86e6-adceaa05378e ;;; mm-extern.el ends here diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el index 148f7059d2..019b82f059 100644 --- a/lisp/gnus/mm-partial.el +++ b/lisp/gnus/mm-partial.el @@ -70,8 +70,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (sort (cons handle (mm-partial-find-parts id - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-article-number)))) #'(lambda (a b) (let ((anumber (string-to-number @@ -83,8 +82,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (< anumber bnumber))))) (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles phandles)) - (save-excursion - (set-buffer (generate-new-buffer " *mm*")) + (with-current-buffer (generate-new-buffer " *mm*") (while (setq phandle (pop phandles)) (setq nn (string-to-number (cdr (assq 'number @@ -150,5 +148,4 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (provide 'mm-partial) -;; arch-tag: 460e7424-05f2-4a1d-a0f2-70ec081eff7d ;;; mm-partial.el ends here diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index c62d56494a..80113fec7c 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -365,15 +365,23 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META." (defun mm-url-decode-entities () "Decode all HTML entities." (goto-char (point-min)) - (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+[0-9]*\\);" nil t) - (let ((elem (if (eq (aref (match-string 1) 0) ?\#) - (let ((c (mm-ucs-to-char - (string-to-number - (substring (match-string 1) 1))))) - (if (mm-char-or-char-int-p c) c ?#)) - (or (cdr (assq (intern (match-string 1)) - mm-url-html-entities)) - ?#)))) + (while (re-search-forward "&\\(#[0-9]+\\|#x[0-9a-f]+\\|[a-z]+[0-9]*\\);" + nil t) + (let* ((entity (match-string 1)) + (elem (if (eq (aref entity 0) ?\#) + (let ((c + ;; Hex number: ㈒ + (if (eq (aref entity 1) ?x) + (string-to-number (substring entity 2) + 16) + ;; Decimal number:  + (string-to-number (substring entity 1))))) + (setq c (or (cdr (assq c mm-extra-numeric-entities)) + (mm-ucs-to-char c))) + (if (mm-char-or-char-int-p c) c ?#)) + (or (cdr (assq (intern entity) + mm-url-html-entities)) + ?#)))) (unless (stringp elem) (setq elem (char-to-string elem))) (replace-match elem t t)))) @@ -404,14 +412,10 @@ spaces. Die Die Die." ((= char ? ) "+") ((memq char mm-url-unreserved-chars) (char-to-string char)) (t (upcase (format "%%%02x" char))))) - ;; Fixme: Should this actually be accepting multibyte? Is there a - ;; better way in XEmacs? - (if (featurep 'mule) - (encode-coding-string chunk - (if (fboundp 'find-coding-systems-string) - (car (find-coding-systems-string chunk)) - buffer-file-coding-system)) - chunk) + (mm-encode-coding-string chunk + (if (fboundp 'find-coding-systems-string) + (car (find-coding-systems-string chunk)) + buffer-file-coding-system)) "")) (defun mm-url-encode-www-form-urlencoded (pairs) @@ -422,6 +426,50 @@ spaces. Die Die Die." (mm-url-form-encode-xwfu (cdr data)))) pairs "&")) +(autoload 'mml-compute-boundary "mml") + +(defun mm-url-encode-multipart-form-data (pairs &optional boundary) + "Return PAIRS encoded in multipart/form-data." + ;; RFC1867 + + ;; Get a good boundary + (unless boundary + (setq boundary (mml-compute-boundary '()))) + + (concat + + ;; Start with the boundary + "--" boundary "\r\n" + + ;; Create name value pairs + (mapconcat + 'identity + ;; Delete any returned items that are empty + (delq nil + (mapcar (lambda (data) + (when (car data) + ;; For each pair + (concat + + ;; Encode the name + "Content-Disposition: form-data; name=\"" + (car data) "\"\r\n" + "Content-Type: text/plain; charset=utf-8\r\n" + "Content-Transfer-Encoding: binary\r\n\r\n" + + (cond ((stringp (cdr data)) + (cdr data)) + ((integerp (cdr data)) + (int-to-string (cdr data)))) + + "\r\n"))) + pairs)) + ;; use the boundary as a separator + (concat "--" boundary "\r\n")) + + ;; put a boundary at the end. + "--" boundary "--\r\n")) + (defun mm-url-fetch-form (url pairs) "Fetch a form from URL with PAIRS as the data using the POST method." (mm-url-load-url) @@ -456,5 +504,4 @@ spaces. Die Die Die." (provide 'mm-url) -;; arch-tag: 0594f9b3-417c-48b0-adc2-5082e1e7917f ;;; mm-url.el ends here diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 0f02d3cebb..99766e6446 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -24,7 +24,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -39,6 +39,10 @@ (require 'timer))) (defvar mm-mime-mule-charset-alist ) +;; Note this is not presently used on Emacs >= 23, which is good, +;; since it means standalone message-mode (which requires mml and +;; hence mml-util) does not load gnus-util. +(autoload 'gnus-completing-read "gnus-util") ;; Emulate functions that are not available in every (X)Emacs version. ;; The name of a function is prefixed with mm-, like `mm-char-int' for @@ -68,11 +72,11 @@ . ,(lambda (prompt) "Return a charset." (intern - (completing-read + (gnus-completing-read prompt - (mapcar (lambda (e) (list (symbol-name (car e)))) + (mapcar (lambda (e) (symbol-name (car e))) mm-mime-mule-charset-alist) - nil t)))) + t)))) ;; `subst-char-in-string' is not available in XEmacs 21.4. (subst-char-in-string . ,(lambda (from to string &optional inplace) @@ -202,19 +206,10 @@ to the contents of the accessible portion of the buffer." (defalias 'mm-decode-coding-region 'decode-coding-region) (defalias 'mm-encode-coding-region 'encode-coding-region))) -;; `string-to-multibyte' is available only in Emacs 22.1 or greater. -(defalias 'mm-string-to-multibyte - (cond - ((featurep 'xemacs) - 'identity) - ((fboundp 'string-to-multibyte) - 'string-to-multibyte) - (t - (lambda (string) - "Return a multibyte string with the same individual chars as STRING." - (mapconcat - (lambda (ch) (mm-string-as-multibyte (char-to-string ch))) - string ""))))) +;; `string-to-multibyte' is available only in Emacs. +(defalias 'mm-string-to-multibyte (if (featurep 'xemacs) + 'identity + 'string-to-multibyte)) ;; `char-or-char-int-p' is an XEmacs function, not available in Emacs. (eval-and-compile @@ -225,42 +220,43 @@ to the contents of the accessible portion of the buffer." (t 'identity)))) ;; `ucs-to-char' is a function that Mule-UCS provides. -(if (featurep 'xemacs) - (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5. - (subrp (symbol-function 'unicode-to-char))) - (if (featurep 'mule) - (defalias 'mm-ucs-to-char 'unicode-to-char) +(eval-and-compile + (if (featurep 'xemacs) + (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5. + (subrp (symbol-function 'unicode-to-char))) + (if (featurep 'mule) + (defalias 'mm-ucs-to-char 'unicode-to-char) + (defun mm-ucs-to-char (codepoint) + "Convert Unicode codepoint to character." + (or (unicode-to-char codepoint) ?#)))) + ((featurep 'mule) + (defun mm-ucs-to-char (codepoint) + "Convert Unicode codepoint to character." + (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded. + (progn + (defalias 'mm-ucs-to-char + (lambda (codepoint) + "Convert Unicode codepoint to character." + (condition-case nil + (or (ucs-to-char codepoint) ?#) + (error ?#)))) + (mm-ucs-to-char codepoint)) + (condition-case nil + (or (int-to-char codepoint) ?#) + (error ?#))))) + (t (defun mm-ucs-to-char (codepoint) "Convert Unicode codepoint to character." - (or (unicode-to-char codepoint) ?#)))) - ((featurep 'mule) - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded. - (progn - (defalias 'mm-ucs-to-char - (lambda (codepoint) - "Convert Unicode codepoint to character." - (condition-case nil - (or (ucs-to-char codepoint) ?#) - (error ?#)))) - (mm-ucs-to-char codepoint)) (condition-case nil (or (int-to-char codepoint) ?#) (error ?#))))) - (t - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (condition-case nil - (or (int-to-char codepoint) ?#) - (error ?#))))) - (if (let ((char (make-char 'japanese-jisx0208 36 34))) - (eq char (decode-char 'ucs char))) - ;; Emacs 23. - (defalias 'mm-ucs-to-char 'identity) - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (or (decode-char 'ucs codepoint) ?#)))) + (if (let ((char (make-char 'japanese-jisx0208 36 34))) + (eq char (decode-char 'ucs char))) + ;; Emacs 23. + (defalias 'mm-ucs-to-char 'identity) + (defun mm-ucs-to-char (codepoint) + "Convert Unicode codepoint to character." + (or (decode-char 'ucs codepoint) ?#))))) ;; Fixme: This seems always to be used to read a MIME charset, so it ;; should be re-named and fixed (in Emacs) to offer completion only on @@ -272,18 +268,19 @@ to the contents of the accessible portion of the buffer." ;; Actually, there should be an `mm-coding-system-mime-charset'. (eval-and-compile (defalias 'mm-read-coding-system - (cond - ((fboundp 'read-coding-system) - (if (and (featurep 'xemacs) - (<= (string-to-number emacs-version) 21.1)) - (lambda (prompt &optional default-coding-system) - (read-coding-system prompt)) - 'read-coding-system)) - (t (lambda (prompt &optional default-coding-system) - "Prompt the user for a coding system." - (completing-read - prompt (mapcar (lambda (s) (list (symbol-name (car s)))) - mm-mime-mule-charset-alist))))))) + (if (featurep 'emacs) 'read-coding-system + (cond + ((fboundp 'read-coding-system) + (if (and (featurep 'xemacs) + (<= (string-to-number emacs-version) 21.1)) + (lambda (prompt &optional default-coding-system) + (read-coding-system prompt)) + 'read-coding-system)) + (t (lambda (prompt &optional default-coding-system) + "Prompt the user for a coding system." + (gnus-completing-read + prompt (mapcar (lambda (s) (symbol-name (car s))) + mm-mime-mule-charset-alist)))))))) (defvar mm-coding-system-list nil) (defun mm-get-coding-system-list () @@ -316,8 +313,8 @@ the alias. Else windows-NUMBER is used." (cp-supported-codepages) ;; Removed in Emacs 23 (unicode), so signal an error: (error "`codepage-setup' not present in this Emacs version")))) - (list (completing-read "Setup DOS Codepage: (default 437) " candidates - nil t nil nil "437")))) + (list (gnus-completing-read "Setup DOS Codepage" candidates + t nil nil "437")))) (when alias (setq alias (if (stringp alias) (intern alias) @@ -383,8 +380,7 @@ See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.") (defcustom mm-codepage-iso-8859-list (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft ;; Outlook users in Czech republic. Use this to allow reading of - ;; their e-mails. cp1250 should be defined by M-x codepage-setup - ;; (Emacs 21). + ;; their e-mails. '(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West ;; Europe). See also `gnus-article-dumbquotes-map'. '(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish). @@ -494,8 +490,8 @@ Unless LIST is given, `mm-codepage-ibm-list' is used." (defcustom mm-charset-eval-alist (if (featurep 'xemacs) nil ;; I don't know what would be useful for XEmacs. - '(;; Emacs 21 offers 1250 1251 1253 1257. Emacs 22 provides autoloads for - ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing). + '(;; Emacs 22 provides autoloads for 1250-1258 + ;; (i.e. `mm-codepage-setup' does nothing). (windows-1250 . (mm-codepage-setup 1250 t)) (windows-1251 . (mm-codepage-setup 1251 t)) (windows-1253 . (mm-codepage-setup 1253 t)) @@ -566,6 +562,9 @@ is not available." ;;; (eq charset (coding-system-get charset 'mime-charset)) ) charset) + ;; Use coding system Emacs knows. + ((and (fboundp 'coding-system-from-name) + (coding-system-from-name charset))) ;; Eval expressions from `mm-charset-eval-alist' ((let* ((el (assq charset mm-charset-eval-alist)) (cs (car el)) @@ -677,7 +676,7 @@ superset of iso-8859-1." "100% binary coding system.") (defvar mm-text-coding-system - (or (if (memq system-type '(windows-nt ms-dos ms-windows)) + (or (if (memq system-type '(windows-nt ms-dos)) (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos) (and (mm-coding-system-p 'raw-text) 'raw-text)) mm-binary-coding-system) @@ -689,12 +688,12 @@ superset of iso-8859-1." (defvar mm-auto-save-coding-system (cond ((mm-coding-system-p 'utf-8-emacs) ; Mule 7 - (if (memq system-type '(windows-nt ms-dos ms-windows)) + (if (memq system-type '(windows-nt ms-dos)) (if (mm-coding-system-p 'utf-8-emacs-dos) 'utf-8-emacs-dos mm-binary-coding-system) 'utf-8-emacs)) ((mm-coding-system-p 'emacs-mule) - (if (memq system-type '(windows-nt ms-dos ms-windows)) + (if (memq system-type '(windows-nt ms-dos)) (if (mm-coding-system-p 'emacs-mule-dos) 'emacs-mule-dos mm-binary-coding-system) 'emacs-mule)) @@ -868,6 +867,21 @@ variable is set, it overrides the default priority." Setting it to nil is useful on Emacsen supporting Unicode if sending mail with multiple parts is preferred to sending a Unicode one.") +(defvar mm-extra-numeric-entities + (mapcar + (lambda (item) + (cons (car item) (mm-ucs-to-char (cdr item)))) + '((#x80 . #x20AC) (#x82 . #x201A) (#x83 . #x0192) (#x84 . #x201E) + (#x85 . #x2026) (#x86 . #x2020) (#x87 . #x2021) (#x88 . #x02C6) + (#x89 . #x2030) (#x8A . #x0160) (#x8B . #x2039) (#x8C . #x0152) + (#x8E . #x017D) (#x91 . #x2018) (#x92 . #x2019) (#x93 . #x201C) + (#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014) + (#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A) + (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178))) + "*Alist of extra numeric entities and characters other than ISO 10646. +This table is used for decoding extra numeric entities to characters, +like \"€\" to the euro sign, mainly in html messages.") + ;;; Internal variables: ;;; Functions: @@ -899,26 +913,20 @@ mail with multiple parts is preferred to sending a Unicode one.") out))) (eval-and-compile - (defvar mm-emacs-mule (and (not (featurep 'xemacs)) - (boundp 'enable-multibyte-characters) - (default-value 'enable-multibyte-characters) - (fboundp 'set-buffer-multibyte)) - "True in Emacs with Mule.") - - (if mm-emacs-mule - (defun mm-enable-multibyte () - "Set the multibyte flag of the current buffer. + (if (featurep 'xemacs) + (defalias 'mm-enable-multibyte 'ignore) + (defun mm-enable-multibyte () + "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is non-nil. This is a no-op in XEmacs." - (set-buffer-multibyte 'to)) - (defalias 'mm-enable-multibyte 'ignore)) + (set-buffer-multibyte 'to))) - (if mm-emacs-mule - (defun mm-disable-multibyte () - "Unset the multibyte flag of in the current buffer. + (if (featurep 'xemacs) + (defalias 'mm-disable-multibyte 'ignore) + (defun mm-disable-multibyte () + "Unset the multibyte flag of in the current buffer. This is a no-op in XEmacs." - (set-buffer-multibyte nil)) - (defalias 'mm-disable-multibyte 'ignore))) + (set-buffer-multibyte nil)))) (defun mm-preferred-coding-system (charset) ;; A typo in some Emacs versions. @@ -969,7 +977,6 @@ If the charset is `composition', return the actual one." (if (eq charset 'unknown) (error "The message contains non-printable characters, please use attachment")) (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property)) - ;; This exists in Emacs 20. (or (and (mm-preferred-coding-system charset) (or (coding-system-get @@ -983,6 +990,7 @@ If the charset is `composition', return the actual one." ;; This is for XEmacs. (mm-mule-charset-to-mime-charset charset))) +;; `delete-dups' is not available in XEmacs 21.4. (if (fboundp 'delete-dups) (defalias 'mm-delete-duplicates 'delete-dups) (defun mm-delete-duplicates (list) @@ -1227,28 +1235,23 @@ Use multibyte mode for this." (defmacro mm-with-unibyte-current-buffer (&rest forms) "Evaluate FORMS with current buffer temporarily made unibyte. -Also bind the default-value of `enable-multibyte-characters' to nil. -Equivalent to `progn' in XEmacs - -NOTE: Use this macro with caution in multibyte buffers (it is not -worth using this macro in unibyte buffers of course). Use of -`(set-buffer-multibyte t)', which is run finally, is generally -harmful since it is likely to modify existing data in the buffer. -For instance, it converts \"\\300\\255\" into \"\\255\" in -Emacs 23 (unicode)." - (let ((multibyte (make-symbol "multibyte")) - (buffer (make-symbol "buffer"))) - `(if mm-emacs-mule - (let ((,multibyte enable-multibyte-characters) - (,buffer (current-buffer))) - (unwind-protect - (letf (((default-value 'enable-multibyte-characters) nil)) - (set-buffer-multibyte nil) - ,@forms) - (set-buffer ,buffer) - (set-buffer-multibyte ,multibyte))) - (letf (((default-value 'enable-multibyte-characters) nil)) - ,@forms)))) +Equivalent to `progn' in XEmacs. + +Note: We recommend not using this macro any more; there should be +better ways to do a similar thing. The previous version of this macro +bound the default value of `enable-multibyte-characters' to nil while +evaluating FORMS but it is no longer done. So, some programs assuming +it if any may malfunction." + (if (featurep 'xemacs) + `(progn ,@forms) + (let ((multibyte (make-symbol "multibyte"))) + `(let ((,multibyte enable-multibyte-characters)) + (when ,multibyte + (set-buffer-multibyte nil)) + (prog1 + (progn ,@forms) + (when ,multibyte + (set-buffer-multibyte t))))))) (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0) (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body)) @@ -1437,16 +1440,23 @@ If SUFFIX is non-nil, add that at the end of the file name." ;; Reset the umask. (set-default-file-modes umask))))) +(defvar mm-image-load-path-cache nil) + (defun mm-image-load-path (&optional package) - (let (dir result) - (dolist (path load-path (nreverse result)) - (when (and path - (file-directory-p - (setq dir (concat (file-name-directory - (directory-file-name path)) - "etc/images/" (or package "gnus/"))))) - (push dir result)) - (push path result)))) + (if (and mm-image-load-path-cache + (equal load-path (car mm-image-load-path-cache))) + (cdr mm-image-load-path-cache) + (let (dir result) + (dolist (path load-path) + (when (and path + (file-directory-p + (setq dir (concat (file-name-directory + (directory-file-name path)) + "etc/images/" (or package "gnus/"))))) + (push dir result))) + (setq result (nreverse result) + mm-image-load-path-cache (cons load-path result)) + result))) ;; Fixme: This doesn't look useful where it's used. (if (fboundp 'detect-coding-region) @@ -1540,14 +1550,13 @@ decompressed data. The buffer's multibyteness must be turned off." prog t (list t err-file) nil args) jka-compr-acceptable-retval-list) (erase-buffer) - (insert (mapconcat - 'identity - (delete "" (split-string - (prog2 - (insert-file-contents err-file) - (buffer-string) - (erase-buffer)))) - " ") + (insert (mapconcat 'identity + (split-string + (prog2 + (insert-file-contents err-file) + (buffer-string) + (erase-buffer)) t) + " ") "\n") (setq err-msg (format "Error while executing \"%s %s < %s\"" @@ -1557,7 +1566,7 @@ decompressed data. The buffer's multibyteness must be turned off." (error (setq err-msg (error-message-string err))))) (when (file-exists-p err-file) - (ignore-errors (jka-compr-delete-temp-file err-file))) + (ignore-errors (delete-file err-file))) (when inplace (unless err-msg (delete-region (point-min) (point-max)) @@ -1590,8 +1599,8 @@ gzip, bzip2, etc. are allowed." filename)) (mm-decompress-buffer filename nil t)))) (when decomp - (set-buffer (letf (((default-value 'enable-multibyte-characters) nil)) - (generate-new-buffer " *temp*"))) + (set-buffer (generate-new-buffer " *temp*")) + (mm-disable-multibyte) (insert decomp) (setq filename (file-name-sans-extension filename))) (goto-char (point-min)) @@ -1661,5 +1670,4 @@ gzip, bzip2, etc. are allowed." (provide 'mm-util) -;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238 ;;; mm-util.el ends here diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 7dbede08f6..432b23c202 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -165,7 +165,7 @@ This can be either \"inline\" or \"attachment\".") ;; dependency on `message.el'. "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" - (lambda () (mm-uu-verbatim-marks-extract -1 0 1 -1)) + (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) nil) ;; Omitting [a-z8<] leads to false positives (bogus signature separators ;; and mailing list banners). @@ -441,7 +441,7 @@ apply the face `mm-uu-extract'." (defun mm-uu-yenc-extract () ;; This might not be exactly correct, but we sure can't get the ;; binary data from the article buffer, since that's already in a - ;; non-binary charset. So get it from the original article buffer. + ;; non-binary charset. So get it from the original article buffer. (mm-make-handle (with-current-buffer gnus-original-article-buffer (mm-uu-copy-to-buffer start-point end-point)) (list (or (and file-name @@ -729,5 +729,4 @@ Assume text has been decoded if DECODED is non-nil." (provide 'mm-uu) -;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c ;;; mm-uu.el ends here diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index d10f2d9f63..61d5b32b2c 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -22,6 +22,8 @@ ;;; Commentary: ;;; Code: + +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) @@ -30,7 +32,10 @@ (require 'mm-bodies) (require 'mm-decode) (require 'smime) +(require 'mml-smime) +(autoload 'gnus-completing-read "gnus-util") +(autoload 'gnus-window-inside-pixel-edges "gnus-ems") (autoload 'gnus-article-prepare-display "gnus-art") (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") @@ -46,45 +51,55 @@ (defvar w3m-minor-mode-map) (defvar mm-text-html-renderer-alist - '((w3 . mm-inline-text-html-render-with-w3) + '((shr . mm-shr) + (w3 . mm-inline-text-html-render-with-w3) (w3m . mm-inline-text-html-render-with-w3m) (w3m-standalone . mm-inline-text-html-render-with-w3m-standalone) + (gnus-w3m . gnus-article-html) (links mm-inline-render-with-file mm-links-remove-leading-blank "links" "-dump" file) - (lynx mm-inline-render-with-stdin nil - "lynx" "-dump" "-force_html" "-stdin" "-nolist") - (html2text mm-inline-render-with-function html2text)) + (lynx mm-inline-render-with-stdin nil + "lynx" "-dump" "-force_html" "-stdin" "-nolist") + (html2text mm-inline-render-with-function html2text)) "The attributes of renderer types for text/html.") -(defvar mm-text-html-washer-alist - '((w3 . gnus-article-wash-html-with-w3) - (w3m . gnus-article-wash-html-with-w3m) - (w3m-standalone . gnus-article-wash-html-with-w3m-standalone) - (links mm-inline-wash-with-file - mm-links-remove-leading-blank - "links" "-dump" file) - (lynx mm-inline-wash-with-stdin nil - "lynx" "-dump" "-force_html" "-stdin" "-nolist") - (html2text html2text)) - "The attributes of washer types for text/html.") - (defcustom mm-fill-flowed t "If non-nil a format=flowed article will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) +(defcustom mm-inline-large-images-proportion 0.9 + "Maximum proportion of large image resized when +`mm-inline-large-images' is set to resize." + :type 'float + :version "24.1" + :group 'mime-display) + ;;; Internal variables. ;;; ;;; Functions for displaying various formats inline ;;; +(autoload 'gnus-rescale-image "gnus-util") + (defun mm-inline-image-emacs (handle) (let ((b (point-marker)) (inhibit-read-only t)) - (put-image (mm-get-image handle) b) + (put-image + (let ((image (mm-get-image handle))) + (if (eq mm-inline-large-images 'resize) + (gnus-rescale-image image + (let ((edges (gnus-window-inside-pixel-edges + (get-buffer-window (current-buffer))))) + (cons (truncate (* mm-inline-large-images-proportion + (- (nth 2 edges) (nth 0 edges)))) + (truncate (* mm-inline-large-images-proportion + (- (nth 3 edges) (nth 1 edges))))))) + image)) + b) (insert "\n\n") (mm-handle-set-undisplayer handle @@ -404,7 +419,7 @@ (buffer-string))))) (defun mm-inline-text-html (handle) - (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer)) + (let* ((func mm-text-html-renderer) (entry (assq func mm-text-html-renderer-alist)) (inhibit-read-only t)) (if entry @@ -639,9 +654,9 @@ (t (error "Could not identify PKCS#7 type"))))) -(defun mm-view-pkcs7 (handle) +(defun mm-view-pkcs7 (handle &optional from) (case (mm-view-pkcs7-get-type handle) - (enveloped (mm-view-pkcs7-decrypt handle)) + (enveloped (mm-view-pkcs7-decrypt handle from)) (signed (mm-view-pkcs7-verify handle)) (otherwise (error "Unknown or unimplemented PKCS#7 type")))) @@ -666,21 +681,26 @@ (replace-match "\n")) t) -(defun mm-view-pkcs7-decrypt (handle) +(defun mm-view-pkcs7-decrypt (handle &optional from) (insert-buffer-substring (mm-handle-buffer handle)) (goto-char (point-min)) - (insert "MIME-Version: 1.0\n") - (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") - (smime-decrypt-region - (point-min) (point-max) - (if (= (length smime-keys) 1) - (cadar smime-keys) - (smime-get-key-by-email - (completing-read - (concat "Decipher using key" - (if smime-keys (concat "(default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) + (if (eq mml-smime-use 'epg) + ;; Use EPG/gpgsm + (let ((part (base64-decode-string (buffer-string)))) + (erase-buffer) + (insert (epg-decrypt-string (epg-make-context 'CMS) part))) + ;; Use openssl + (insert "MIME-Version: 1.0\n") + (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") + (smime-decrypt-region + (point-min) (point-max) + (if (= (length smime-keys) 1) + (cadar smime-keys) + (smime-get-key-by-email + (gnus-completing-read + "Decipher using key" + smime-keys nil nil nil (car-safe (car-safe smime-keys))))) + from)) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n")) @@ -688,5 +708,4 @@ (provide 'mm-view) -;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 ;;; mm-view.el ends here diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 3d80fee688..9e831a40e6 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -26,10 +26,6 @@ (eval-when-compile (require 'cl)) -(if (locate-library "password-cache") - (require 'password-cache) - (require 'password)) - (autoload 'mml2015-sign "mml2015") (autoload 'mml2015-encrypt "mml2015") (autoload 'mml1991-sign "mml1991") @@ -109,12 +105,18 @@ details." :group 'message :type 'boolean) -(defcustom mml-secure-cache-passphrase password-cache +(defcustom mml-secure-cache-passphrase + (if (boundp 'password-cache) + password-cache + t) "If t, cache passphrase." :group 'message :type 'boolean) -(defcustom mml-secure-passphrase-cache-expiry password-cache-expiry +(defcustom mml-secure-passphrase-cache-expiry + (if (boundp 'password-cache-expiry) + password-cache-expiry + 16) "How many seconds the passphrase is cached. Whether the passphrase is cached at all is controlled by `mml-secure-cache-passphrase'." @@ -306,11 +308,11 @@ Use METHOD if given. Else use `mml-secure-method' or (defun mml-secure-message-sign (&optional method) - "Add MML tags to sign this MML part. + "Add MML tags to sign the entire message. Use METHOD if given. Else use `mml-secure-method' or `mml-default-sign-method'." (interactive) - (mml-secure-part + (mml-secure-message (or method mml-secure-method mml-default-sign-method) 'sign)) @@ -378,5 +380,4 @@ If called with a prefix argument, only encrypt (do NOT sign)." (provide 'mml-sec) -;; arch-tag: 111c56e7-df5e-4287-87d7-93ed2911ec6c ;;; mml-sec.el ends here diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 85995d8cd4..4d27384002 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -53,11 +53,6 @@ mml-smime-epg-verify mml-smime-epg-verify-test))) -(defcustom mml-smime-verbose mml-secure-verbose - "If non-nil, ask the user about the current operation more verbosely." - :group 'mime-security - :type 'boolean) - (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase "If t, cache passphrase." :group 'mime-security @@ -166,10 +161,10 @@ Whether the passphrase is cached at all is controlled by ""))))) (and from (smime-get-key-by-email from))) (smime-get-key-by-email - (completing-read "Sign this part with what signature? " - smime-keys nil nil - (and (listp (car-safe smime-keys)) - (caar smime-keys)))))))) + (gnus-completing-read "Sign this part with what signature" + (mapcar 'car smime-keys) nil nil nil + (and (listp (car-safe smime-keys)) + (caar smime-keys)))))))) (defun mml-smime-get-file-cert () (ignore-errors @@ -218,15 +213,16 @@ Whether the passphrase is cached at all is controlled by (quit)) result)) -(autoload 'gnus-completing-read-with-default "gnus-util") +(autoload 'gnus-completing-read "gnus-util") (defun mml-smime-openssl-encrypt-query () ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) - (ecase (read (gnus-completing-read-with-default - "ldap" "Fetch certificate from" - '(("dns") ("ldap") ("file")) nil t)) + (ecase (read (gnus-completing-read + "Fetch certificate from" + '("dns" "ldap" "file") t nil nil + "ldap")) (dns (setq certs (append certs (mml-smime-get-dns-cert)))) (ldap (setq certs (append certs @@ -520,10 +516,14 @@ Content-Disposition: attachment; filename=smime.p7m ctl 'protocol) "application/pkcs7-signature") t))) - (null (setq signature (mm-find-part-by-type - (cdr handle) - "application/pkcs7-signature" - nil t)))) + (null (setq signature (or (mm-find-part-by-type + (cdr handle) + "application/pkcs7-signature" + nil t) + (mm-find-part-by-type + (cdr handle) + "application/x-pkcs7-signature" + nil t))))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) @@ -550,5 +550,4 @@ Content-Disposition: attachment; filename=smime.p7m (provide 'mml-smime) -;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 ;;; mml-smime.el ends here diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index e81d30ea54..9fb95e3cb4 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -23,7 +23,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -33,10 +33,14 @@ (require 'mm-decode) (require 'mml-sec) (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' (autoload 'message-make-message-id "message") -(autoload 'gnus-setup-posting-charset "gnus-msg") +(declare-function gnus-setup-posting-charset "gnus-msg" (group)) (autoload 'gnus-make-local-hook "gnus-util") +(autoload 'gnus-completing-read "gnus-util") (autoload 'message-fetch-field "message") (autoload 'message-mark-active-p "message") (autoload 'message-info "message") @@ -117,10 +121,18 @@ match found will be used." ,dispositions)))) :group 'message) -(defcustom mml-insert-mime-headers-always nil +(defcustom mml-insert-mime-headers-always t "If non-nil, always put Content-Type: text/plain at top of empty parts. It is necessary to work against a bug in certain clients." - :version "22.1" + :version "24.1" + :type 'boolean + :group 'message) + +(defcustom mml-enable-flowed t + "If non-nil, enable format=flowed usage when encoding a message. +This is only performed when filling on text/plain with hard +newlines in the text." + :version "24.1" :type 'boolean :group 'message) @@ -225,7 +237,10 @@ part. This is for the internal use, you should never modify the value.") (let* (secure-mode (taginfo (mml-read-tag)) (keyfile (cdr (assq 'keyfile taginfo))) - (certfile (cdr (assq 'certfile taginfo))) + (certfiles (delq nil (mapcar (lambda (tag) + (if (eq (car-safe tag) 'certfile) + (cdr tag))) + taginfo))) (recipients (cdr (assq 'recipients taginfo))) (sender (cdr (assq 'sender taginfo))) (location (cdr (assq 'tag-location taginfo))) @@ -251,8 +266,10 @@ part. This is for the internal use, you should never modify the value.") ,@tags ,(if keyfile "keyfile") ,keyfile - ,(if certfile "certfile") - ,certfile + ,@(apply #'append + (mapcar (lambda (certfile) + (list "certfile" certfile)) + certfiles)) ,(if recipients "recipients") ,recipients ,(if sender "sender") @@ -392,8 +409,8 @@ A message part needs to be split into %d charset parts. Really send? " (skip-chars-forward "= \t\n") (setq val (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point)))) - (when (string-match "^\"\\(.*\\)\"$" val) - (setq val (match-string 1 val))) + (when (string-match "\\`\"" val) + (setq val (read val))) ;; inverse of prin1 in mml-insert-tag (push (cons (intern elem) val) contents) (skip-chars-forward " \t\n")) (goto-char (match-end 0)) @@ -520,7 +537,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; `m-g-d-t' will be bound to "message/rfc822" ;; when encoding an article to be forwarded. (mml-generate-default-type "text/plain")) - (mml-to-mime)) + (mml-to-mime) + ;; Update handle so mml-compute-boundary can + ;; detect collisions with the nested parts. + (setcdr (assoc 'contents cont) (buffer-string))) (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) ;; ignore 0x1b, it is part of iso-2022-jp (setq encoding (mm-body-7-or-8)))) @@ -534,7 +554,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; in the mml tag or it says "flowed" and there ;; actually are hard newlines in the text. (let (use-hard-newlines) - (when (and (string= type "text/plain") + (when (and mml-enable-flowed + (string= type "text/plain") (not (string= (cdr (assq 'sign cont)) "pgp")) (or (null (assq 'format cont)) (string= (cdr (assq 'format cont)) @@ -699,7 +720,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defun mml-compute-boundary-1 (cont) (let (filename) (cond - ((eq (car cont) 'part) + ((member (car cont) '(part mml)) (with-temp-buffer (cond ((cdr (assq 'buffer cont)) @@ -898,8 +919,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;; Determine type and stuff. (unless (stringp (car handle)) (unless (setq textp (equal (mm-handle-media-supertype handle) "text")) - (save-excursion - (set-buffer (setq buffer (mml-generate-new-buffer " *mml*"))) + (with-current-buffer (setq buffer (mml-generate-new-buffer " *mml*")) (if (eq (mail-content-type-get (mm-handle-type handle) 'charset) 'gnus-decoded) ;; A part that mm-uu dissected from a non-MIME message @@ -1126,25 +1146,18 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ,@(if (featurep 'xemacs) '(t) '(:help "Display the EasyPG manual"))])) -(defvar mml-mode nil - "Minor mode for editing MML.") - -(defun mml-mode (&optional arg) +(define-minor-mode mml-mode "Minor mode for editing MML. MML is the MIME Meta Language, a minor mode for composing MIME articles. See Info node `(emacs-mime)Composing'. \\{mml-mode-map}" - (interactive "P") - (when (set (make-local-variable 'mml-mode) - (if (null arg) (not mml-mode) - (> (prefix-numeric-value arg) 0))) - (add-minor-mode 'mml-mode " MML" mml-mode-map) + :lighter " MML" :keymap mml-mode-map + (when mml-mode (easy-menu-add mml-menu mml-mode-map) (when (boundp 'dnd-protocol-alist) (set (make-local-variable 'dnd-protocol-alist) - (append mml-dnd-protocol-alist dnd-protocol-alist))) - (run-hooks 'mml-mode-hook))) + (append mml-dnd-protocol-alist dnd-protocol-alist))))) ;;; ;;; Helper functions for reading MIME stuff from the minibuffer and @@ -1173,7 +1186,11 @@ If not set, `default-directory' will be used." (error "Permission denied: %s" file)) file)) +(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force)) +(declare-function mailcap-mime-types "mailcap" ()) + (defun mml-minibuffer-read-type (name &optional default) + (require 'mailcap) (mailcap-parse-mimetypes) (let* ((default (or default (mm-default-file-encoding name) @@ -1181,9 +1198,10 @@ If not set, `default-directory' will be used." ;; looks like, and offer text/plain if it looks ;; like text/plain. "application/octet-stream")) - (string (completing-read - (format "Content type (default %s): " default) - (mapcar 'list (mailcap-mime-types))))) + (string (gnus-completing-read + "Content type" + (mailcap-mime-types) + nil nil nil default))) (if (not (equal string "")) string default))) @@ -1197,10 +1215,10 @@ If not set, `default-directory' will be used." (defun mml-minibuffer-read-disposition (type &optional default filename) (unless default (setq default (mml-content-disposition type filename))) - (let ((disposition (completing-read - (format "Disposition (default %s): " default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) + (let ((disposition (gnus-completing-read + "Disposition" + '("attachment" "inline") + t nil nil default))) (if (not (equal disposition "")) disposition default))) @@ -1388,11 +1406,11 @@ TYPE is the MIME type to use." (defun mml-insert-multipart (&optional type) (interactive (if (message-in-body-p) - (list (completing-read "Multipart type (default mixed): " - '(("mixed") ("alternative") - ("digest") ("parallel") - ("signed") ("encrypted")) - nil nil "mixed")) + (list (gnus-completing-read "Multipart type" + '("mixed" "alternative" + "digest" "parallel" + "signed" "encrypted") + nil "mixed")) (error "Use this command in the message body"))) (or type (setq type "mixed")) @@ -1445,8 +1463,10 @@ or the `pop-to-buffer' function." (setq mml-preview-buffer (generate-new-buffer (concat (if raw "*Raw MIME preview of " "*MIME preview of ") (buffer-name)))) + (require 'gnus-msg) ; for gnus-setup-posting-charset (save-excursion (let* ((buf (current-buffer)) + (article-editing (eq major-mode 'gnus-article-edit-mode)) (message-options message-options) (message-this-is-mail (message-mail-p)) (message-this-is-news (message-news-p)) @@ -1466,15 +1486,19 @@ or the `pop-to-buffer' function." (mml-preview-insert-mail-followup-to) (let ((message-deletable-headers (if (message-news-p) nil - message-deletable-headers))) + message-deletable-headers)) + (mail-header-separator (if article-editing + "" + mail-header-separator))) (message-generate-headers (copy-sequence (if (message-news-p) message-required-news-headers - message-required-mail-headers)))) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t) - (replace-match "\n")) - (let ((mail-header-separator ""));; mail-header-separator is removed. + message-required-mail-headers))) + (unless article-editing + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (replace-match "\n")) + (setq mail-header-separator "")) (message-sort-headers) (mml-to-mime)) (if raw @@ -1485,7 +1509,8 @@ or the `pop-to-buffer' function." (mm-disable-multibyte) (insert s))) (let ((gnus-newsgroup-charset (car message-posting-charset)) - gnus-article-prepare-hook gnus-original-article-buffer) + gnus-article-prepare-hook gnus-original-article-buffer + gnus-displaying-mime) (run-hooks 'gnus-article-decode-hook) (let ((gnus-newsgroup-name "dummy") (gnus-newsrc-hashtb (or gnus-newsrc-hashtb @@ -1562,5 +1587,4 @@ or the `pop-to-buffer' function." (provide 'mml) -;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index dc56466573..f9a47a7180 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -26,9 +26,13 @@ ;;; Code: -;; For Emacs < 22.2. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + ;; For Emacs <22.2 and XEmacs. + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + + (if (locate-library "password-cache") + (require 'password-cache) + (require 'password))) (eval-when-compile (require 'cl) @@ -53,17 +57,12 @@ (defvar mml1991-function-alist '((mailcrypt mml1991-mailcrypt-sign mml1991-mailcrypt-encrypt) - (gpg mml1991-gpg-sign - mml1991-gpg-encrypt) (pgg mml1991-pgg-sign mml1991-pgg-encrypt) (epg mml1991-epg-sign mml1991-epg-encrypt)) "Alist of PGP functions.") -(defvar mml1991-verbose mml-secure-verbose - "If non-nil, ask the user about the current operation more verbosely.") - (defvar mml1991-cache-passphrase mml-secure-cache-passphrase "If t, cache passphrase.") @@ -141,6 +140,7 @@ Whether the passphrase is cached at all is controlled by (delete-region (point-min) (point))) (mm-with-unibyte-current-buffer (with-temp-buffer + (inline (mm-disable-multibyte)) (setq cipher (current-buffer)) (insert-buffer-substring text) (unless (mc-encrypt-generic @@ -166,100 +166,11 @@ Whether the passphrase is cached at all is controlled by (insert-buffer-substring cipher) (goto-char (point-max)))))) -;;; gpg wrapper - -(autoload 'gpg-sign-cleartext "gpg") - -(declare-function gpg-sign-encrypt "ext:gpg" - (plaintext ciphertext result recipients &optional - passphrase sign-with-key armor textmode)) -(declare-function gpg-encrypt "ext:gpg" - (plaintext ciphertext result recipients &optional - passphrase armor textmode)) - -(defun mml1991-gpg-sign (cont) - (let ((text (current-buffer)) - headers signature - (result-buffer (get-buffer-create "*GPG Result*"))) - ;; Save MIME Content[^ ]+: headers from signing - (goto-char (point-min)) - (while (looking-at "^Content[^ ]+:") (forward-line)) - (unless (bobp) - (setq headers (buffer-string)) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (quoted-printable-decode-region (point-min) (point-max)) - (with-temp-buffer - (unless (gpg-sign-cleartext text (setq signature (current-buffer)) - result-buffer - nil - (message-options-get 'message-sender)) - (unless (> (point-max) (point-min)) - (pop-to-buffer result-buffer) - (error "Sign error"))) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (quoted-printable-encode-region (point-min) (point-max)) - (set-buffer text) - (delete-region (point-min) (point-max)) - (if headers (insert headers)) - (insert "\n") - (insert-buffer-substring signature) - (goto-char (point-max))))) - -(defun mml1991-gpg-encrypt (cont &optional sign) - (let ((text (current-buffer)) - cipher - (result-buffer (get-buffer-create "*GPG Result*"))) - ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED - (goto-char (point-min)) - (while (looking-at "^Content[^ ]+:") (forward-line)) - (unless (bobp) - (delete-region (point-min) (point))) - (mm-with-unibyte-current-buffer - (with-temp-buffer - (flet ((gpg-encrypt-func - (sign plaintext ciphertext result recipients &optional - passphrase sign-with-key armor textmode) - (if sign - (gpg-sign-encrypt - plaintext ciphertext result recipients passphrase - sign-with-key armor textmode) - (gpg-encrypt - plaintext ciphertext result recipients passphrase - armor textmode)))) - (unless (gpg-encrypt-func - sign - text (setq cipher (current-buffer)) - result-buffer - (split-string - (or - (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (read-string "Recipients: "))) - "[ \f\t\n\r\v,]+") - nil - (message-options-get 'message-sender) - t t) ; armor & textmode - (unless (> (point-max) (point-min)) - (pop-to-buffer result-buffer) - (error "Encrypt error")))) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (set-buffer text) - (delete-region (point-min) (point-max)) - ;;(insert "Content-Type: application/pgp-encrypted\n\n") - ;;(insert "Version: 1\n\n") - (insert "\n") - (insert-buffer-substring cipher) - (goto-char (point-max)))))) - ;; pgg wrapper +(autoload 'pgg-sign-region "pgg") +(autoload 'pgg-encrypt-region "pgg") + (defvar pgg-default-user-id) (defvar pgg-errors-buffer) (defvar pgg-output-buffer) @@ -329,7 +240,6 @@ Whether the passphrase is cached at all is controlled by ;; epg wrapper (defvar epg-user-id-alist) -(defvar password-cache-expiry) (autoload 'epg-make-context "epg") (autoload 'epg-passphrase-callback-function "epg") @@ -516,5 +426,4 @@ If no one is selected, default secret key is used. " ;; coding: iso-8859-1 ;; End: -;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706 ;;; mml1991.el ends here diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 5b3271b302..ee1958b6b8 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -28,9 +28,13 @@ ;;; Code: -;; For Emacs < 22.2. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + ;; For Emacs <22.2 and XEmacs. + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + + (if (locate-library "password-cache") + (require 'password-cache) + (require 'password))) (eval-when-compile (require 'cl)) (require 'mm-decode) @@ -52,18 +56,9 @@ 'epg) (error)) (progn - (ignore-errors - ;; Avoid the "Recursive load suspected" error - ;; in Emacs 21.1. - (let ((recursive-load-depth-limit 100)) - (require 'pgg))) + (ignore-errors (require 'pgg)) (and (fboundp 'pgg-sign-region) 'pgg)) - (progn - (ignore-errors - (require 'gpg)) - (and (fboundp 'gpg-sign-detached) - 'gpg)) (progn (ignore-errors (load "mc-toplev")) (and (fboundp 'mc-encrypt-generic) @@ -71,7 +66,7 @@ (fboundp 'mc-cleanup-recipient-headers) 'mailcrypt))) "The package used for PGP/MIME. -Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") +Valid packages include `epg', `pgg' and `mailcrypt'.") ;; Something is not RFC2015. (defvar mml2015-function-alist @@ -81,24 +76,18 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") mml2015-mailcrypt-decrypt mml2015-mailcrypt-clear-verify mml2015-mailcrypt-clear-decrypt) - (gpg mml2015-gpg-sign - mml2015-gpg-encrypt - mml2015-gpg-verify - mml2015-gpg-decrypt - mml2015-gpg-clear-verify - mml2015-gpg-clear-decrypt) - (pgg mml2015-pgg-sign - mml2015-pgg-encrypt - mml2015-pgg-verify - mml2015-pgg-decrypt - mml2015-pgg-clear-verify - mml2015-pgg-clear-decrypt) - (epg mml2015-epg-sign - mml2015-epg-encrypt - mml2015-epg-verify - mml2015-epg-decrypt - mml2015-epg-clear-verify - mml2015-epg-clear-decrypt)) + (pgg mml2015-pgg-sign + mml2015-pgg-encrypt + mml2015-pgg-verify + mml2015-pgg-decrypt + mml2015-pgg-clear-verify + mml2015-pgg-clear-decrypt) + (epg mml2015-epg-sign + mml2015-epg-encrypt + mml2015-epg-verify + mml2015-epg-decrypt + mml2015-epg-clear-verify + mml2015-epg-clear-decrypt)) "Alist of PGP/MIME functions.") (defvar mml2015-result-buffer nil) @@ -115,11 +104,6 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") :type '(repeat (cons (regexp :tag "GnuPG output regexp") (boolean :tag "Trust key")))) -(defcustom mml2015-verbose mml-secure-verbose - "If non-nil, ask the user about the current operation more verbosely." - :group 'mime-security - :type 'boolean) - (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase "If t, cache passphrase." :group 'mime-security @@ -149,7 +133,7 @@ Whether the passphrase is cached at all is controlled by ;; Extract plaintext from cleartext signature. IMO, this kind of task ;; should be done by GnuPG rather than Elisp, but older PGP backends -;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG. +;; (such as Mailcrypt, and PGG) discard the output from GnuPG. (defun mml2015-extract-cleartext-signature () ;; Daiki Ueno in ;; <[email protected]>: ``I still @@ -189,9 +173,6 @@ Whether the passphrase is cached at all is controlled by (autoload 'mc-cleanup-recipient-headers "mc-toplev") (autoload 'mc-sign-generic "mc-toplev") -(defvar mc-default-scheme) -(defvar mc-schemes) - (defvar mml2015-decrypt-function 'mailcrypt-decrypt) (defvar mml2015-verify-function 'mailcrypt-verify) @@ -238,6 +219,58 @@ Whether the passphrase is cached at all is controlled by handles (list handles))))) +(defun mml2015-gpg-pretty-print-fpr (fingerprint) + (let* ((result "") + (fpr-length (string-width fingerprint)) + (n-slice 0) + slice) + (setq fingerprint (string-to-list fingerprint)) + (while fingerprint + (setq fpr-length (- fpr-length 4)) + (setq slice (butlast fingerprint fpr-length)) + (setq fingerprint (nthcdr 4 fingerprint)) + (setq n-slice (1+ n-slice)) + (setq result + (concat + result + (case n-slice + (1 slice) + (otherwise (concat " " slice)))))) + result)) + +(defun mml2015-gpg-extract-signature-details () + (goto-char (point-min)) + (let* ((expired (re-search-forward + "^\\[GNUPG:\\] SIGEXPIRED$" + nil t)) + (signer (and (re-search-forward + "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" + nil t) + (cons (match-string 1) (match-string 2)))) + (fprint (and (re-search-forward + "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " + nil t) + (match-string 1))) + (trust (and (re-search-forward + "^\\[GNUPG:\\] \\(TRUST_.*\\)$" + nil t) + (match-string 1))) + (trust-good-enough-p + (cdr (assoc trust mml2015-unabbrev-trust-alist)))) + (cond ((and signer fprint) + (concat (cdr signer) + (unless trust-good-enough-p + (concat "\nUntrusted, Fingerprint: " + (mml2015-gpg-pretty-print-fpr fprint))) + (when expired + (format "\nWARNING: Signature from expired key (%s)" + (car signer))))) + ((re-search-forward + "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t) + (match-string 2)) + (t + "From unknown user")))) + (defun mml2015-mailcrypt-clear-decrypt () (let (result) (setq result @@ -450,279 +483,6 @@ Whether the passphrase is cached at all is controlled by (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) -;;; gpg wrapper - -(autoload 'gpg-decrypt "gpg") -(autoload 'gpg-verify "gpg") -(autoload 'gpg-verify-cleartext "gpg") -(autoload 'gpg-sign-detached "gpg") -(autoload 'gpg-sign-encrypt "gpg") -(autoload 'gpg-encrypt "gpg") -(autoload 'gpg-passphrase-read "gpg") - -(defun mml2015-gpg-passphrase () - (or (message-options-get 'gpg-passphrase) - (message-options-set 'gpg-passphrase (gpg-passphrase-read)))) - -(defun mml2015-gpg-decrypt-1 () - (let ((cipher (current-buffer)) plain result) - (if (with-temp-buffer - (prog1 - (gpg-decrypt cipher (setq plain (current-buffer)) - mml2015-result-buffer nil) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (with-current-buffer mml2015-result-buffer - (buffer-string))) - (set-buffer cipher) - (erase-buffer) - (insert-buffer-substring plain) - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n" t t)))) - '(t) - ;; Some wrong with the return value, check plain text buffer. - (if (> (point-max) (point-min)) - '(t) - nil)))) - -(defun mml2015-gpg-decrypt (handle ctl) - (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1)) - (mml2015-mailcrypt-decrypt handle ctl))) - -(defun mml2015-gpg-clear-decrypt () - (let (result) - (setq result (mml2015-gpg-decrypt-1)) - (if (car result) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK") - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")))) - -(defun mml2015-gpg-pretty-print-fpr (fingerprint) - (let* ((result "") - (fpr-length (string-width fingerprint)) - (n-slice 0) - slice) - (setq fingerprint (string-to-list fingerprint)) - (while fingerprint - (setq fpr-length (- fpr-length 4)) - (setq slice (butlast fingerprint fpr-length)) - (setq fingerprint (nthcdr 4 fingerprint)) - (setq n-slice (1+ n-slice)) - (setq result - (concat - result - (case n-slice - (1 slice) - (otherwise (concat " " slice)))))) - result)) - -(defun mml2015-gpg-extract-signature-details () - (goto-char (point-min)) - (let* ((expired (re-search-forward - "^\\[GNUPG:\\] SIGEXPIRED$" - nil t)) - (signer (and (re-search-forward - "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" - nil t) - (cons (match-string 1) (match-string 2)))) - (fprint (and (re-search-forward - "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " - nil t) - (match-string 1))) - (trust (and (re-search-forward - "^\\[GNUPG:\\] \\(TRUST_.*\\)$" - nil t) - (match-string 1))) - (trust-good-enough-p - (cdr (assoc trust mml2015-unabbrev-trust-alist)))) - (cond ((and signer fprint) - (concat (cdr signer) - (unless trust-good-enough-p - (concat "\nUntrusted, Fingerprint: " - (mml2015-gpg-pretty-print-fpr fprint))) - (when expired - (format "\nWARNING: Signature from expired key (%s)" - (car signer))))) - ((re-search-forward - "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t) - (match-string 2)) - (t - "From unknown user")))) - -(defun mml2015-gpg-verify (handle ctl) - (catch 'error - (let (part message signature info-is-set-p) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mm-handle-multipart-ctl-parameter - ctl 'protocol) - "application/pgp-signature") - t)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Corrupted") - (throw 'error handle)) - (with-temp-buffer - (setq message (current-buffer)) - (insert part) - ;; Convert <LF> to <CR><LF> in signed text. If --textmode is - ;; specified when signing, the conversion is not necessary. - (goto-char (point-min)) - (end-of-line) - (while (not (eobp)) - (unless (eq (char-before) ?\r) - (insert "\r")) - (forward-line) - (end-of-line)) - (with-temp-buffer - (setq signature (current-buffer)) - (unless (setq part (mm-find-part-by-type - (cdr handle) "application/pgp-signature" nil t)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Corrupted") - (throw 'error handle)) - (mm-insert-part part) - (unless (condition-case err - (prog1 - (gpg-verify message signature mml2015-result-buffer) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (with-current-buffer mml2015-result-buffer - (buffer-string)))) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (mml2015-format-error err)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Error.") - (setq info-is-set-p t) - nil) - (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Quit.") - (setq info-is-set-p t) - nil)) - (unless info-is-set-p - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")) - (throw 'error handle))) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info - (with-current-buffer mml2015-result-buffer - (mml2015-gpg-extract-signature-details)))) - handle))) - -(defun mml2015-gpg-clear-verify () - (if (condition-case err - (prog1 - (gpg-verify-cleartext (current-buffer) mml2015-result-buffer) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (with-current-buffer mml2015-result-buffer - (buffer-string)))) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (mml2015-format-error err)) - nil) - (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") - nil)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info - (with-current-buffer mml2015-result-buffer - (mml2015-gpg-extract-signature-details))) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed")) - (mml2015-extract-cleartext-signature)) - -(defun mml2015-gpg-sign (cont) - (let ((boundary (mml-compute-boundary cont)) - (text (current-buffer)) signature) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (with-temp-buffer - (unless (gpg-sign-detached text (setq signature (current-buffer)) - mml2015-result-buffer - nil - (message-options-get 'message-sender) - t t) ; armor & textmode - (unless (> (point-max) (point-min)) - (pop-to-buffer mml2015-result-buffer) - (error "Sign error"))) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (set-buffer text) - (goto-char (point-min)) - (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" - boundary)) - ;;; FIXME: what is the micalg? - (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n") - (insert (format "\n--%s\n" boundary)) - (goto-char (point-max)) - (insert (format "\n--%s\n" boundary)) - (insert "Content-Type: application/pgp-signature\n\n") - (insert-buffer-substring signature) - (goto-char (point-max)) - (insert (format "--%s--\n" boundary)) - (goto-char (point-max))))) - -(defun mml2015-gpg-encrypt (cont &optional sign) - (let ((boundary (mml-compute-boundary cont)) - (text (current-buffer)) - cipher) - (mm-with-unibyte-current-buffer - (with-temp-buffer - ;; set up a function to call the correct gpg encrypt routine - ;; with the right arguments. (FIXME: this should be done - ;; differently.) - (flet ((gpg-encrypt-func - (sign plaintext ciphertext result recipients &optional - passphrase sign-with-key armor textmode) - (if sign - (gpg-sign-encrypt - plaintext ciphertext result recipients passphrase - sign-with-key armor textmode) - (gpg-encrypt - plaintext ciphertext result recipients passphrase - armor textmode)))) - (unless (gpg-encrypt-func - sign ; passed in when using signencrypt - text (setq cipher (current-buffer)) - mml2015-result-buffer - (split-string - (or - (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (read-string "Recipients: "))) - "[ \f\t\n\r\v,]+") - nil - (message-options-get 'message-sender) - t t) ; armor & textmode - (unless (> (point-max) (point-min)) - (pop-to-buffer mml2015-result-buffer) - (error "Encrypt error")))) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (set-buffer text) - (delete-region (point-min) (point-max)) - (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" - boundary)) - (insert "\tprotocol=\"application/pgp-encrypted\"\n\n") - (insert (format "--%s\n" boundary)) - (insert "Content-Type: application/pgp-encrypted\n\n") - (insert "Version: 1\n\n") - (insert (format "--%s\n" boundary)) - (insert "Content-Type: application/octet-stream\n\n") - (insert-buffer-substring cipher) - (goto-char (point-max)) - (insert (format "--%s--\n" boundary)) - (goto-char (point-max)))))) - ;;; pgg wrapper (defvar pgg-default-user-id) @@ -982,12 +742,11 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-key-sub-key-list "epg") (autoload 'epg-sub-key-capability "epg") (autoload 'epg-sub-key-validity "epg") +(autoload 'epg-sub-key-fingerprint "epg") (autoload 'epg-configuration "epg-config") (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") -(defvar password-cache-expiry) - (defvar mml2015-epg-secret-key-id-list nil) (defun mml2015-epg-passphrase-callback (context key-id ignore) @@ -1019,12 +778,31 @@ Whether the passphrase is cached at all is controlled by (let ((pointer (epg-key-sub-key-list (car keys)))) (while pointer (if (and (memq usage (epg-sub-key-capability (car pointer))) + (not (memq 'disabled (epg-sub-key-capability (car pointer)))) (not (memq (epg-sub-key-validity (car pointer)) '(revoked expired)))) (throw 'found (car keys))) (setq pointer (cdr pointer)))) (setq keys (cdr keys))))) +;; XXX: since gpg --list-secret-keys does not return validity of each +;; key, `mml2015-epg-find-usable-key' defined above is not enough for +;; secret keys. The function `mml2015-epg-find-usable-secret-key' +;; below looks at appropriate public keys to check usability. +(defun mml2015-epg-find-usable-secret-key (context name usage) + (let ((secret-keys (epg-list-keys context name t)) + secret-key) + (while (and (not secret-key) secret-keys) + (if (mml2015-epg-find-usable-key + (epg-list-keys context (epg-sub-key-fingerprint + (car (epg-key-sub-key-list + (car secret-keys))))) + usage) + (setq secret-key (car secret-keys) + secret-keys nil) + (setq secret-keys (cdr secret-keys)))) + secret-key)) + (defun mml2015-epg-decrypt (handle ctl) (catch 'error (let ((inhibit-redisplay t) @@ -1182,6 +960,7 @@ Whether the passphrase is cached at all is controlled by (let* ((inhibit-redisplay t) (context (epg-make-context)) (boundary (mml-compute-boundary cont)) + (sender (message-options-get 'message-sender)) signer-key (signers (or (message-options-get 'mml2015-epg-signers) @@ -1191,14 +970,18 @@ Whether the passphrase is cached at all is controlled by (epa-select-keys context "\ Select keys for signing. If no one is selected, default secret key is used. " - mml2015-signers t) - (if mml2015-signers + (if sender + (cons (concat "<" sender ">") + mml2015-signers) + mml2015-signers) + t) + (if (or sender mml2015-signers) (delq nil (mapcar (lambda (signer) - (setq signer-key (mml2015-epg-find-usable-key - (epg-list-keys context signer t) - 'sign)) + (setq signer-key + (mml2015-epg-find-usable-secret-key + context signer 'sign)) (unless (or signer-key (y-or-n-p (format @@ -1206,7 +989,10 @@ If no one is selected, default secret key is used. " signer))) (error "No secret key for %s" signer)) signer-key) - mml2015-signers))))))) + (if sender + (cons (concat "<" sender ">") + mml2015-signers) + mml2015-signers)))))))) signature micalg) (epg-context-set-armor context t) (epg-context-set-textmode context t) @@ -1249,6 +1035,7 @@ If no one is selected, default secret key is used. " (let ((inhibit-redisplay t) (context (epg-make-context)) (config (epg-configuration)) + (sender (message-options-get 'message-sender)) (recipients (message-options-get 'mml2015-epg-recipients)) cipher signers (boundary (mml-compute-boundary cont)) @@ -1266,9 +1053,12 @@ If no one is selected, default secret key is used. " (read-string "Recipients: "))) "[ \f\t\n\r\v,]+")))) (when mml2015-encrypt-to-self - (unless mml2015-signers - (error "mml2015-signers not set")) - (setq recipients (nconc recipients mml2015-signers))) + (unless (or sender mml2015-signers) + (error "Message sender and mml2015-signers not set")) + (setq recipients (nconc recipients (if sender + (cons (concat "<" sender ">") + mml2015-signers) + mml2015-signers)))) (if (eq mm-encrypt-option 'guided) (setq recipients (epa-select-keys context "\ @@ -1301,14 +1091,18 @@ If no one is selected, symmetric encryption will be performed. " (epa-select-keys context "\ Select keys for signing. If no one is selected, default secret key is used. " - mml2015-signers t) - (if mml2015-signers + (if sender + (cons (concat "<" sender ">") + mml2015-signers) + mml2015-signers) + t) + (if (or sender mml2015-signers) (delq nil (mapcar (lambda (signer) - (setq signer-key (mml2015-epg-find-usable-key - (epg-list-keys context signer t) - 'sign)) + (setq signer-key + (mml2015-epg-find-usable-secret-key + context signer 'sign)) (unless (or signer-key (y-or-n-p (format @@ -1316,7 +1110,9 @@ If no one is selected, default secret key is used. " signer))) (error "No secret key for %s" signer)) signer-key) - mml2015-signers))))))) + (if sender + (cons (concat "<" sender ">") mml2015-signers) + mml2015-signers)))))))) (epg-context-set-signers context signers)) (epg-context-set-armor context t) (epg-context-set-textmode context t) @@ -1416,5 +1212,4 @@ If no one is selected, default secret key is used. " (provide 'mml2015) -;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 ;;; mml2015.el ends here diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el index 63eea8cacd..7d7672b573 100644 --- a/lisp/gnus/nnagent.el +++ b/lisp/gnus/nnagent.el @@ -121,7 +121,7 @@ (deffoo nnagent-request-set-mark (group action server) (mm-with-unibyte-buffer (insert "(gnus-agent-synchronize-group-flags \"" - group + group "\" '") (gnus-pp action) (insert " \"" @@ -151,7 +151,7 @@ ;; Assume that articles with smaller numbers than the first one ;; Agent knows are gone. (setq first (caar gnus-agent-article-alist)) - (when first + (when first (while (and arts (< (car arts) first)) (pop arts))) (set-buffer nntp-server-buffer) @@ -190,9 +190,9 @@ (deffoo nnagent-request-expire-articles (articles group &optional server force) articles) -(deffoo nnagent-request-group (group &optional server dont-check) +(deffoo nnagent-request-group (group &optional server dont-check info) (nnoo-parent-function 'nnagent 'nnml-request-group - (list group (nnagent-server server) dont-check))) + (list group (nnagent-server server) dont-check info))) (deffoo nnagent-close-group (group &optional server) (nnoo-parent-function 'nnagent 'nnml-close-group @@ -252,6 +252,9 @@ (nnoo-parent-function 'nnagent 'nnml-request-regenerate (list (nnagent-server server)))) +(deffoo nnagent-retrieve-group-data-early (server infos) + nil) + ;; Use nnml functions for just about everything. (nnoo-import nnagent (nnml)) @@ -261,5 +264,4 @@ (provide 'nnagent) -;; arch-tag: af710b77-f816-4969-af31-6fd94fb42245 ;;; nnagent.el ends here diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 0ced239e91..51e0466495 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -75,8 +75,7 @@ (nnoo-define-basics nnbabyl) (deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let ((number (length articles)) (count 0) @@ -136,8 +135,7 @@ ;; Restore buffer mode. (when (and (nnbabyl-server-opened) nnbabyl-previous-buffer-mode) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (narrow-to-region (caar nnbabyl-previous-buffer-mode) (cdar nnbabyl-previous-buffer-mode)) @@ -155,8 +153,7 @@ (deffoo nnbabyl-request-article (article &optional newsgroup server buffer) (nnbabyl-possibly-change-newsgroup newsgroup server) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (when (search-forward (nnbabyl-article-string article) nil t) (let (start stop summary-line) @@ -194,7 +191,7 @@ (cons nnbabyl-current-group article) (nnbabyl-article-group-number))))))) -(deffoo nnbabyl-request-group (group &optional server dont-check) +(deffoo nnbabyl-request-group (group &optional server dont-check info) (let ((active (cadr (assoc group nnbabyl-group-alist)))) (save-excursion (cond @@ -216,8 +213,7 @@ (nnmail-get-new-mail 'nnbabyl (lambda () - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (save-buffer))) (file-name-directory nnbabyl-mbox-file) group @@ -264,8 +260,7 @@ rest) (nnmail-activate 'nnbabyl) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (set-text-properties (point-min) (point-max) nil) (while (and articles is-old) (goto-char (point-min)) @@ -308,15 +303,13 @@ result) (and (nnbabyl-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) (while (re-search-forward "^X-Gnus-Newsgroup:" (save-excursion (search-forward "\n\n" nil t) (point)) t) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (delete-region (point-at-bol) (progn (forward-line 1) (point)))) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) @@ -344,7 +337,7 @@ (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) (delete-region (point) (progn (forward-line 1) (point))))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -363,7 +356,7 @@ (insert-buffer-substring buf) (when last (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -373,8 +366,7 @@ (deffoo nnbabyl-request-replace-article (article group buffer) (nnbabyl-possibly-change-newsgroup group) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (if (not (search-forward (nnbabyl-article-string article) nil t)) nil @@ -388,8 +380,7 @@ ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) @@ -409,8 +400,7 @@ (deffoo nnbabyl-request-rename-group (group new-name &optional server) (nnbabyl-possibly-change-newsgroup group server) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) @@ -436,9 +426,7 @@ (defun nnbabyl-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. (unless force - (delete-region - (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (delete-region (point-at-bol) (progn (forward-line 1) (point)))) ;; Beginning of the article. (save-excursion (save-restriction @@ -558,9 +546,8 @@ (defun nnbabyl-create-mbox () (unless (file-exists-p nnbabyl-mbox-file) ;; Create a new, empty RMAIL mbox file. - (save-excursion - (set-buffer (setq nnbabyl-mbox-buffer - (create-file-buffer nnbabyl-mbox-file))) + (with-current-buffer (setq nnbabyl-mbox-buffer + (create-file-buffer nnbabyl-mbox-file)) (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region @@ -572,8 +559,7 @@ (unless (and nnbabyl-mbox-buffer (buffer-name nnbabyl-mbox-buffer) - (save-excursion - (set-buffer nnbabyl-mbox-buffer) + (with-current-buffer nnbabyl-mbox-buffer (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) ;; This buffer has changed since we read it last. Possibly. (save-excursion @@ -650,8 +636,7 @@ (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) (if (intern-soft (setq id (match-string 1)) idents) (progn - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) + (delete-region (point-at-bol) (progn (forward-line 1) (point))) (nnheader-message 7 "Moving %s..." id) (nnbabyl-save-mail (nnmail-article-group 'nnbabyl-active-number))) @@ -663,5 +648,4 @@ (provide 'nnbabyl) -;; arch-tag: aa7ddedb-8c07-4c0e-beb0-58e795c2b81b ;;; nnbabyl.el ends here diff --git a/lisp/gnus/nndb.el b/lisp/gnus/nndb.el deleted file mode 100644 index 07cd7b1d12..0000000000 --- a/lisp/gnus/nndb.el +++ /dev/null @@ -1,325 +0,0 @@ -;;; nndb.el --- nndb access for Gnus - -;; Copyright (C) 1997, 1998, 2000, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <[email protected]> -;; Kai Grossjohann <[email protected]> -;; Joe Hildebrand <[email protected]> -;; David Blacka <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; This was based upon Kai Grossjohan's shamessly snarfed code and -;;; further modified by Joe Hildebrand. It has been updated for Red -;;; Gnus. - -;; TODO: -;; -;; * Fix bug where server connection can be lost and impossible to regain -;; This hasn't happened to me in a while; think it was fixed in Rgnus -;; -;; * make it handle different nndb servers seemlessly -;; -;; * Optimize expire if FORCE -;; -;; * Optimize move (only expire once) -;; -;; * Deal with add/deletion of groups -;; -;; * make the backend TOUCH an article when marked as expireable (will -;; make article expire 'expiry' days after that moment). - -;;; Code: - -;; For Emacs < 22.2. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - -;;- -;; Register nndb with known select methods. - -(require 'gnus-start) -(unless (assoc "nndb" gnus-valid-select-methods) - (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address)) - -(require 'nnmail) -(require 'nnheader) -(require 'nntp) -(eval-when-compile (require 'cl)) - -;; Declare nndb as derived from nntp - -(nnoo-declare nndb nntp) - -;; Variables specific to nndb - -;;- currently not used but just in case... -(defvoo nndb-deliver-program "nndel" - "*The program used to put a message in an NNDB group.") - -(defvoo nndb-server-side-expiry nil - "If t, expiry calculation will occur on the server side.") - -(defvoo nndb-set-expire-date-on-mark nil - "If t, the expiry date for a given article will be set to the time -it was marked as expireable; otherwise the date will be the time the -article was posted to nndb") - -;; Variables copied from nntp - -(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) - "Like nntp-server-opened-hook." - nntp-server-opened-hook) - -(defvoo nndb-address "localhost" - "*The name of the NNDB server." - nntp-address) - -(defvoo nndb-port-number 9000 - "*Port number to connect to." - nntp-port-number) - -;; change to 'news if you are actually using nndb for news -(defvoo nndb-article-type 'mail) - -(defvoo nndb-status-string nil "" nntp-status-string) - - - -(defconst nndb-version "nndb 0.7" - "Version numbers of this version of NNDB.") - - -;;; Interface functions. - -(nnoo-define-basics nndb) - -;;------------------------------------------------------------------ - -;; this function turns the lisp list into a string list. There is -;; probably a more efficient way to do this. -(defun nndb-build-article-string (articles) - (let (art-string art) - (while articles - (setq art (pop articles)) - (setq art-string (concat art-string art " "))) - art-string)) - -(defun nndb-build-expire-rest-list (total expire) - (let (art rest) - (while total - (setq art (pop total)) - (if (memq art expire) - () - (push art rest))) - rest)) - - -;; -(deffoo nndb-request-type (group &optional article) - nndb-article-type) - -;; nndb-request-update-info does not exist and is not needed - -;; nndb-request-update-mark does not exist; it should be used to TOUCH -;; articles as they are marked exipirable -(defun nndb-touch-article (group article) - (nntp-send-command nil "X-TOUCH" article)) - -(deffoo nndb-request-update-mark - (group article mark) - "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" - (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) - (nndb-touch-article group article)) - mark) - -;; nndb-request-create-group -- currently this isn't necessary; nndb -;; creates groups on demand. - -;; todo -- use some other time than the creation time of the article -;; best is time since article has been marked as expirable - -(defun nndb-request-expire-articles-local - (articles &optional group server force) - "Let gnus do the date check and issue the delete commands." - (let (msg art delete-list (num-delete 0) rest) - (nntp-possibly-change-group group server) - (while articles - (setq art (pop articles)) - (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) - (setq msg (nndb-status-message)) - (if (string-match "^423" msg) - () - (or (string-match "'\\(.+\\)'" msg) - (error "Not a valid response for X-DATE command: %s" - msg)) - (if (nnmail-expired-article-p - group - (date-to-time (substring msg (match-beginning 1) (match-end 1))) - force) - (progn - (setq delete-list (concat delete-list " " (int-to-string art))) - (setq num-delete (1+ num-delete))) - (push art rest)))) - (if (> (length delete-list) 0) - (progn - (nnheader-message 5 "Deleting %s article(s) from %s" - (int-to-string num-delete) group) - (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) - ) - - (nnheader-message 5 "") - (nconc rest articles))) - -(defun nndb-get-remote-expire-response () - (let (list) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (looking-at "^[34]") - ;; x-expire returned error--presume no articles were expirable) - (setq list nil) - ;; otherwise, pull all of the following numbers into the list - (re-search-forward "follows\r?\n?" nil t) - (while (re-search-forward "^[0-9]+$" nil t) - (push (string-to-number (match-string 0)) list))) - list)) - -(defun nndb-request-expire-articles-remote - (articles &optional group server force) - "Let the nndb backend expire articles" - (let (days art-string delete-list (num-delete 0)) - (nntp-possibly-change-group group server) - - ;; first calculate the wait period in days - (setq days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function group)) - nnmail-expiry-wait)) - ;; now handle the special cases - (cond (force - (setq days 0)) - ((eq days 'never) - ;; This isn't an expirable group. - (setq days -1)) - ((eq days 'immediate) - (setq days 0))) - - - ;; build article string - (setq art-string (concat days " " (nndb-build-article-string articles))) - (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) - - (setq delete-list (nndb-get-remote-expire-response)) - (setq num-delete (length delete-list)) - (if (> num-delete 0) - (nnheader-message 5 "Deleting %s article(s) from %s" - (int-to-string num-delete) group)) - - (nndb-build-expire-rest-list articles delete-list))) - -(deffoo nndb-request-expire-articles - (articles &optional group server force) - "Expires ARTICLES from GROUP on SERVER. -If FORCE, delete regardless of exiration date, otherwise use normal -expiry mechanism." - (if nndb-server-side-expiry - (nndb-request-expire-articles-remote articles group server force) - (nndb-request-expire-articles-local articles group server force))) - -;; _Something_ defines it... -(declare-function nndb-request-article "nndb" t t) - -(deffoo nndb-request-move-article - (article group server accept-form &optional last move-is-internal) - "Move ARTICLE (a number) from GROUP on SERVER. -Evals ACCEPT-FORM in current buffer, where the article is. -Optional LAST is ignored." - ;; we guess that the second arg in accept-form is the new group, - ;; which it will be for nndb, which is all that matters anyway - (let ((new-group (nth 1 accept-form)) result) - (nntp-possibly-change-group group server) - - ;; use the move command for nndb-to-nndb moves - (if (string-match "^nndb" new-group) - (let ((new-group-name (gnus-group-real-name new-group))) - (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) - (cons new-group article)) - ;; else move normally - (let ((artbuf (get-buffer-create " *nndb move*"))) - (and - (nndb-request-article article group server artbuf) - (save-excursion - (set-buffer artbuf) - (insert-buffer-substring nntp-server-buffer) - (setq result (eval accept-form)) - (kill-buffer (current-buffer)) - result) - (nndb-request-expire-articles (list article) - group - server - t)) - result) - ))) - -(deffoo nndb-request-accept-article (group server &optional last) - "The article in the current buffer is put into GROUP." - (nntp-possibly-change-group group server) - (let (art msg) - (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) - (nnheader-insert "") - (nntp-send-buffer "^[23].*\n")) - - (set-buffer nntp-server-buffer) - (setq msg (buffer-string)) - (or (string-match "^\\([0-9]+\\)" msg) - (error "nndb: %s" msg)) - (setq art (substring msg (match-beginning 1) (match-end 1))) - (nnheader-message 5 "nndb: accepted %s" art) - (list art))) - -(deffoo nndb-request-replace-article (article group buffer) - "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." - (set-buffer buffer) - (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) - (nnheader-insert "") - (nntp-send-buffer "^[23.*\n") - (list (int-to-string article)))) - - ; nndb-request-delete-group does not exist - ; todo -- maybe later - - ; nndb-request-rename-group does not exist - ; todo -- maybe later - -;; -- standard compatibility functions - -(deffoo nndb-status-message (&optional server) - "Return server status as a string." - (set-buffer nntp-server-buffer) - (buffer-string)) - -;; Import stuff from nntp - -(nnoo-import nndb - (nntp)) - -(provide 'nndb) - -;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a -;;; nndb.el ends here diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 0662da239b..f28aa1845e 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -380,8 +380,7 @@ all. This may very well take some time.") (deffoo nndiary-retrieve-headers (sequence &optional group server fetch-old) (when (nndiary-possibly-change-directory group server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((file nil) (number (length sequence)) @@ -483,7 +482,7 @@ all. This may very well take some time.") (cons (if group-num (car group-num) group) (string-to-number (file-name-nondirectory path))))))) -(deffoo nndiary-request-group (group &optional server dont-check) +(deffoo nndiary-request-group (group &optional server dont-check info) (let ((file-name-coding-system nnmail-pathname-coding-system)) (cond ((not (nndiary-possibly-change-directory group server)) @@ -615,8 +614,7 @@ all. This may very well take some time.") (let (nndiary-current-directory nndiary-current-group nndiary-article-file-alist) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) @@ -672,8 +670,7 @@ all. This may very well take some time.") (deffoo nndiary-request-replace-article (article group buffer) (nndiary-possibly-change-directory group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (nndiary-possibly-create-directory group) (let ((chars (nnmail-insert-lines)) (art (concat (int-to-string article) "\t")) @@ -688,8 +685,7 @@ all. This may very well take some time.") t) (setq headers (nndiary-parse-head chars article)) ;; Replace the NOV line in the NOV file. - (save-excursion - (set-buffer (nndiary-open-nov group)) + (with-current-buffer (nndiary-open-nov group) (goto-char (point-min)) (if (or (looking-at art) (search-forward (concat "\n" art) nil t)) @@ -842,8 +838,7 @@ all. This may very well take some time.") ;; Find an article number in the current group given the Message-ID. (defun nndiary-find-group-number (id) - (save-excursion - (set-buffer (get-buffer-create " *nndiary id*")) + (with-current-buffer (get-buffer-create " *nndiary id*") (let ((alist nndiary-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -888,8 +883,7 @@ all. This may very well take some time.") (let ((nov (expand-file-name nndiary-nov-file-name nndiary-current-directory))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -989,8 +983,7 @@ all. This may very well take some time.") (defun nndiary-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nndiary-open-nov group)) + (with-current-buffer (nndiary-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) @@ -1015,8 +1008,7 @@ all. This may very well take some time.") (or (cdr (assoc group nndiary-nov-buffer-alist)) (let ((buffer (get-buffer-create (format " *nndiary overview %s*" group)))) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nndiary-nov-buffer-file-name) (expand-file-name nndiary-nov-file-name @@ -1069,9 +1061,9 @@ all. This may very well take some time.") (file-directory-p dir)) (nndiary-generate-nov-databases-1 dir seen)))) ;; Do this directory. - (let ((files (sort (nnheader-article-to-file-alist dir) + (let ((nndiary-files (sort (nnheader-article-to-file-alist dir) 'car-less-than-car))) - (if (not files) + (if (not nndiary-files) (let* ((group (nnheader-file-to-group (directory-file-name dir) nndiary-directory)) (info (cadr (assoc group nndiary-group-alist)))) @@ -1079,11 +1071,11 @@ all. This may very well take some time.") (setcar info (1+ (cdr info))))) (funcall nndiary-generate-active-function dir) ;; Generate the nov file. - (nndiary-generate-nov-file dir files) + (nndiary-generate-nov-file dir nndiary-files) (unless no-active (nnmail-save-active nndiary-group-alist nndiary-active-file)))))) -(defvar files) +(defvar nndiary-files) ; dynamically bound in nndiary-generate-nov-databases-1 (defun nndiary-generate-active-info (dir) ;; Update the active info for this group. (let* ((group (nnheader-file-to-group @@ -1092,9 +1084,9 @@ all. This may very well take some time.") (last (or (caadr entry) 0))) (setq nndiary-group-alist (delq entry nndiary-group-alist)) (push (list group - (cons (or (caar files) (1+ last)) + (cons (or (caar nndiary-files) (1+ last)) (max last - (or (caar (last files)) + (or (caar (last nndiary-files)) 0)))) nndiary-group-alist))) @@ -1103,9 +1095,8 @@ all. This may very well take some time.") (nov (concat dir nndiary-nov-file-name)) (nov-buffer (get-buffer-create " *nov*")) chars file headers) - (save-excursion - ;; Init the nov buffer. - (set-buffer nov-buffer) + ;; Init the nov buffer. + (with-current-buffer nov-buffer (buffer-disable-undo) (erase-buffer) (set-buffer nntp-server-buffer) @@ -1125,20 +1116,17 @@ all. This may very well take some time.") (unless (zerop (buffer-size)) (goto-char (point-min)) (setq headers (nndiary-parse-head chars (caar files))) - (save-excursion - (set-buffer nov-buffer) + (with-current-buffer nov-buffer (goto-char (point-max)) (nnheader-insert-nov headers))) (widen)) (setq files (cdr files))) - (save-excursion - (set-buffer nov-buffer) + (with-current-buffer nov-buffer (nnmail-write-region 1 (point-max) nov nil 'nomesg) (kill-buffer (current-buffer)))))) (defun nndiary-nov-delete-article (group article) - (save-excursion - (set-buffer (nndiary-open-nov group)) + (with-current-buffer (nndiary-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point))) (when (bobp) @@ -1584,6 +1572,4 @@ all. This may very well take some time.") (provide 'nndiary) - -;; arch-tag: 9c542b95-92e7-4ace-a038-330ab296e203 ;;; nndiary.el ends here diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el index b90cd4929e..3d390acd5a 100644 --- a/lisp/gnus/nndir.el +++ b/lisp/gnus/nndir.el @@ -96,5 +96,4 @@ (provide 'nndir) -;; arch-tag: 56f09f68-0e4e-4816-818a-df80b4a394c8 ;;; nndir.el ends here diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index b3361bb4a9..759d3cf02a 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -64,9 +64,6 @@ from the document.") (body-end . "") (file-end . "") (subtype digest guess)) - (mime-parts - (generate-head-function . nndoc-generate-mime-parts-head) - (article-transform-function . nndoc-transform-mime-parts)) (nsmail (article-begin . "^From - ")) (news @@ -82,6 +79,9 @@ from the document.") (body-end . "\^_") (body-begin-function . nndoc-babyl-body-begin) (head-begin-function . nndoc-babyl-head-begin)) + (mime-parts + (generate-head-function . nndoc-generate-mime-parts-head) + (article-transform-function . nndoc-transform-mime-parts)) (exim-bounce (article-begin . "^------ This is a copy of the message, including all the headers. ------\n\n") (body-end-function . nndoc-exim-bounce-body-end-function)) @@ -100,7 +100,7 @@ from the document.") (head-end . "^\t") (generate-head-function . nndoc-generate-clari-briefs-head) (article-transform-function . nndoc-transform-clari-briefs)) - + (standard-digest (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+")) (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+")) @@ -118,6 +118,16 @@ from the document.") (file-end . "^End of") (prepare-body-function . nndoc-unquote-dashes) (subtype digest guess)) + (google + (pre-dissection-function . nndoc-decode-content-transfer-encoding) + (article-begin . "^== [0-9]+ of [0-9]+ ==$") + (head-begin . "^Date:") + (head-end . "^$") + (body-end-function . nndoc-digest-body-end) + (body-begin . "^$") + (file-end . "^==============================================================================$") + (prepare-body-function . nndoc-unquote-dashes) + (subtype digest guess)) (lanl-gov-announce (article-begin . "^\\\\\\\\\n") (head-begin . "^\\(Paper.*:\\|arXiv:\\)") @@ -128,6 +138,14 @@ from the document.") (generate-head-function . nndoc-generate-lanl-gov-head) (article-transform-function . nndoc-transform-lanl-gov-announce) (subtype preprints guess)) + (git + (file-begin . "\n- Log ---.*") + (article-begin . "^commit ") + (head-begin . "^Author: ") + (body-begin . "^$") + (file-end . "\n-----------------------------------------------------------------------") + (article-transform-function . nndoc-transform-git-article) + (header-transform-function . nndoc-transform-git-headers)) (rfc822-forward (article-begin . "^\n+") (body-end-function . nndoc-rfc822-forward-body-end-function) @@ -183,9 +201,11 @@ from the document.") (defvoo nndoc-prepare-body-function nil) (defvoo nndoc-generate-head-function nil) (defvoo nndoc-article-transform-function nil) +(defvoo nndoc-header-transform-function nil) (defvoo nndoc-article-begin-function nil) (defvoo nndoc-generate-article-function nil) (defvoo nndoc-dissection-function nil) +(defvoo nndoc-pre-dissection-function nil) (defvoo nndoc-status-string "") (defvoo nndoc-group-alist nil) @@ -204,8 +224,7 @@ from the document.") (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old) (when (nndoc-possibly-change-buffer newsgroup server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article entry) (if (stringp (car articles)) @@ -213,17 +232,22 @@ from the document.") (while articles (when (setq entry (cdr (assq (setq article (pop articles)) nndoc-dissection-alist))) - (insert (format "221 %d Article retrieved.\n" article)) - (if nndoc-generate-head-function - (funcall nndoc-generate-head-function article) - (insert-buffer-substring - nndoc-current-buffer (car entry) (nth 1 entry))) - (goto-char (point-max)) - (unless (eq (char-after (1- (point))) ?\n) - (insert "\n")) - (insert (format "Lines: %d\n" (nth 4 entry))) - (insert ".\n"))) - + (let ((start (point))) + (insert (format "221 %d Article retrieved.\n" article)) + (if nndoc-generate-head-function + (funcall nndoc-generate-head-function article) + (insert-buffer-substring + nndoc-current-buffer (car entry) (nth 1 entry))) + (goto-char (point-max)) + (unless (eq (char-after (1- (point))) ?\n) + (insert "\n")) + (insert (format "Lines: %d\n" (nth 4 entry))) + (insert ".\n") + (when nndoc-header-transform-function + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (funcall nndoc-header-transform-function entry))))))) (nnheader-fold-continuation-lines) 'headers))))) @@ -254,7 +278,7 @@ from the document.") (funcall nndoc-article-transform-function article)) t)))))) -(deffoo nndoc-request-group (group &optional server dont-check) +(deffoo nndoc-request-group (group &optional server dont-check info) "Select news GROUP." (let (number) (cond @@ -270,6 +294,11 @@ from the document.") (t (nnheader-insert "211 %d %d %d %s\n" number 1 number group))))) +(deffoo nndoc-retrieve-groups (groups &optional server) + (dolist (group groups) + (nndoc-request-group group server)) + t) + (deffoo nndoc-request-type (group &optional article) (cond ((not article) 'unknown) (nndoc-post-type nndoc-post-type) @@ -288,7 +317,7 @@ from the document.") t) (deffoo nndoc-request-list (&optional server) - nil) + t) (deffoo nndoc-request-newgroups (date &optional server) nil) @@ -322,8 +351,7 @@ from the document.") (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (erase-buffer) (if (and (stringp nndoc-address) (string-match nndoc-binary-file-names nndoc-address)) @@ -336,8 +364,7 @@ from the document.") ;; Initialize the nndoc structures according to this new document. (when (and nndoc-current-buffer (not nndoc-dissection-alist)) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (nndoc-set-delims) (if (eq nndoc-article-type 'mime-parts) (nndoc-dissect-mime-parts) @@ -360,10 +387,12 @@ from the document.") nndoc-file-end nndoc-article-begin nndoc-body-begin nndoc-body-end-function nndoc-body-end nndoc-prepare-body-function nndoc-article-transform-function + nndoc-header-transform-function nndoc-generate-head-function nndoc-body-begin-function nndoc-head-begin-function nndoc-generate-article-function - nndoc-dissection-function))) + nndoc-dissection-function + nndoc-pre-dissection-function))) (while vars (set (pop vars) nil))) (let (defs) @@ -445,6 +474,22 @@ from the document.") (forward-line 1) (goto-char (+ (point) (string-to-number (match-string 1)))))) +(defun nndoc-google-type-p () + (when (re-search-forward "^=3D=3D 1 of [0-9]+ =3D=3D$" nil t) + t)) + +(defun nndoc-decode-content-transfer-encoding () + (let ((encoding + (save-restriction + (message-narrow-to-head) + (message-fetch-field "content-transfer-encoding")))) + (when (and encoding + (search-forward "\n\n" nil t)) + (save-restriction + (narrow-to-region (point) (point-max)) + (mm-decode-content-transfer-encoding + (intern (downcase (mail-header-strip encoding)))))))) + (defun nndoc-babyl-type-p () (when (re-search-forward "\^_\^L *\n" nil t) t)) @@ -560,8 +605,7 @@ from the document.") (defun nndoc-generate-clari-briefs-head (article) (let ((entry (cdr (assq article nndoc-dissection-alist))) subject from) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (save-restriction (narrow-to-region (car entry) (nth 3 entry)) (goto-char (point-min)) @@ -620,6 +664,30 @@ from the document.") (defun nndoc-slack-digest-type-p () 0) +(defun nndoc-git-type-p () + (and (search-forward "\n- Log ---" nil t) + (search-forward "\ncommit " nil t) + (search-forward "\nAuthor: " nil t))) + +(defun nndoc-transform-git-article (article) + (goto-char (point-min)) + (when (re-search-forward "^Author: " nil t) + (replace-match "From: " t t))) + +(defun nndoc-transform-git-headers (entry) + (goto-char (point-min)) + (when (re-search-forward "^Author: " nil t) + (replace-match "From: " t t)) + (let (subject) + (with-current-buffer nndoc-current-buffer + (goto-char (car entry)) + (when (search-forward "\n\n" nil t) + (setq subject (buffer-substring (point) (line-end-position))))) + (when subject + (goto-char (point-min)) + (forward-line 1) + (insert (format "Subject: %s\n" subject))))) + (defun nndoc-lanl-gov-announce-type-p () (when (let ((case-fold-search nil)) (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t)) @@ -649,8 +717,7 @@ from the document.") (let ((entry (cdr (assq article nndoc-dissection-alist))) (from "<no address given>") subject date) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (save-restriction (narrow-to-region (car entry) (nth 1 entry)) (goto-char (point-min)) @@ -741,7 +808,7 @@ from the document.") (setq p (1+ (nth 3 blk))))) (goto-char begin) (while (re-search-forward "\r$" nil t) - (delete-backward-char 1)) + (delete-char -1)) (when head (goto-char begin) (when (search-forward "\n\n" nil t) @@ -801,12 +868,14 @@ from the document.") (first t) art-begin head-begin head-end body-begin body-end) (setq nndoc-dissection-alist nil) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (goto-char (point-min)) ;; Remove blank lines. (while (eq (following-char) ?\n) (delete-char 1)) + (when nndoc-pre-dissection-function + (save-excursion + (funcall nndoc-pre-dissection-function))) (if nndoc-dissection-function (funcall nndoc-dissection-function) ;; Find the beginning of the file. @@ -849,7 +918,8 @@ from the document.") (setq body-end (point)) (push (list (incf i) head-begin head-end body-begin body-end (count-lines body-begin body-end)) - nndoc-dissection-alist))))))) + nndoc-dissection-alist))))) + (setq nndoc-dissection-alist (nreverse nndoc-dissection-alist)))) (defun nndoc-article-begin () (if nndoc-article-begin-function @@ -871,8 +941,7 @@ When a MIME entity contains sub-entities, dissection produces one article for the header of this entity, and one article per sub-entity." (setq nndoc-dissection-alist nil nndoc-mime-split-ordinal 0) - (save-excursion - (set-buffer nndoc-current-buffer) + (with-current-buffer nndoc-current-buffer (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil))) (defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert @@ -1009,7 +1078,7 @@ as the last checked definition, if t or `first', add as the first definition, and if any other symbol, add after that symbol in the alist." ;; First remove any old instances. - (gnus-pull (car definition) nndoc-type-alist) + (gnus-alist-pull (car definition) nndoc-type-alist) ;; Then enter the new definition in the proper place. (cond ((or (null position) (eq position 'last)) @@ -1025,5 +1094,4 @@ symbol in the alist." (provide 'nndoc) -;; arch-tag: f5c2970e-0387-47ac-a0b3-6cc317dffabe ;;; nndoc.el ends here diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 94dd20b2e1..64f93ee0bc 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -77,10 +77,9 @@ are generated if and only if they are also in `message-draft-headers'.") (deffoo nndraft-retrieve-headers (articles &optional group server fetch-old) (nndraft-possibly-change-group group) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) - (let* (article) + (let (article lines chars) ;; We don't support fetching by Message-ID. (if (stringp (car articles)) 'headers @@ -92,9 +91,12 @@ are generated if and only if they are also in `message-draft-headers'.") (if (search-forward "\n\n" nil t) (forward-line -1) (goto-char (point-max))) + (setq lines (count-lines (point) (point-max)) + chars (- (point-max) (point))) (delete-region (point) (point-max)) (goto-char (point-min)) (insert (format "221 %d Article retrieved.\n" article)) + (insert (format "Lines: %d\nChars: %d\n" lines chars)) (widen) (goto-char (point-max)) (insert ".\n"))) @@ -119,8 +121,7 @@ are generated if and only if they are also in `message-draft-headers'.") mm-text-coding-system) mm-auto-save-coding-system))) (nnmail-find-file newest))) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) ;; If there's a mail header separator in this file, ;; we remove it. @@ -184,7 +185,7 @@ are generated if and only if they are also in `message-draft-headers'.") (add-hook hook 'nndraft-generate-headers nil t)) article)) -(deffoo nndraft-request-group (group &optional server dont-check) +(deffoo nndraft-request-group (group &optional server dont-check info) (nndraft-possibly-change-group group) (unless dont-check (let* ((pathname (nnmail-group-pathname group nndraft-directory)) @@ -202,15 +203,14 @@ are generated if and only if they are also in `message-draft-headers'.") 'nnmh-request-group (list group server dont-check))) -(deffoo nndraft-request-move-article (article group server accept-form +(deffoo nndraft-request-move-article (article group server accept-form &optional last move-is-internal) (nndraft-possibly-change-group group) (let ((buf (get-buffer-create " *nndraft move*")) result) (and (nndraft-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) @@ -222,6 +222,11 @@ are generated if and only if they are also in `message-draft-headers'.") (deffoo nndraft-request-expire-articles (articles group &optional server force) (nndraft-possibly-change-group group) (let* ((nnmh-allow-delete-final t) + (nnmail-expiry-target + (or (gnus-group-find-parameter + (gnus-group-prefixed-name group (list 'nndraft server)) + 'expiry-target t) + nnmail-expiry-target)) (res (nnoo-parent-function 'nndraft 'nnmh-request-expire-articles (list articles group server force))) @@ -313,5 +318,4 @@ are generated if and only if they are also in `message-draft-headers'.") (provide 'nndraft) -;; arch-tag: 3ce26ca0-41cb-48b1-8703-4dad35e188aa ;;; nndraft.el ends here diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index daf4311a91..2f43e34617 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -28,6 +28,7 @@ (eval-when-compile (require 'cl)) +(require 'mailcap) (require 'nnheader) (require 'nnmail) (require 'nnoo) @@ -80,8 +81,7 @@ included.") (deffoo nneething-retrieve-headers (articles &optional group server fetch-old) (nneething-possibly-change-directory group) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((number (length articles)) (count 0) @@ -144,7 +144,7 @@ included.") (insert "\n")) t)))) -(deffoo nneething-request-group (group &optional server dont-check) +(deffoo nneething-request-group (group &optional server dont-check info) (nneething-possibly-change-directory group server) (unless dont-check (nneething-create-mapping) @@ -322,8 +322,7 @@ included.") (if (equal '(0 0) (nth 5 atts)) "" (concat "Date: " (current-time-string (nth 5 atts)) "\n")) (or (when buffer - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) (concat "From: " (match-string 0) "\n")))) (nneething-from-line (nth 2 atts) file)) @@ -331,8 +330,7 @@ included.") (concat "Chars: " (int-to-string (nth 7 atts)) "\n") "") (if buffer - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (concat "Lines: " (int-to-string (count-lines (point-min) (point-max))) "\n")) @@ -381,8 +379,7 @@ included.") (defun nneething-get-head (file) "Either find the head in FILE or make a head for FILE." - (save-excursion - (set-buffer (get-buffer-create nneething-work-buffer)) + (with-current-buffer (get-buffer-create nneething-work-buffer) (setq case-fold-search nil) (buffer-disable-undo) (erase-buffer) @@ -426,5 +423,4 @@ included.") (provide 'nneething) -;; arch-tag: 1277f386-88f2-4459-bb24-f3f45962a6c5 ;;; nneething.el ends here diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index a93f0913e4..a264bc24c1 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -29,7 +29,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -157,8 +157,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnoo-define-basics nnfolder) (deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article start stop num) (nnfolder-possibly-change-group group server) @@ -261,8 +260,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-article (article &optional group server buffer) (nnfolder-possibly-change-group group server) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (goto-char (point-min)) (when (nnfolder-goto-article article) (let (start stop) @@ -291,7 +289,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (point) (point-at-eol))) -1)))))))) -(deffoo nnfolder-request-group (group &optional server dont-check) +(deffoo nnfolder-request-group (group &optional server dont-check info) (nnfolder-possibly-change-group group server t) (save-excursion (cond ((not (assoc group nnfolder-group-alist)) @@ -324,20 +322,20 @@ the group. Then the marks file will be regenerated properly by Gnus.") (when nnfolder-get-new-mail (nnfolder-possibly-change-group group server) (nnmail-get-new-mail - 'nnfolder - (lambda () - (let ((bufs nnfolder-buffer-alist)) - (save-excursion - (while bufs - (if (not (gnus-buffer-live-p (nth 1 (car bufs)))) - (setq nnfolder-buffer-alist - (delq (car bufs) nnfolder-buffer-alist)) - (set-buffer (nth 1 (car bufs))) - (nnfolder-save-buffer) - (kill-buffer (current-buffer))) - (setq bufs (cdr bufs)))))) - nnfolder-directory - group))) + 'nnfolder 'nnfolder-save-all-buffers + nnfolder-directory group))) + +(defun nnfolder-save-all-buffers () + (let ((bufs nnfolder-buffer-alist)) + (save-excursion + (while bufs + (if (not (gnus-buffer-live-p (nth 1 (car bufs)))) + (setq nnfolder-buffer-alist + (delq (car bufs) nnfolder-buffer-alist)) + (set-buffer (nth 1 (car bufs))) + (nnfolder-save-buffer) + (kill-buffer (current-buffer))) + (setq bufs (cdr bufs)))))) ;; Don't close the buffer if we're not shutting down the server. This way, ;; we can keep the buffer in the group buffer cache, and not have to grovel @@ -360,8 +358,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") nnfolder-current-group (car inf)))) (when (and nnfolder-current-buffer (buffer-name nnfolder-current-buffer)) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer ;; If the buffer was modified, write the file out now. (nnfolder-save-buffer) ;; If we're shutting the server down, we need to kill the @@ -447,8 +444,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") target) (nnmail-activate 'nnfolder) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer ;; Since messages are sorted in arrival order and expired in the ;; same order, we can stop as soon as we find a message that is ;; too old. @@ -492,17 +488,17 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnfolder-save-buffer) (nnfolder-adjust-min-active newsgroup) (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) - (gnus-sorted-difference articles (nreverse deleted-articles))))) + (gnus-sorted-difference articles (nreverse deleted-articles))) + (nnfolder-save-all-buffers))) -(deffoo nnfolder-request-move-article (article group server accept-form +(deffoo nnfolder-request-move-article (article group server accept-form &optional last move-is-internal) (save-excursion (let ((buf (get-buffer-create " *nnfolder move*")) result) (and (nnfolder-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) @@ -552,7 +548,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -578,8 +574,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-replace-article (article group buffer) (nnfolder-possibly-change-group group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (goto-char (point-min)) (if (not (looking-at "X-From-Line: ")) (insert "From nobody " (current-time-string) "\n") @@ -596,8 +591,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnfolder-delete-mail) (insert-buffer-substring buffer) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (let ((headers (nnfolder-parse-head article (point-min) (point-max)))) (with-current-buffer (nnfolder-open-nov group) @@ -630,8 +624,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-rename-group (group new-name &optional server) (nnfolder-possibly-change-group group server) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (and (file-writable-p buffer-file-name) (ignore-errors (let ((new-file (nnfolder-group-pathname new-name))) @@ -671,8 +664,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (marker (concat "\n" nnfolder-article-marker)) (number "[0-9]+") (activemin (cdr active))) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (goto-char (point-min)) (while (and (search-forward marker nil t) (re-search-forward number nil t)) @@ -1114,8 +1106,7 @@ This command does not work if you use short group names." (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) (erase-buffer) @@ -1139,8 +1130,7 @@ This command does not work if you use short group names." (setq nnfolder-nov-buffer-alist (cdr nnfolder-nov-buffer-alist))))) (defun nnfolder-nov-delete-article (group article) - (save-excursion - (set-buffer (nnfolder-open-nov group)) + (with-current-buffer (nnfolder-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point)))) t)) @@ -1150,8 +1140,7 @@ This command does not work if you use short group names." nil (let ((nov (nnfolder-group-nov-pathname nnfolder-current-group))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -1187,8 +1176,7 @@ This command does not work if you use short group names." (defun nnfolder-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nnfolder-open-nov group)) + (with-current-buffer (nnfolder-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) @@ -1199,23 +1187,11 @@ This command does not work if you use short group names." (nnfolder-open-server server)) (unless nnfolder-marks-is-evil (nnfolder-open-marks group server) - (dolist (action actions) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) nil - "Unknown request-set-mark action: %s" what) - (dolist (mark marks) - (setq nnfolder-marks (gnus-update-alist-soft - mark - (funcall (if (eq what 'add) 'gnus-range-add - 'gnus-remove-from-range) - (cdr (assoc mark nnfolder-marks)) range) - nnfolder-marks))))) + (setq nnfolder-marks (nnheader-update-marks-actions nnfolder-marks actions)) (nnfolder-save-marks group server)) nil) -(deffoo nnfolder-request-update-info (group info &optional server) +(deffoo nnfolder-request-marks (group info &optional server) ;; Change servers. (when (and server (not (nnfolder-server-opened server))) @@ -1301,5 +1277,4 @@ This command does not work if you use short group names." (provide 'nnfolder) -;; arch-tag: a040d0f4-4f4e-445f-8972-839575c5f7e6 ;;; nnfolder.el ends here diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el index f3a12c5582..ac93620b2a 100644 --- a/lisp/gnus/nngateway.el +++ b/lisp/gnus/nngateway.el @@ -89,5 +89,4 @@ parameter -- the gateway address.") (provide 'nngateway) -;; arch-tag: f7ecb92e-b10c-43d5-9a9b-1314233341fc ;;; nngateway.el ends here diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index a0bd442f11..1c7990b3ef 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -27,6 +27,9 @@ ;;; Code: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (defvar nnmail-extra-headers) @@ -75,7 +78,7 @@ Integer values will in effect be rounded up to the nearest multiple of "*Length of each read operation when trying to fetch HEAD headers.") (defvar nnheader-read-timeout - (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (if (string-match "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) ;; http://thread.gmane.org/[email protected] ;; @@ -100,7 +103,7 @@ Shorter values mean quicker response, but are more CPU intensive.") (defvar nnheader-file-name-translation-alist (let ((case-fold-search t)) (cond - ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" + ((string-match "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) (append (mapcar (lambda (c) (cons c ?_)) '(?: ?* ?\" ?< ?> ??)) @@ -121,7 +124,6 @@ on your system, you could say something like: (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") -(autoload 'message-remove-header "message") (autoload 'gnus-buffer-live-p "gnus-util") ;;; Header access macros. @@ -364,15 +366,13 @@ on your system, you could say something like: (setq num 0 beg (point-min) end (point-max)) - (goto-char (point-min)) ;; Search to the beginning of the next header. Error ;; messages do not begin with 2 or 3. (when (re-search-forward "^[23][0-9]+ " nil t) - (end-of-line) (setq num (read cur) beg (point) end (if (search-forward "\n.\n" nil t) - (- (point) 2) + (goto-char (- (point) 2)) (point))))) (with-temp-buffer (insert-buffer-substring cur beg end) @@ -462,7 +462,7 @@ on your system, you could say something like: (let ((extra (mail-header-extra header))) (while extra (insert (symbol-name (caar extra)) - ": " (cdar extra) "\t") + ": " (if (stringp (cdar extra)) (cdar extra) "") "\t") (pop extra)))) (insert "\n") (backward-char 1) @@ -569,8 +569,6 @@ the line could be found." (defvar nntp-server-buffer nil) (defvar nntp-process-response nil) -(defvar news-reply-yank-from nil) -(defvar news-reply-yank-message-id nil) (defvar nnheader-callback-function nil) @@ -662,8 +660,12 @@ the line could be found." ;; without inserting extra newline. (fill-region-as-paragraph begin (1+ (point)))))) +(declare-function message-remove-header "message" + (header &optional is-regexp first reverse)) + (defun nnheader-replace-header (header new-value) "Remove HEADER and insert the NEW-VALUE." + (require 'message) (save-excursion (save-restriction (nnheader-narrow-to-headers) @@ -781,8 +783,7 @@ If FULL, translate everything." ;; We translate -- but only the file name. We leave the directory ;; alone. (if (and (featurep 'xemacs) - (memq system-type '(cygwin32 win32 w32 mswindows windows-nt - cygwin))) + (memq system-type '(windows-nt cygwin))) ;; This is needed on NT and stuff, because ;; file-name-nondirectory is not enough to split ;; file names, containing ':', e.g. @@ -820,19 +821,22 @@ The first string in ARGS can be a format string." (apply 'format args))) nil) -(defun nnheader-get-report (backend) +(defun nnheader-get-report-string (backend) "Get the most recent report from BACKEND." (condition-case () - (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" - backend)))) - (error (nnheader-message 5 "")))) + (format "%s" (symbol-value (intern (format "%s-status-string" + backend)))) + (error ""))) + +(defun nnheader-get-report (backend) + "Get the most recent report from BACKEND." + (nnheader-message 5 (nnheader-get-report-string backend))) (defun nnheader-insert (format &rest args) "Clear the communication buffer and insert FORMAT and ARGS into the buffer. If FORMAT isn't a format string, it and all ARGS will be inserted without formatting." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (if (string-match "%" format) (insert (apply 'format format args)) @@ -1074,6 +1078,26 @@ See `find-file-noselect' for the arguments." (truncate nnheader-read-timeout)) 1000)))) +(defun nnheader-update-marks-actions (backend-marks actions) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (dolist (mark marks) + (setq backend-marks + (gnus-update-alist-soft + mark + (cond + ((eq what 'add) + (gnus-range-add (cdr (assoc mark backend-marks)) range)) + ((eq what 'del) + (gnus-remove-from-range + (cdr (assoc mark backend-marks)) range)) + ((eq what 'set) + range)) + backend-marks))))) + backend-marks) + (when (featurep 'xemacs) (require 'nnheaderxm)) @@ -1081,5 +1105,4 @@ See `find-file-noselect' for the arguments." (provide 'nnheader) -;; arch-tag: a9c4b7d9-52ae-4ec9-b196-dfd93124d202 ;;; nnheader.el ends here diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 1e2a9da244..0c711701e9 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1,11 +1,9 @@ -;;; nnimap.el --- imap backend for Gnus +;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. -;; Author: Simon Josefsson <[email protected]> -;; Jim Radford <[email protected]> -;; Keywords: mail +;; Author: Lars Magne Ingebrigtsen <[email protected]> +;; Simon Josefsson <[email protected]> ;; This file is part of GNU Emacs. @@ -24,1784 +22,1821 @@ ;;; Commentary: -;; Todo, major things: -;; -;; o Fix Gnus to view correct number of unread/total articles in group buffer -;; o Fix Gnus to handle leading '.' in group names (fixed?) -;; o Finish disconnected mode (moving articles between mailboxes unplugged) -;; o Sieve -;; o MIME (partial article fetches) -;; o Split to other backends, different split rules for different -;; servers/inboxes -;; -;; Todo, minor things: -;; -;; o Don't require half of Gnus -- backends should be standalone -;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B) -;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow) -;; o Split up big fetches (1,* header especially) in smaller chunks -;; o What do I do with gnus-newsgroup-*? -;; o Tell Gnus about new groups (how can we tell?) -;; o Respooling (fix Gnus?) (unnecessary?) -;; o Add support for the following: (if applicable) -;; request-list-newsgroups, request-regenerate -;; list-active-group, -;; request-associate-buffer, request-restore-buffer, -;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?) -;; o Support RFC2221 (Login referrals) -;; o IMAP2BIS compatibility? (RFC2061) -;; o ACAP stuff (perhaps a different project, would be nice to ACAPify -;; .newsrc.eld) -;; o What about Gnus's article editing, can we support it? NO! -;; o Use \Draft to support the draft group?? -;; o Duplicate suppression -;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers +;; nnimap interfaces Gnus with IMAP servers. ;;; Code: -(require 'imap) -(require 'nnoo) -(require 'nnmail) +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + +(eval-and-compile + (require 'nnheader)) + +(eval-when-compile + (require 'cl)) + (require 'nnheader) -(require 'mm-util) +(require 'gnus-util) (require 'gnus) -(require 'gnus-range) -(require 'gnus-start) -(require 'gnus-int) - -(eval-when-compile (require 'cl)) +(require 'nnoo) +(require 'netrc) +(require 'utf7) +(require 'tls) +(require 'parse-time) +(require 'nnmail) +(require 'proto-stream) +(autoload 'auth-source-forget-user-or-password "auth-source") (autoload 'auth-source-user-or-password "auth-source") (nnoo-declare nnimap) -(defconst nnimap-version "nnimap 1.0") - -(defgroup nnimap nil - "Reading IMAP mail with Gnus." - :group 'gnus) - (defvoo nnimap-address nil - "Address of physical IMAP server. If nil, use the virtual server's name.") + "The address of the IMAP server.") (defvoo nnimap-server-port nil - "Port number on physical IMAP server. -If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.") - -;; Splitting variables - -(defcustom nnimap-split-crosspost t - "If non-nil, do crossposting if several split methods match the mail. -If nil, the first match found will be used." - :group 'nnimap - :type 'boolean) - -(defcustom nnimap-split-inbox nil - "Name of mailbox to split mail from. - -Mail is read from this mailbox and split according to rules in -`nnimap-split-rule'. - -This can be a string or a list of strings." - :group 'nnimap - :type '(choice (string) - (repeat string))) - -(define-widget 'nnimap-strict-function 'function - "This widget only matches values that are functionp. - -Warning: This means that a value that is the symbol of a not yet -loaded function will not match. Use with care." - :match 'nnimap-strict-function-match) - -(defun nnimap-strict-function-match (widget value) - "Ignoring WIDGET, match if VALUE is a function." - (functionp value)) - -(defcustom nnimap-split-rule nil - "Mail will be split according to these rules. - -Mail is read from mailbox(es) specified in `nnimap-split-inbox'. - -If you'd like, for instance, one mail group for mail from the -\"gnus-imap\" mailing list, one group for junk mail and leave -everything else in the incoming mailbox, you could do something like -this: - -\(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\") - (\"INBOX.junk\" \"Subject:.*buy\"))) - -As you can see, `nnimap-split-rule' is a list of lists, where the -first element in each \"rule\" is the name of the IMAP mailbox (or the -symbol `junk' if you want to remove the mail), and the second is a -regexp that nnimap will try to match on the header to find a fit. - -The second element can also be a function. In that case, it will be -called narrowed to the headers with the first element of the rule as -the argument. It should return a non-nil value if it thinks that the -mail belongs in that group. - -This variable can also have a function as its value, the function will -be called with the headers narrowed and should return a group where it -thinks the article should be splitted to. See `nnimap-split-fancy'. - -To allow for different split rules on different virtual servers, and -even different split rules in different inboxes on the same server, -the syntax of this variable have been extended along the lines of: - -\(setq nnimap-split-rule - '((\"my1server\" (\".*\" ((\"ding\" \"[email protected]\") - (\"junk\" \"From:.*Simon\"))) - (\"my2server\" (\"INBOX\" nnimap-split-fancy)) - (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\") - (\"junk\" my-junk-func))))) - -The virtual server name is in fact a regexp, so that the same rules -may apply to several servers. In the example, the servers -\"my3server\" and \"my4server\" both use the same rules. Similarly, -the inbox string is also a regexp. The actual splitting rules are as -before, either a function, or a list with group/regexp or -group/function elements." - :group 'nnimap - ;; FIXME: Doesn't allow `("my2server" ("INBOX" nnimap-split-fancy))' - ;; per example above. -- fx - :type '(choice :tag "Rule type" - (repeat :menu-tag "Single-server" - :tag "Single-server list" - (list (string :tag "Mailbox") - (choice :tag "Predicate" - (regexp :tag "A regexp") - (nnimap-strict-function :tag "A function")))) - (choice :menu-tag "A function" - :tag "A function" - (function-item nnimap-split-fancy) - (function-item nnmail-split-fancy) - (nnimap-strict-function :tag "User-defined function")) - (repeat :menu-tag "Multi-server (extended)" - :tag "Multi-server list" - (list (regexp :tag "Server regexp") - (list (regexp :tag "Incoming Mailbox regexp") - (repeat :tag "Rules for matching server(s) and mailbox(es)" - (list (string :tag "Destination mailbox") - (choice :tag "Predicate" - (regexp :tag "A Regexp") - (nnimap-strict-function :tag "A Function"))))))))) - -(defcustom nnimap-split-predicate "UNSEEN UNDELETED" - "The predicate used to find articles to split. -If you use another IMAP client to peek on articles but always would -like nnimap to split them once it's started, you could change this to -\"UNDELETED\". Other available predicates are available in -RFC2060 section 6.4.4." - :group 'nnimap - :type 'string) - -(defcustom nnimap-split-fancy nil - "Like the variable `nnmail-split-fancy'." - :group 'nnimap - :type 'sexp) + "The IMAP port used. +If nnimap-stream is `ssl', this will default to `imaps'. If not, +it will default to `imap'.") -(defvar nnimap-split-download-body-default nil - "Internal variable with default value for `nnimap-split-download-body'.") +(defvoo nnimap-stream 'undecided + "How nnimap will talk to the IMAP server. +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) + (car imap-shell-program) + imap-shell-program) + "ssh %s imapd")) + +(defvoo nnimap-inbox nil + "The mail box where incoming mail arrives and should be split out of.") + +(defvoo nnimap-split-methods nil + "How mail is split. +Uses the same syntax as nnmail-split-methods") -(defcustom nnimap-split-download-body 'default - "Whether to download entire articles during splitting. -This is generally not required, and will slow things down considerably. -You may need it if you want to use an advanced splitting function that -analyzes the body before splitting the article. -If this variable is nil, bodies will not be downloaded; if this -variable is the symbol `default' the default behavior is -used (which currently is nil, unless you use a statistical -spam.el test); if this variable is another non-nil value bodies -will be downloaded." - :version "22.1" - :group 'nnimap - :type '(choice (const :tag "Let system decide" deault) - boolean)) - -;; Performance / bug workaround variables - -(defcustom nnimap-close-asynchronous t - "Close mailboxes asynchronously in `nnimap-close-group'. -This means that errors caught by nnimap when closing the mailbox will -not prevent Gnus from updating the group status, which may be harmful. -However, it increases speed." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defcustom nnimap-dont-close t - "Never close mailboxes. -This increases the speed of closing mailboxes (quiting group) but may -decrease the speed of selecting another mailbox later. Re-selecting -the same mailbox will be faster though." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defcustom nnimap-retrieve-groups-asynchronous t - "Send asynchronous STATUS commands for each mailbox before checking mail. -If you have mailboxes that rarely receives mail, this speeds up new -mail checking. It works by first sending STATUS commands for each -mailbox, and then only checking groups which has a modified UIDNEXT -more carefully for new mail. - -In summary, the default is O((1-p)*k+p*n) and changing it to nil makes -it O(n). If p is small, then the default is probably faster." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defvoo nnimap-need-unselect-to-notice-new-mail t - "Unselect mailboxes before looking for new mail in them. -Some servers seem to need this under some circumstances.") - -(defvoo nnimap-logout-timeout nil - "Close server immediately if it can't logout in this number of seconds. -If it is nil, never close server until logout completes. This variable -overrides `imap-logout-timeout' on a per-server basis.") - -;; Authorization / Privacy variables - -(defvoo nnimap-auth-method nil - "Obsolete.") - -(defvoo nnimap-stream nil - "How nnimap will connect to the server. - -The default, nil, will try to use the \"best\" method the server can -handle. - -Change this if - -1) you want to connect with TLS/SSL. The TLS/SSL integration - with IMAP is suboptimal so you'll have to tell it - specifically. - -2) your server is more capable than your environment -- i.e. your - server accept Kerberos login's but you haven't installed the - `imtest' program or your machine isn't configured for Kerberos. - -Possible choices: gssapi, kerberos4, starttls, tls, ssl, network, shell. -See also `imap-streams' and `imap-stream-alist'.") +(defvoo nnimap-split-fancy nil + "Uses the same syntax as nnmail-split-fancy.") + +(defvoo nnimap-unsplittable-articles '(%Deleted %Seen) + "Articles with the flags in the list will not be considered when splitting.") + +(make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'" + "Emacs 24.1") (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. +Possible choices are nil (use default methods) or `anonymous'.") -The default, nil, will try to use the \"best\" method the server can -handle. - -There is only one reason for fiddling with this variable, and that is -if your server is more capable than your environment -- i.e. you -connect to a server that accept Kerberos login's but you haven't -installed the `imtest' program or your machine isn't configured for -Kerberos. - -Possible choices: gssapi, kerberos4, digest-md5, cram-md5, login, anonymous. -See also `imap-authenticators' and `imap-authenticator-alist'") - -(defvoo nnimap-directory (nnheader-concat gnus-directory "overview/") - "Directory to keep NOV cache files for nnimap groups. -See also `nnimap-nov-file-name'.") - -(defvoo nnimap-nov-file-name "nnimap." - "NOV cache base filename. -The group name and `nnimap-nov-file-name-suffix' will be appended. A -typical complete file name would be -~/News/overview/nnimap.pdc.INBOX.ding.nov, or -~/News/overview/nnimap/pdc/INBOX/ding/nov if -`nnmail-use-long-file-names' is nil") - -(defvoo nnimap-nov-file-name-suffix ".novcache" - "Suffix for NOV cache base filename.") - -(defvoo nnimap-nov-is-evil gnus-agent - "If non-nil, never generate or use a local nov database for this backend. -Using nov databases should speed up header fetching considerably. -However, it will invoke a UID SEARCH UID command on the server, and -some servers implement this command inefficiently by opening each and -every message in the group, thus making it quite slow. -Unlike other backends, you do not need to take special care if you -flip this variable.") - -(defvoo nnimap-search-uids-not-since-is-evil nil - "If non-nil, avoid \"UID SEARCH UID ... NOT SINCE\" queries when expiring. -Instead, use \"UID SEARCH SINCE\" to prune the list of expirable -articles within Gnus. This seems to be faster on Courier in some cases.") - -(defvoo nnimap-expunge-on-close 'always ; 'ask, 'never - "Whether to expunge a group when it is closed. -When a IMAP group with articles marked for deletion is closed, this -variable determine if nnimap should actually remove the articles or -not. - -If always, nnimap always perform a expunge when closing the group. -If never, nnimap never expunges articles marked for deletion. -If ask, nnimap will ask you if you wish to expunge marked articles. - -When setting this variable to `never', you can only expunge articles -by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.") - -(defvoo nnimap-list-pattern "*" - "A string LIMIT or list of strings with mailbox wildcards used to limit available groups. -See below for available wildcards. - -The LIMIT string can be a cons cell (REFERENCE . LIMIT), where -REFERENCE will be passed as the first parameter to LIST/LSUB. The -semantics of this are server specific, on the University of Washington -server you can specify a directory. - -Example: - '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\")) - -There are two wildcards * and %. * matches everything, % matches -everything in the current hierarchy.") - -(defvoo nnimap-news-groups nil - "IMAP support a news-like mode, also known as bulletin board mode, -where replies is sent via IMAP instead of SMTP. - -This variable should contain a regexp matching groups where you wish -replies to be stored to the mailbox directly. - -Example: - '(\"^[^I][^N][^B][^O][^X].*$\") - -This will match all groups not beginning with \"INBOX\". - -Note that there is nothing technically different between mail-like and -news-like mailboxes. If you wish to have a group with todo items or -similar which you wouldn't want to set up a mailing list for, you can -use this to make replies go directly to the group.") - -(defvoo nnimap-expunge-search-string "UID %s NOT SINCE %s" - "IMAP search command to use for articles that are to be expired. -The first %s is replaced by a UID set of articles to search on, -and the second %s is replaced by a date criterium. - -One useful (and perhaps the only useful) value to change this to would -be `UID %s NOT SENTSINCE %s' to make nnimap use the Date: header -instead of the internal date of messages. See section 6.4.4 of RFC -2060 for more information on valid strings. - -However, if `nnimap-search-uids-not-since-is-evil' is true, this -variable has no effect since the search logic is reversed.") - -(defvoo nnimap-importantize-dormant t - "If non-nil, mark \"dormant\" articles as \"ticked\" for other IMAP clients. -Note that within Gnus, dormant articles will still (only) be -marked as ticked. This is to make \"dormant\" articles stand out, -just like \"ticked\" articles, in other IMAP clients.") - -(defvoo nnimap-server-address nil - "Obsolete. Use `nnimap-address'.") - -(defcustom nnimap-authinfo-file "~/.authinfo" - "Authorization information for IMAP servers. In .netrc format." - :type - '(choice file - (repeat :tag "Entries" - :menu-tag "Inline" - (list :format "%v" - :value ("" ("login" . "") ("password" . "")) - (string :tag "Host") - (checklist :inline t - (cons :format "%v" - (const :format "" "login") - (string :format "Login: %v")) - (cons :format "%v" - (const :format "" "password") - (string :format "Password: %v")))))) - :group 'nnimap) - -(defcustom nnimap-prune-cache t - "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache." - :type 'boolean - :group 'nnimap) - -(defvar nnimap-request-list-method 'imap-mailbox-list - "Method to use to request a list of all folders from the server. -If this is 'imap-mailbox-lsub, then use a server-side subscription list to -restrict visible folders.") - -(defcustom nnimap-id nil - "Plist with client identity to send to server upon login. -A nil value means no information is sent, symbol `no' to disable ID query -altogether, or plist with identifier-value pairs to send to -server. RFC 2971 describes the list as follows: - - Any string may be sent as a field, but the following are defined to - describe certain values that might be sent. Implementations are free - to send none, any, or all of these. Strings are not case-sensitive. - Field strings MUST NOT be longer than 30 octets. Value strings MUST - NOT be longer than 1024 octets. Implementations MUST NOT send more - than 30 field-value pairs. - - name Name of the program - version Version number of the program - os Name of the operating system - os-version Version of the operating system - vendor Vendor of the client/server - support-url URL to contact for support - address Postal address of contact/vendor - date Date program was released, specified as a date-time - in IMAP4rev1 - command Command used to start the program - arguments Arguments supplied on the command line, if any - if any - environment Description of environment, i.e., UNIX environment - variables or Windows registry settings - - Implementations MUST NOT send the same field name more than once. - -An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number -\"os\" system-configuration \"vendor\" \"GNU\")." - :group 'nnimap - :type '(choice (const :tag "No information" nil) - (const :tag "Disable ID query" no) - (plist :key-type string :value-type string))) - -(defcustom nnimap-debug nil - "If non-nil, trace nnimap- functions into `nnimap-debug-buffer'. -Uses `trace-function-background', so you can turn it off with, -say, `untrace-all'. - -Note that username, passwords and other privacy sensitive -information (such as e-mail) may be stored in the buffer. -It is not written to disk, however. Do not enable this -variable unless you are comfortable with that. - -This variable only takes effect when loading the `nnimap' library. -See also `nnimap-log'." - :group 'nnimap - :type 'boolean) - -;; Internal variables: - -(defvar nnimap-debug-buffer "*nnimap-debug*") -(defvar nnimap-mailbox-info (gnus-make-hashtable 997)) -(defvar nnimap-current-move-server nil) -(defvar nnimap-current-move-group nil) -(defvar nnimap-current-move-article nil) -(defvar nnimap-length) -(defvar nnimap-progress-chars '(?| ?/ ?- ?\\)) -(defvar nnimap-progress-how-often 20) -(defvar nnimap-counter) -(defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. -(defvar nnimap-current-server nil) ;; Current server -(defvar nnimap-server-buffer nil) ;; Current servers' buffer - - - -(nnoo-define-basics nnimap) - -;; Utility functions: - -(defsubst nnimap-get-server-buffer (server) - "Return buffer for SERVER, if nil use current server." - (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist))) - -(defun nnimap-remove-server-from-buffer-alist (server list) - "Remove SERVER from LIST." - (let (l) - (dolist (e list) - (unless (equal server (car-safe e)) - (push e l))) - l)) - -(defun nnimap-possibly-change-server (server) - "Return buffer for SERVER, changing the current server as a side-effect. -If SERVER is nil, uses the current server." - (setq nnimap-current-server (or server nnimap-current-server) - nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server))) - -(defun nnimap-verify-uidvalidity (group server) - "Verify stored uidvalidity match current one in GROUP on SERVER." - (let* ((gnusgroup (gnus-group-prefixed-name - group (gnus-server-to-method - (format "nnimap:%s" server)))) - (new-uidvalidity (imap-mailbox-get 'uidvalidity)) - (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)) - (dir (file-name-as-directory (expand-file-name nnimap-directory))) - (nameuid (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group "." old-uidvalidity - nnimap-nov-file-name-suffix) t)) - (file (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name nameuid dir))) - (expand-file-name nameuid dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string nameuid ?. ?/) - nnmail-pathname-coding-system) - dir)))) - (if old-uidvalidity - (if (not (equal old-uidvalidity new-uidvalidity)) - ;; uidvalidity clash - (gnus-delete-file file) - (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity) - t) - (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity)) - t))) +(defvoo nnimap-expunge t + "If non-nil, expunge articles after deleting them. +This is always done if the server supports UID EXPUNGE, but it's +not done by default on servers that doesn't support that command.") -(defun nnimap-before-find-minmax-bugworkaround () - "Function called before iterating through mailboxes with -`nnimap-find-minmax-uid'." - (when nnimap-need-unselect-to-notice-new-mail - ;; XXX this is for UoW imapd problem, it doesn't notice new mail in - ;; currently selected mailbox without a re-select/examine. - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)))) - -(defun nnimap-find-minmax-uid (group &optional examine) - "Find lowest and highest active article number in GROUP. -If EXAMINE is non-nil the group is selected read-only." - (with-current-buffer nnimap-server-buffer - (when (or (string= group (imap-current-mailbox)) - (imap-mailbox-select group examine)) - (let (minuid maxuid) - (when (> (imap-mailbox-get 'exists) 0) - (imap-fetch-safe '("1,*" . "1,*:*") "UID" nil 'nouidfetch) - (imap-message-map (lambda (uid Uid) - (setq minuid (if minuid (min minuid uid) uid) - maxuid (if maxuid (max maxuid uid) uid))) - 'UID)) - (list (imap-mailbox-get 'exists) minuid maxuid))))) - -(defun nnimap-possibly-change-group (group &optional server) - "Make GROUP the current group, and SERVER the current server." - (when (nnimap-possibly-change-server server) - (with-current-buffer nnimap-server-buffer - (if (or (null group) (imap-current-mailbox-p group)) - imap-current-mailbox - (if (imap-mailbox-select group) - (if (or (nnimap-verify-uidvalidity - group (or server nnimap-current-server)) - (zerop (imap-mailbox-get 'exists group)) - t ;; for OGnus to see if ignoring uidvalidity - ;; changes has any bad effects. - (yes-or-no-p - (format - "nnimap: Group %s is not uidvalid. Continue? " group))) - imap-current-mailbox - (imap-mailbox-unselect) - (error "nnimap: Group %s is not uid-valid" group)) - (nnheader-report 'nnimap (imap-error-text))))))) - -(defun nnimap-replace-whitespace (string) - "Return STRING with all whitespace replaced with space." - (when string - (while (string-match "[\r\n\t]+" string) - (setq string (replace-match " " t t string))) - string)) - -;; Required backend functions - -(defun nnimap-retrieve-headers-progress () - "Hook to insert NOV line for current article into `nntp-server-buffer'." - (and (numberp nnmail-large-newsgroup) - (zerop (% (incf nnimap-counter) nnimap-progress-how-often)) - (> nnimap-length nnmail-large-newsgroup) - (nnheader-message 6 "nnimap: Retrieving headers... %c" - (nth (/ (% nnimap-counter - (* (length nnimap-progress-chars) - nnimap-progress-how-often)) - nnimap-progress-how-often) - nnimap-progress-chars))) - (with-current-buffer nntp-server-buffer - (let (headers lines chars uid mbx) - (with-current-buffer nnimap-server-buffer - (setq uid imap-current-message - mbx imap-current-mailbox - headers (if (imap-capability 'IMAP4rev1) - ;; xxx don't just use car? alist doesn't contain - ;; anything else now, but it might... - (nth 2 (car (imap-message-get uid 'BODYDETAIL))) - (imap-message-get uid 'RFC822.HEADER)) - lines (imap-body-lines (imap-message-body imap-current-message)) - chars (imap-message-get imap-current-message 'RFC822.SIZE))) - (nnheader-insert-nov - ;; At this stage, we only have bytes, so let's use unibyte buffers - ;; to make it more clear. - (mm-with-unibyte-buffer - (buffer-disable-undo) - ;; headers can be nil if article is write-only - (when headers (insert headers)) - (let ((head (nnheader-parse-naked-head uid))) - (mail-header-set-number head uid) - (mail-header-set-chars head chars) - (mail-header-set-lines head lines) - (mail-header-set-xref - head (format "%s %s:%d" (system-name) mbx uid)) - head)))))) - -(defun nnimap-retrieve-which-headers (articles fetch-old) - "Get a range of articles to fetch based on ARTICLES and FETCH-OLD." - (with-current-buffer nnimap-server-buffer - (if (numberp (car-safe articles)) - (imap-search - (concat "UID " - (imap-range-to-message-set - (gnus-compress-sequence - (append (gnus-uncompress-sequence - (and fetch-old - (cons (if (numberp fetch-old) - (max 1 (- (car articles) fetch-old)) - 1) - (1- (car articles))))) - articles))))) - (mapcar (lambda (msgid) - (imap-search - (format "HEADER Message-Id \"%s\"" msgid))) - articles)))) - -(defun nnimap-group-overview-filename (group server) - "Make file name for GROUP on SERVER." - (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) - (uidvalidity (gnus-group-get-parameter - (gnus-group-prefixed-name - group (gnus-server-to-method - (format "nnimap:%s" server))) - 'uidvalidity)) - (name (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group nnimap-nov-file-name-suffix) t)) - (nameuid (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group "." uidvalidity - nnimap-nov-file-name-suffix) t)) - (oldfile (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name name dir))) - (expand-file-name name dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string name ?. ?/) - nnmail-pathname-coding-system) - dir))) - (newfile (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name nameuid dir))) - (expand-file-name nameuid dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string nameuid ?. ?/) - nnmail-pathname-coding-system) - dir)))) - (when (and (file-exists-p oldfile) (not (file-exists-p newfile))) - (message "nnimap: Upgrading novcache filename...") - (sit-for 1) - (gnus-make-directory (file-name-directory newfile)) - (unless (ignore-errors (rename-file oldfile newfile) t) - (if (ignore-errors (copy-file oldfile newfile) t) - (delete-file oldfile) - (error "Can't rename `%s' to `%s'" oldfile newfile)))) - newfile)) - -(defun nnimap-retrieve-headers-from-file (group server) - (with-current-buffer nntp-server-buffer - (let ((nov (nnimap-group-overview-filename group server))) - (when (file-exists-p nov) - (mm-insert-file-contents nov) - (set-buffer-modified-p nil) - (let ((min (ignore-errors (goto-char (point-min)) - (read (current-buffer)))) - (max (ignore-errors (goto-char (point-max)) - (forward-line -1) - (read (current-buffer))))) - (if (and (numberp min) (numberp max)) - (cons min max) - ;; junk, remove it, it's saved later - (erase-buffer) - nil)))))) - -(defun nnimap-retrieve-headers-from-server (articles group server) - (with-current-buffer nnimap-server-buffer - (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress)) - (nnimap-length (gnus-range-length articles)) - (nnimap-counter 0)) - (imap-fetch (imap-range-to-message-set articles) - (concat "(UID RFC822.SIZE BODY " - (let ((headers - (append '(Subject From Date Message-Id - References In-Reply-To Xref) - (copy-sequence - nnmail-extra-headers)))) - (if (imap-capability 'IMAP4rev1) - (format "BODY.PEEK[HEADER.FIELDS %s])" headers) - (format "RFC822.HEADER.LINES %s)" headers))))) - (with-current-buffer nntp-server-buffer - (sort-numeric-fields 1 (point-min) (point-max))) - (and (numberp nnmail-large-newsgroup) - (> nnimap-length nnmail-large-newsgroup) - (nnheader-message 6 "nnimap: Retrieving headers...done"))))) - -(defun nnimap-dont-use-nov-p (group server) - (or gnus-nov-is-evil nnimap-nov-is-evil - (unless (and (gnus-make-directory - (file-name-directory - (nnimap-group-overview-filename group server))) - (file-writable-p - (nnimap-group-overview-filename group server))) - (message "nnimap: Nov cache not writable, %s" - (nnimap-group-overview-filename group server))))) +(defvoo nnimap-streaming t + "If non-nil, try to use streaming commands with IMAP servers. +Switching this off will make nnimap slower, but it helps with +some servers.") + +(defvoo nnimap-connection-alist nil) + +(defvoo nnimap-current-infos nil) + +(defvoo nnimap-fetch-partial-articles nil + "If non-nil, Gnus will fetch partial articles. +If t, nnimap will fetch only the first part. If a string, it +will fetch all parts that have types that match that string. A +likely value would be \"text/\" to automatically fetch all +textual parts.") + +(defvar nnimap-process nil) + +(defvar nnimap-status-string "") + +(defvar nnimap-split-download-body-default nil + "Internal variable with default value for `nnimap-split-download-body'.") + +(defvar nnimap-keepalive-timer nil) +(defvar nnimap-process-buffers nil) + +(defstruct nnimap + group process commands capabilities select-result newlinep server + last-command-time greeting examined) + +(defvar nnimap-object nil) + +(defvar nnimap-mark-alist + '((read "\\Seen" %Seen) + (tick "\\Flagged" %Flagged) + (reply "\\Answered" %Answered) + (expire "gnus-expire") + (dormant "gnus-dormant") + (score "gnus-score") + (save "gnus-save") + (download "gnus-download") + (forward "gnus-forward"))) + +(defvar nnimap-quirks + '(("QRESYNC" "Zimbra" "QRESYNC "))) + +(defun nnimap-buffer () + (nnimap-find-process-buffer nntp-server-buffer)) + +(defun nnimap-header-parameters () + (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" + (format + (if (nnimap-ver4-p) + "BODY.PEEK[HEADER.FIELDS %s]" + "RFC822.HEADER.LINES %s") + (append '(Subject From Date Message-Id + References In-Reply-To Xref) + nnmail-extra-headers)))) (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) - (when (nnimap-possibly-change-group group server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (if (nnimap-dont-use-nov-p group server) - (nnimap-retrieve-headers-from-server - (gnus-compress-sequence articles) group server) - (let (uids cached low high) - (when (setq uids (nnimap-retrieve-which-headers articles fetch-old) - low (car uids) - high (car (last uids))) - (if (setq cached (nnimap-retrieve-headers-from-file group server)) - (progn - ;; fetch articles with uids before cache block - (when (< low (car cached)) - (goto-char (point-min)) - (nnimap-retrieve-headers-from-server - (cons low (1- (car cached))) group server)) - ;; fetch articles with uids after cache block - (when (> high (cdr cached)) - (goto-char (point-max)) - (nnimap-retrieve-headers-from-server - (cons (1+ (cdr cached)) high) group server)) - (when nnimap-prune-cache - ;; remove nov's for articles which has expired on server - (goto-char (point-min)) - (dolist (uid (gnus-set-difference articles uids)) - (when (re-search-forward (format "^%d\t" uid) nil t) - (gnus-delete-line))))) - ;; nothing cached, fetch whole range from server - (nnimap-retrieve-headers-from-server - (cons low high) group server)) - (when (buffer-modified-p) - (nnmail-write-region - (point-min) (point-max) - (nnimap-group-overview-filename group server) nil 'nomesg)) - (nnheader-nov-delete-outside-range low high)))) - 'nov))) - -(defun nnimap-open-connection (server) - ;; Note: `nnimap-open-server' that calls this function binds - ;; `imap-logout-timeout' to `nnimap-logout-timeout'. - (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream - nnimap-authenticator nnimap-server-buffer)) - (nnheader-report 'nnimap "Can't open connection to server %s" server) - (unless (or (imap-capability 'IMAP4 nnimap-server-buffer) - (imap-capability 'IMAP4rev1 nnimap-server-buffer)) - (imap-close nnimap-server-buffer) - (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server)) - (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'." - nnimap-authinfo-file) - (netrc-parse nnimap-authinfo-file))) - (port (if nnimap-server-port - (int-to-string nnimap-server-port) - "imap")) - (auth-info - (auth-source-user-or-password '("login" "password") server port)) - (auth-user (nth 0 auth-info)) - (auth-passwd (nth 1 auth-info)) - (user (or - auth-user ; this is preferred to netrc-* - (netrc-machine-user-or-password - "login" - list - (list server - (or nnimap-server-address - nnimap-address)) - (list port) - (list "imap" "imaps" "143" "993")))) - (passwd (or - auth-passwd ; this is preferred to netrc-* - (netrc-machine-user-or-password - "password" - list - (list server - (or nnimap-server-address - nnimap-address)) - (list port) - (list "imap" "imaps" "143" "993"))))) - (if (imap-authenticate user passwd nnimap-server-buffer) - (prog2 - (setq nnimap-server-buffer-alist - (nnimap-remove-server-from-buffer-alist - server - nnimap-server-buffer-alist)) - (push (list server nnimap-server-buffer) - nnimap-server-buffer-alist) - (imap-id nnimap-id nnimap-server-buffer) - (nnimap-possibly-change-server server)) - (imap-close nnimap-server-buffer) - (kill-buffer nnimap-server-buffer) - (nnheader-report 'nnimap "Could not authenticate to %s" server))))) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (nnimap-wait-for-response + (nnimap-send-command + "UID FETCH %s %s" + (nnimap-article-ranges (gnus-compress-sequence articles)) + (nnimap-header-parameters)) + t) + (nnimap-transform-headers) + (nnheader-remove-cr-followed-by-lf)) + (insert-buffer-substring + (nnimap-find-process-buffer (current-buffer)))) + 'headers)) + +(defun nnimap-transform-headers () + (goto-char (point-min)) + (let (article bytes lines size string) + (block nil + (while (not (eobp)) + (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (delete-region (point) (progn (forward-line 1) (point))) + (when (eobp) + (return))) + (setq article (match-string 1)) + ;; Unfold quoted {number} strings. + (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n" + (1+ (line-end-position)) t) + (setq size (string-to-number (match-string 1))) + (delete-region (+ (match-beginning 0) 2) (point)) + (setq string (buffer-substring (point) (+ (point) size))) + (delete-region (point) (+ (point) size)) + (insert (format "%S" string))) + (setq bytes (nnimap-get-length) + lines nil) + (beginning-of-line) + (setq size + (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" + (line-end-position) + t) + (match-string 1))) + (beginning-of-line) + (when (search-forward "BODYSTRUCTURE" (line-end-position) t) + (let ((structure (ignore-errors + (read (current-buffer))))) + (while (and (consp structure) + (not (stringp (car structure)))) + (setq structure (car structure))) + (setq lines (nth 7 structure)))) + (delete-region (line-beginning-position) (line-end-position)) + (insert (format "211 %s Article retrieved." article)) + (forward-line 1) + (when size + (insert (format "Chars: %s\n" size))) + (when lines + (insert (format "Lines: %s\n" lines))) + (unless (re-search-forward "^\r$" nil t) + (goto-char (point-max))) + (delete-region (line-beginning-position) (line-end-position)) + (insert ".") + (forward-line 1))))) + +(defun nnimap-unfold-quoted-lines () + ;; Unfold quoted {number} strings. + (let (size string) + (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t) + (setq size (string-to-number (match-string 1))) + (delete-region (1+ (match-beginning 0)) (point)) + (setq string (buffer-substring (point) (+ (point) size))) + (delete-region (point) (+ (point) size)) + (insert (format "%S" string))))) + +(defun nnimap-get-length () + (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t) + (string-to-number (match-string 1)))) + +(defun nnimap-article-ranges (ranges) + (let (result) + (cond + ((numberp ranges) + (number-to-string ranges)) + ((numberp (cdr ranges)) + (format "%d:%d" (car ranges) (cdr ranges))) + (t + (dolist (elem ranges) + (push + (if (consp elem) + (format "%d:%d" (car elem) (cdr elem)) + (number-to-string elem)) + result)) + (mapconcat #'identity (nreverse result) ","))))) (deffoo nnimap-open-server (server &optional defs) - (nnheader-init-server-buffer) (if (nnimap-server-opened server) t - (unless (assq 'nnimap-server-buffer defs) - (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs)) - ;; translate `nnimap-server-address' to `nnimap-address' in defs - ;; for people that configured nnimap with a very old version (unless (assq 'nnimap-address defs) - (if (assq 'nnimap-server-address defs) - (push (list 'nnimap-address - (cadr (assq 'nnimap-server-address defs))) defs) - (push (list 'nnimap-address server) defs))) + (setq defs (append defs (list (list 'nnimap-address server))))) (nnoo-change-server 'nnimap server defs) - (or nnimap-server-buffer - (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs)))) - (with-current-buffer (get-buffer-create nnimap-server-buffer) - (nnoo-change-server 'nnimap server defs)) - (let ((imap-logout-timeout nnimap-logout-timeout)) - (or (and nnimap-server-buffer - (imap-opened nnimap-server-buffer) - (if (with-current-buffer nnimap-server-buffer - (memq imap-state '(auth selected examine))) - t - (imap-close nnimap-server-buffer) - (nnimap-open-connection server))) - (nnimap-open-connection server))))) - -(deffoo nnimap-server-opened (&optional server) - "Whether SERVER is opened. -If SERVER is the current virtual server, and the connection to the -physical server is alive, this function return a non-nil value. If -SERVER is nil, it is treated as the current server." - ;; clean up autologouts?? - (and (or server nnimap-current-server) - (nnoo-server-opened 'nnimap (or server nnimap-current-server)) - (imap-opened (nnimap-get-server-buffer server)))) + (or (nnimap-find-connection nntp-server-buffer) + (nnimap-open-connection nntp-server-buffer)))) + +(defun nnimap-make-process-buffer (buffer) + (with-current-buffer + (generate-new-buffer (format "*nnimap %s %s %s*" + nnimap-address nnimap-server-port + (gnus-buffer-exists-p buffer))) + (mm-disable-multibyte) + (buffer-disable-undo) + (gnus-add-buffer) + (set (make-local-variable 'after-change-functions) nil) + (set (make-local-variable 'nnimap-object) + (make-nnimap :server (nnoo-current-server 'nnimap))) + (push (list buffer (current-buffer)) nnimap-connection-alist) + (push (current-buffer) nnimap-process-buffers) + (current-buffer))) + +(defun nnimap-credentials (address ports &optional inhibit-create) + (let (port credentials) + ;; Request the credentials from all ports, but only query on the + ;; last port if all the previous ones have failed. + (while (and (null credentials) + (setq port (pop ports))) + (setq credentials + (auth-source-user-or-password + '("login" "password") address port nil + (if inhibit-create + nil + (null ports))))) + credentials)) + +(defun nnimap-keepalive () + (let ((now (current-time))) + (dolist (buffer nnimap-process-buffers) + (when (buffer-name buffer) + (with-current-buffer buffer + (when (and nnimap-object + (nnimap-last-command-time nnimap-object) + (> (gnus-float-time + (time-subtract + now + (nnimap-last-command-time nnimap-object))) + ;; More than five minutes since the last command. + (* 5 60))) + (nnimap-send-command "NOOP"))))))) + +(defun nnimap-open-connection (buffer) + ;; Be backwards-compatible -- the earlier value of nnimap-stream was + ;; `ssl' when nnimap-server-port was nil. Sort of. + (when (and nnimap-server-port + (eq nnimap-stream 'undecided)) + (setq nnimap-stream 'ssl)) + (let ((stream + (if (eq nnimap-stream 'undecided) + (loop for type in '(ssl network) + for stream = (let ((nnimap-stream type)) + (nnimap-open-connection-1 buffer)) + while (eq stream 'no-connect) + finally (return stream)) + (nnimap-open-connection-1 buffer)))) + (if (eq stream 'no-connect) + nil + stream))) + +(defun nnimap-open-connection-1 (buffer) + (unless nnimap-keepalive-timer + (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) + 'nnimap-keepalive))) + (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) 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" + (message-make-address)) + (or + ;; First look for the credentials based + ;; on the virtual server name. + (nnimap-credentials + (nnoo-current-server 'nnimap) ports t) + ;; Then look them up based on the + ;; physical address. + (nnimap-credentials nnimap-address ports))))) + (setq nnimap-object nil) + (setq login-result + (nnimap-login (car credentials) (cadr credentials))) + (unless (car login-result) + ;; If the login failed, then forget the credentials + ;; that are now possibly cached. + (dolist (host (list (nnoo-current-server 'nnimap) + nnimap-address)) + (dolist (port ports) + (dolist (element '("login" "password")) + (auth-source-forget-user-or-password + element host port)))) + (delete-process (nnimap-process nnimap-object)) + (setq nnimap-object nil)))) + (when nnimap-object + (when (nnimap-capability "QRESYNC") + (nnimap-command "ENABLE QRESYNC")) + (nnimap-process nnimap-object)))))))) + +(autoload 'rfc2104-hash "rfc2104") + +(defun nnimap-login (user password) + (cond + ((nnimap-capability "AUTH=CRAM-MD5") + (erase-buffer) + (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5")) + (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n"))) + (process-send-string + (get-buffer-process (current-buffer)) + (concat + (base64-encode-string + (concat user " " + (rfc2104-hash 'md5 64 16 password + (base64-decode-string challenge)))) + "\r\n")) + (nnimap-wait-for-response sequence))) + ((not (nnimap-capability "LOGINDISABLED")) + (nnimap-command "LOGIN %S %S" user password)) + ((nnimap-capability "AUTH=PLAIN") + (nnimap-command + "AUTHENTICATE PLAIN %s" + (base64-encode-string + (format "\000%s\000%s" + (nnimap-quote-specials user) + (nnimap-quote-specials password))))))) + +(defun nnimap-quote-specials (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "[\\\"]" nil t) + (forward-char -1) + (insert "\\") + (forward-char 1)) + (buffer-string))) + +(defun nnimap-find-parameter (parameter elems) + (let (result) + (dolist (elem elems) + (cond + ((equal (car elem) parameter) + (setq result (cdr elem))) + ((and (equal (car elem) "OK") + (consp (cadr elem)) + (equal (caadr elem) parameter)) + (setq result (cdr (cadr elem)))))) + result)) (deffoo nnimap-close-server (&optional server) - "Close connection to server and free all resources connected to it. -Return nil if the server couldn't be closed for some reason." - (let ((server (or server nnimap-current-server)) - (imap-logout-timeout nnimap-logout-timeout)) - (when (or (nnimap-server-opened server) - (imap-opened (nnimap-get-server-buffer server))) - (imap-close (nnimap-get-server-buffer server)) - (kill-buffer (nnimap-get-server-buffer server)) - (setq nnimap-server-buffer nil - nnimap-current-server nil - nnimap-server-buffer-alist - (nnimap-remove-server-from-buffer-alist - server - nnimap-server-buffer-alist))) - (nnoo-close-server 'nnimap server))) + (when (nnoo-change-server 'nnimap server nil) + (ignore-errors + (delete-process (get-buffer-process (nnimap-buffer)))) + (nnoo-close-server 'nnimap server) + t)) (deffoo nnimap-request-close () - "Close connection to all servers and free all resources that the backend have reserved. -All buffers that have been created by that -backend should be killed. (Not the nntp-server-buffer, though.) This -function is generally only called when Gnus is shutting down." - (mapc (lambda (server) (nnimap-close-server (car server))) - nnimap-server-buffer-alist) - (setq nnimap-server-buffer-alist nil)) + t) -(deffoo nnimap-status-message (&optional server) - "This function returns the last error message from server." - (when (nnimap-possibly-change-server server) - (nnoo-status-message 'nnimap server))) - -;; We used to use a string-as-multibyte here, but it is really incorrect. -;; This function is used when we're about to insert a unibyte string -;; into a potentially multibyte buffer. The string is either an article -;; header or body (or both?), undecoded. When Emacs is asked to convert -;; a unibyte string to multibyte, it may either use the equivalent of -;; nothing (e.g. non-Mule XEmacs), string-make-unibyte (i.e. decode using -;; locale), string-as-multibyte (decode using emacs-internal coding system) -;; or string-to-multibyte (keep the data undecoded as a sequence of bytes). -;; Only the last one preserves the data such that we can reliably later on -;; decode the text using the mime info. -(defalias 'nnimap-demule 'mm-string-to-multibyte) - -(defun nnimap-make-callback (article gnus-callback buffer) - "Return a callback function." - `(lambda () - (nnimap-callback ,article ,gnus-callback ,buffer))) - -(defun nnimap-callback (article gnus-callback buffer) - (when (eq article (imap-current-message)) - (remove-hook 'imap-fetch-data-hook - (nnimap-make-callback article gnus-callback buffer)) - (with-current-buffer buffer - (insert - (with-current-buffer nnimap-server-buffer - (nnimap-demule - (if (imap-capability 'IMAP4rev1) - ;; xxx don't just use car? alist doesn't contain - ;; anything else now, but it might... - (nth 2 (car (imap-message-get article 'BODYDETAIL))) - (imap-message-get article 'RFC822))))) - (nnheader-ms-strip-cr) - (funcall gnus-callback t)))) - -(defun nnimap-request-article-part (article part prop &optional - group server to-buffer detail) - (when (nnimap-possibly-change-group group server) - (let ((article (if (stringp article) - (car-safe (imap-search - (format "HEADER Message-Id \"%s\"" article) - nnimap-server-buffer)) - article))) - (when article - (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." - article (or group imap-current-mailbox - gnus-newsgroup-name)) - (if (not nnheader-callback-function) - (with-current-buffer (or to-buffer nntp-server-buffer) - (erase-buffer) - (let ((data (imap-fetch article part prop nil - nnimap-server-buffer))) - ;; data can be nil if article is write-only - (when data - (insert (nnimap-demule (if detail - (nth 2 (car data)) - data))))) - (nnheader-ms-strip-cr) - (gnus-message - 10 "nnimap: Fetching (part of) article %d from %s...done" - article (or group imap-current-mailbox gnus-newsgroup-name)) - (if (bobp) - (nnheader-report 'nnimap "No such article %d in %s: %s" - article (or group imap-current-mailbox - gnus-newsgroup-name) - (imap-error-text nnimap-server-buffer)) - (cons group article))) - (add-hook 'imap-fetch-data-hook - (nnimap-make-callback article - nnheader-callback-function - nntp-server-buffer)) - (imap-fetch-asynch article part nil nnimap-server-buffer) - (cons group article)))))) +(deffoo nnimap-server-opened (&optional server) + (and (nnoo-current-server-p 'nnimap server) + nntp-server-buffer + (gnus-buffer-live-p nntp-server-buffer) + (nnimap-find-connection nntp-server-buffer))) -(deffoo nnimap-asynchronous-p () - t) +(deffoo nnimap-status-message (&optional server) + nnimap-status-string) (deffoo nnimap-request-article (article &optional group server to-buffer) - (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) - (nnimap-request-article-part - article "BODY.PEEK[]" 'BODYDETAIL group server to-buffer 'detail) - (nnimap-request-article-part - article "RFC822.PEEK" 'RFC822 group server to-buffer))) + (with-current-buffer nntp-server-buffer + (let ((result (nnimap-possibly-change-group group server)) + parts structure) + (when (stringp article) + (setq article (nnimap-find-article-by-message-id group article))) + (when (and result + article) + (erase-buffer) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (when nnimap-fetch-partial-articles + (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) + (goto-char (point-min)) + (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) + (setq structure (ignore-errors + (let ((start (point))) + (forward-sexp 1) + (downcase-region start (point)) + (goto-char start) + (read (current-buffer)))) + parts (nnimap-find-wanted-parts structure)))) + (when (if parts + (nnimap-get-partial-article article parts structure) + (nnimap-get-whole-article article)) + (let ((buffer (current-buffer))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring buffer) + (nnheader-ms-strip-cr) + (cons group article))))))))) (deffoo nnimap-request-head (article &optional group server to-buffer) - (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) - (nnimap-request-article-part - article "BODY.PEEK[HEADER]" 'BODYDETAIL group server to-buffer 'detail) - (nnimap-request-article-part - article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))) - -(deffoo nnimap-request-body (article &optional group server to-buffer) - (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) - (nnimap-request-article-part - article "BODY.PEEK[TEXT]" 'BODYDETAIL group server to-buffer 'detail) - (nnimap-request-article-part - article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))) - -(deffoo nnimap-request-group (group &optional server fast) - (nnimap-request-update-info-internal - group - (gnus-get-info (gnus-group-prefixed-name - group (gnus-server-to-method (format "nnimap:%s" server)))) - server) (when (nnimap-possibly-change-group group server) - (nnimap-before-find-minmax-bugworkaround) - (let (info) - (cond (fast group) - ((null (setq info (nnimap-find-minmax-uid group t))) - (nnheader-report 'nnimap "Could not get active info for %s" - group)) - (t - (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0) - (max 1 (or (nth 1 info) 1)) - (or (nth 2 info) 0) group) - (nnheader-report 'nnimap "Group %s selected" group) - t))))) - -(defun nnimap-update-unseen (group &optional server) - "Update the unseen count in `nnimap-mailbox-info'." - (gnus-sethash - (gnus-group-prefixed-name group server) - (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server) - nnimap-mailbox-info))) - (list (nth 0 old) (nth 1 old) - (imap-mailbox-status group 'unseen nnimap-server-buffer) - (nth 3 old))) - nnimap-mailbox-info)) - -(defun nnimap-close-group (group &optional server) - (with-current-buffer nnimap-server-buffer - (when (and (imap-opened) - (nnimap-possibly-change-group group server)) - (nnimap-update-unseen group server) - (case nnimap-expunge-on-close - (always (progn - (imap-mailbox-expunge nnimap-close-asynchronous) - (unless nnimap-dont-close - (imap-mailbox-close nnimap-close-asynchronous)))) - (ask (if (and (imap-search "DELETED") - (gnus-y-or-n-p (format "Expunge articles in group `%s'? " - imap-current-mailbox))) - (progn - (imap-mailbox-expunge nnimap-close-asynchronous) - (unless nnimap-dont-close - (imap-mailbox-close nnimap-close-asynchronous))) - (imap-mailbox-unselect))) - (t (imap-mailbox-unselect))) - (not imap-current-mailbox)))) - -(defun nnimap-pattern-to-list-arguments (pattern) - (mapcar (lambda (p) - (cons (car-safe p) (or (cdr-safe p) p))) - (if (and (listp pattern) - (listp (cdr pattern))) - pattern - (list pattern)))) + (with-current-buffer (nnimap-buffer) + (when (stringp article) + (setq article (nnimap-find-article-by-message-id group article))) + (nnimap-get-whole-article + article (format "UID FETCH %%d %s" + (nnimap-header-parameters))) + (let ((buffer (current-buffer))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring buffer) + (nnheader-ms-strip-cr) + (cons group article)))))) -(deffoo nnimap-request-list (&optional server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nntp-server-buffer - (erase-buffer)) - (gnus-message 5 "nnimap: Generating active list%s..." - (if (> (length server) 0) (concat " for " server) "")) - (nnimap-before-find-minmax-bugworkaround) - (with-current-buffer nnimap-server-buffer - (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) - (dolist (mbx (funcall nnimap-request-list-method - (cdr pattern) (car pattern))) - (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx)) - (let ((info (nnimap-find-minmax-uid mbx 'examine))) - (when info - (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) - (gnus-message 5 "nnimap: Generating active list%s...done" - (if (> (length server) 0) (concat " for " server) "")) +(defun nnimap-get-whole-article (article &optional command) + (let ((result + (nnimap-command + (or command + (if (nnimap-ver4-p) + "UID FETCH %d BODY.PEEK[]" + "UID FETCH %d RFC822.PEEK")) + article))) + ;; Check that we really got an article. + (goto-char (point-min)) + (unless (re-search-forward "\\* [0-9]+ FETCH" nil t) + (setq result nil)) + (when result + ;; Remove any data that may have arrived before the FETCH data. + (beginning-of-line) + (unless (bobp) + (delete-region (point-min) (point))) + (let ((bytes (nnimap-get-length))) + (delete-region (line-beginning-position) + (progn (forward-line 1) (point))) + (goto-char (+ (point) bytes)) + (delete-region (point) (point-max))) + t))) + +(defun nnimap-capability (capability) + (member capability (nnimap-capabilities nnimap-object))) + +(defun nnimap-ver4-p () + (nnimap-capability "IMAP4REV1")) + +(defun nnimap-get-partial-article (article parts structure) + (let ((result + (nnimap-command + "UID FETCH %d (%s %s)" + article + (if (nnimap-ver4-p) + "BODY.PEEK[HEADER]" + "RFC822.HEADER") + (if (nnimap-ver4-p) + (mapconcat (lambda (part) + (format "BODY.PEEK[%s]" part)) + parts " ") + (mapconcat (lambda (part) + (format "RFC822.PEEK[%s]" part)) + parts " "))))) + (when result + (nnimap-convert-partial-article structure)))) + +(defun nnimap-convert-partial-article (structure) + ;; First just skip past the headers. + (goto-char (point-min)) + (let ((bytes (nnimap-get-length)) + id parts) + ;; Delete "FETCH" line. + (delete-region (line-beginning-position) + (progn (forward-line 1) (point))) + (goto-char (+ (point) bytes)) + ;; Collect all the body parts. + (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]") + (setq id (match-string 1) + bytes (or (nnimap-get-length) 0)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (push (list id (buffer-substring (point) (+ (point) bytes))) + parts) + (delete-region (point) (+ (point) bytes))) + ;; Delete trailing junk. + (delete-region (point) (point-max)) + ;; Now insert all the parts again where they fit in the structure. + (nnimap-insert-partial-structure structure parts) t)) -(deffoo nnimap-request-post (&optional server) - (let ((success t)) - (dolist (mbx (message-unquote-tokens - (message-tokenize-header - (message-fetch-field "Newsgroups") ", ")) success) - (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) - (or (gnus-active to-newsgroup) - (gnus-activate-group to-newsgroup) - (if (gnus-y-or-n-p (format "No such group: %s. Create it? " - to-newsgroup)) - (or (and (gnus-request-create-group - to-newsgroup gnus-command-method) - (gnus-activate-group to-newsgroup nil nil - gnus-command-method)) - (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) - (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method)) - (setq success nil)))))) - -;; Optional backend functions - -(defun nnimap-string-lessp-numerical (s1 s2) - "Return t if first arg string is less than second in numerical order." - (cond ((string= s1 s2) - nil) - ((> (length s1) (length s2)) - nil) - ((< (length s1) (length s2)) - t) - ((< (string-to-number (substring s1 0 1)) - (string-to-number (substring s2 0 1))) - t) - ((> (string-to-number (substring s1 0 1)) - (string-to-number (substring s2 0 1))) - nil) - (t - (nnimap-string-lessp-numerical (substring s1 1) (substring s2 1))))) - -(deffoo nnimap-retrieve-groups (groups &optional server) - (when (nnimap-possibly-change-server server) - (gnus-message 5 "nnimap: Checking mailboxes...") +(defun nnimap-insert-partial-structure (structure parts &optional subp) + (let (type boundary) + (let ((bstruc structure)) + (while (consp (car bstruc)) + (pop bstruc)) + (setq type (car bstruc)) + (setq bstruc (car (cdr bstruc))) + (let ((has-boundary (member "boundary" bstruc))) + (when has-boundary + (setq boundary (cadr has-boundary))))) + (when subp + (insert (format "Content-type: multipart/%s; boundary=%S\n\n" + (downcase type) boundary))) + (while (not (stringp (car structure))) + (insert "\n--" boundary "\n") + (if (consp (caar structure)) + (nnimap-insert-partial-structure (pop structure) parts t) + (let ((bit (pop structure))) + (insert (format "Content-type: %s/%s" + (downcase (nth 0 bit)) + (downcase (nth 1 bit)))) + (if (member "CHARSET" (nth 2 bit)) + (insert (format + "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit))))) + (insert "\n")) + (insert (format "Content-transfer-encoding: %s\n" + (nth 5 bit))) + (insert "\n") + (when (assoc (nth 9 bit) parts) + (insert (cadr (assoc (nth 9 bit) parts))))))) + (insert "\n--" boundary "--\n"))) + +(defun nnimap-find-wanted-parts (structure) + (message-flatten-list (nnimap-find-wanted-parts-1 structure ""))) + +(defun nnimap-find-wanted-parts-1 (structure prefix) + (let ((num 1) + parts) + (while (consp (car structure)) + (let ((sub (pop structure))) + (if (consp (car sub)) + (push (nnimap-find-wanted-parts-1 + sub (if (string= prefix "") + (number-to-string num) + (format "%s.%s" prefix num))) + parts) + (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub))) + (id (if (string= prefix "") + (number-to-string num) + (format "%s.%s" prefix num)))) + (setcar (nthcdr 9 sub) id) + (when (if (eq nnimap-fetch-partial-articles t) + (equal id "1") + (string-match nnimap-fetch-partial-articles type)) + (push id parts)))) + (incf num))) + (nreverse parts))) + +(deffoo nnimap-request-group (group &optional server dont-check info) + (let ((result (nnimap-possibly-change-group + ;; Don't SELECT the group if we're going to select it + ;; later, anyway. + (if (and (not dont-check) + (assoc group nnimap-current-infos)) + nil + group) + server)) + articles active marks high low) (with-current-buffer nntp-server-buffer - (erase-buffer) - (nnimap-before-find-minmax-bugworkaround) - (let (asyncgroups slowgroups) - (if (null nnimap-retrieve-groups-asynchronous) - (setq slowgroups groups) - (dolist (group groups) - (gnus-message 9 "nnimap: Quickly checking mailbox %s" group) - (add-to-list (if (gnus-gethash-safe - (gnus-group-prefixed-name group server) - nnimap-mailbox-info) - 'asyncgroups - 'slowgroups) - (list group (imap-mailbox-status-asynch - group '(uidvalidity uidnext unseen) - nnimap-server-buffer)))) - (dolist (asyncgroup asyncgroups) - (let ((group (nth 0 asyncgroup)) - (tag (nth 1 asyncgroup)) - new old) - (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer)) - (if (or (not (string= - (nth 0 (gnus-gethash (gnus-group-prefixed-name - group server) - nnimap-mailbox-info)) - (imap-mailbox-get 'uidvalidity group - nnimap-server-buffer))) - (not (string= - (nth 1 (gnus-gethash (gnus-group-prefixed-name - group server) - nnimap-mailbox-info)) - (imap-mailbox-get 'uidnext group - nnimap-server-buffer)))) - (push (list group) slowgroups) - (insert (nth 3 (gnus-gethash (gnus-group-prefixed-name - group server) - nnimap-mailbox-info)))))))) - (dolist (group slowgroups) - (if nnimap-retrieve-groups-asynchronous - (setq group (car group))) - (gnus-message 7 "nnimap: Mailbox %s modified" group) - (imap-mailbox-put 'uidnext nil group nnimap-server-buffer) - (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group - nnimap-server-buffer)) - (let* ((info (nnimap-find-minmax-uid group 'examine)) - (str (format "\"%s\" %d %d y\n" group - (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))) - (when (> (or (imap-mailbox-get 'recent group - nnimap-server-buffer) 0) - 0) - (push (list (cons group 0)) nnmail-split-history)) - (insert str) - (when nnimap-retrieve-groups-asynchronous - (gnus-sethash - (gnus-group-prefixed-name group server) - (list (or (imap-mailbox-get - 'uidvalidity group nnimap-server-buffer) - (imap-mailbox-status - group 'uidvalidity nnimap-server-buffer)) - (or (imap-mailbox-get - 'uidnext group nnimap-server-buffer) - (imap-mailbox-status - group 'uidnext nnimap-server-buffer)) - (or (imap-mailbox-get - 'unseen group nnimap-server-buffer) - (imap-mailbox-status - group 'unseen nnimap-server-buffer)) - str) - nnimap-mailbox-info))))))) - (gnus-message 5 "nnimap: Checking mailboxes...done") - 'active)) - -(deffoo nnimap-request-update-info-internal (group info &optional server) + (when result + (if (and dont-check + (setq active (nth 2 (assoc group nnimap-current-infos)))) + (insert (format "211 %d %d %d %S\n" + (- (cdr active) (car active)) + (car active) + (cdr active) + group)) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (let ((group-sequence + (nnimap-send-command "SELECT %S" (utf7-encode group t))) + (flag-sequence + (nnimap-send-command "UID FETCH 1:* FLAGS"))) + (setf (nnimap-group nnimap-object) group) + (nnimap-wait-for-response flag-sequence) + (setq marks + (nnimap-flags-to-marks + (nnimap-parse-flags + (list (list group-sequence flag-sequence + 1 group "SELECT"))))) + (when (and info + marks) + (nnimap-update-infos marks (list info)) + (nnimap-store-info info (gnus-active (gnus-info-group info)))) + (goto-char (point-max)) + (let ((uidnext (nth 5 (car marks)))) + (setq high (or (if uidnext + (1- uidnext) + (nth 3 (car marks))) + 0) + low (or (nth 4 (car marks)) uidnext 1))))) + (erase-buffer) + (insert + (format + "211 %d %d %d %S\n" (1+ (- high low)) low high group))) + t)))) + +(deffoo nnimap-request-create-group (group &optional server args) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) + +(deffoo nnimap-request-delete-group (group &optional force server) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) + +(deffoo nnimap-request-rename-group (group new-name &optional server) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (nnimap-unselect-group) + (car (nnimap-command "RENAME %S %S" + (utf7-encode group t) (utf7-encode new-name t)))))) + +(defun nnimap-unselect-group () + ;; Make sure we don't have this group open read/write by asking + ;; to examine a mailbox that doesn't exist. This seems to be + ;; the only way that allows us to reliably go back to unselected + ;; state on Courier. + (nnimap-command "EXAMINE DOES.NOT.EXIST")) + +(deffoo nnimap-request-expunge-group (group &optional server) (when (nnimap-possibly-change-group group server) - (when info ;; xxx what does this mean? should we create a info? - (with-current-buffer nnimap-server-buffer - (gnus-message 5 "nnimap: Updating info for %s..." - (gnus-info-group info)) - - (when (nnimap-mark-permanent-p 'read) - (let (seen unseen) - ;; read info could contain articles marked unread by other - ;; imap clients! we correct this - (setq unseen (gnus-compress-sequence - (imap-search "UNSEEN UNDELETED")) - seen (gnus-range-difference (gnus-info-read info) unseen) - seen (gnus-range-add seen - (gnus-compress-sequence - (imap-search "SEEN"))) - seen (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen)) - (gnus-info-set-read info seen))) - - (dolist (pred gnus-article-mark-lists) - (when (or (eq (cdr pred) 'recent) - (and (nnimap-mark-permanent-p (cdr pred)) - (member (nnimap-mark-to-flag (cdr pred)) - (imap-mailbox-get 'flags)))) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (gnus-compress-sequence - (imap-search (nnimap-mark-to-predicate (cdr pred)))) - (gnus-info-marks info)) - t))) - - (when nnimap-importantize-dormant - ;; nnimap mark dormant article as ticked too (for other clients) - ;; so we remove that mark for gnus since we support dormant - (gnus-info-set-marks - info - (gnus-update-alist-soft - 'tick - (gnus-remove-from-range - (cdr-safe (assoc 'tick (gnus-info-marks info))) - (cdr-safe (assoc 'dormant (gnus-info-marks info)))) - (gnus-info-marks info)) - t)) - - (gnus-message 5 "nnimap: Updating info for %s...done" - (gnus-info-group info)) - - info)))) - -(deffoo nnimap-request-type (group &optional article) - (if (and nnimap-news-groups (string-match nnimap-news-groups group)) - 'news - 'mail)) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "EXPUNGE"))))) + +(defun nnimap-get-flags (spec) + (let ((articles nil) + elems end) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (nnimap-wait-for-response (nnimap-send-command + "UID FETCH %s FLAGS" spec)) + (setq end (point)) + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) + (goto-char (point-min)) + (while (search-forward " FETCH " end t) + (setq elems (read (current-buffer))) + (push (cons (cadr (memq 'UID elems)) + (cadr (memq 'FLAGS elems))) + articles))) + (nreverse articles))) + +(deffoo nnimap-close-group (group &optional server) + t) + +(deffoo nnimap-request-move-article (article group server accept-form + &optional last internal-move-group) + (with-temp-buffer + (mm-disable-multibyte) + (when (funcall (if internal-move-group + 'nnimap-request-head + 'nnimap-request-article) + article group server (current-buffer)) + ;; If the move is internal (on the same server), just do it the easy + ;; way. + (let ((message-id (message-field-value "message-id"))) + (if internal-move-group + (let ((result + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID COPY %d %S" + article + (utf7-encode internal-move-group t))))) + (when (car result) + (nnimap-delete-article article) + (cons internal-move-group + (or (nnimap-find-uid-response "COPYUID" (cadr result)) + (nnimap-find-article-by-message-id + internal-move-group message-id))))) + ;; Move the article to a different method. + (let ((result (eval accept-form))) + (when result + (nnimap-delete-article article) + result))))))) + +(deffoo nnimap-request-expire-articles (articles group &optional server force) + (cond + ((null articles) + nil) + ((not (nnimap-possibly-change-group group server)) + articles) + ((and force + (eq nnmail-expiry-target 'delete)) + (unless (nnimap-delete-article (gnus-compress-sequence articles)) + (nnheader-message 7 "Article marked for deletion, but not expunged.")) + nil) + (t + (let ((deletable-articles + (if (or force + (eq nnmail-expiry-wait 'immediate)) + articles + (gnus-sorted-intersection + articles + (nnimap-find-expired-articles group))))) + (if (null deletable-articles) + articles + (if (eq nnmail-expiry-target 'delete) + (nnimap-delete-article (gnus-compress-sequence deletable-articles)) + (setq deletable-articles + (nnimap-process-expiry-targets + deletable-articles group server))) + ;; Return the articles we didn't delete. + (gnus-sorted-complement articles deletable-articles)))))) + +(defun nnimap-process-expiry-targets (articles group server) + (let ((deleted-articles nil)) + (cond + ;; shortcut further processing if we're going to delete the articles + ((eq nnmail-expiry-target 'delete) + (setq deleted-articles articles) + t) + ;; or just move them to another folder on the same IMAP server + ((and (not (functionp nnmail-expiry-target)) + (gnus-server-equal (gnus-group-method nnmail-expiry-target) + (gnus-server-to-method + (format "nnimap:%s" server)))) + (and (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (nnheader-message 7 "Expiring articles from %s: %s" group articles) + (nnimap-command + "UID COPY %s %S" + (nnimap-article-ranges (gnus-compress-sequence articles)) + (utf7-encode (gnus-group-real-name nnmail-expiry-target) t)) + (setq deleted-articles articles))) + t) + (t + (dolist (article articles) + (let ((target nnmail-expiry-target)) + (with-temp-buffer + (mm-disable-multibyte) + (when (nnimap-request-article article group server (current-buffer)) + (nnheader-message 7 "Expiring article %s:%d" group article) + (when (functionp target) + (setq target (funcall target group))) + (when (and target + (not (eq target 'delete))) + (if (or (gnus-request-group target t) + (gnus-request-create-group target)) + (nnmail-expiry-target-group target group) + (setq target nil))) + (when target + (push article deleted-articles)))))))) + ;; Change back to the current group again. + (nnimap-possibly-change-group group server) + (setq deleted-articles (nreverse deleted-articles)) + (nnimap-delete-article (gnus-compress-sequence deleted-articles)) + deleted-articles)) + +(defun nnimap-find-expired-articles (group) + (let ((cutoff (nnmail-expired-article-p group nil nil))) + (with-current-buffer (nnimap-buffer) + (let ((result + (nnimap-command + "UID SEARCH SENTBEFORE %s" + (format-time-string + (format "%%d-%s-%%Y" + (upcase + (car (rassoc (nth 4 (decode-time cutoff)) + parse-time-months)))) + cutoff)))) + (and (car result) + (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))))))) + + +(defun nnimap-find-article-by-message-id (group message-id) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (unless (equal group (nnimap-group nnimap-object)) + (setf (nnimap-group nnimap-object) nil) + (setf (nnimap-examined nnimap-object) group) + (nnimap-send-command "EXAMINE %S" (utf7-encode group t))) + (let ((sequence + (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id)) + article result) + (setq result (nnimap-wait-for-response sequence)) + (when (and result + (car (setq result (nnimap-parse-response)))) + ;; Select the last instance of the message in the group. + (and (setq article + (car (last (assoc "SEARCH" (cdr result))))) + (string-to-number article)))))) + +(defun nnimap-delete-article (articles) + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" + (nnimap-article-ranges articles)) + (cond + ((nnimap-capability "UIDPLUS") + (nnimap-command "UID EXPUNGE %s" + (nnimap-article-ranges articles)) + t) + (nnimap-expunge + (nnimap-command "EXPUNGE") + t) + (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the " + "server doesn't support UIDPLUS, so we won't " + "delete this article now")))))) + +(deffoo nnimap-request-scan (&optional group server) + (when (and (nnimap-possibly-change-group nil server) + nnimap-inbox + nnimap-split-methods) + (nnheader-message 7 "nnimap %s splitting mail..." server) + (nnimap-split-incoming-mail))) + +(defun nnimap-marks-to-flags (marks) + (let (flags flag) + (dolist (mark marks) + (when (setq flag (cadr (assq mark nnimap-mark-alist))) + (push flag flags))) + flags)) + +(deffoo nnimap-request-update-group-status (group status &optional server) + (when (nnimap-possibly-change-group nil server) + (let ((command (assoc + status + '((subscribe "SUBSCRIBE") + (unsubscribe "UNSUBSCRIBE"))))) + (when command + (with-current-buffer (nnimap-buffer) + (nnimap-command "%s %S" (cadr command) (utf7-encode group t))))))) (deffoo nnimap-request-set-mark (group actions &optional server) (when (nnimap-possibly-change-group group server) - (with-current-buffer nnimap-server-buffer - (let (action) - (gnus-message 7 "nnimap: Setting marks in %s..." group) - (while (setq action (pop actions)) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (cmdmarks (nth 2 action)) - marks) - ;; bookmark can't be stored (not list/range - (setq cmdmarks (delq 'bookmark cmdmarks)) - ;; killed can't be stored (not list/range - (setq cmdmarks (delq 'killed cmdmarks)) - ;; unsent are for nndraft groups only - (setq cmdmarks (delq 'unsent cmdmarks)) - ;; cache flags are pointless on the server - (setq cmdmarks (delq 'cache cmdmarks)) - ;; seen flags are local to each gnus - (setq cmdmarks (delq 'seen cmdmarks)) - ;; recent marks can't be set - (setq cmdmarks (delq 'recent cmdmarks)) - (when nnimap-importantize-dormant - ;; flag dormant articles as ticked - (if (memq 'dormant cmdmarks) - (setq cmdmarks (cons 'tick cmdmarks)))) - ;; remove stuff we are forbidden to store - (mapc (lambda (mark) - (if (imap-message-flag-permanent-p - (nnimap-mark-to-flag mark)) - (setq marks (cons mark marks)))) - cmdmarks) - (when (and range marks) - (cond ((eq what 'del) - (imap-message-flags-del - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))) - ((eq what 'add) - (imap-message-flags-add - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))) - ((eq what 'set) - (imap-message-flags-set - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))))))) - (gnus-message 7 "nnimap: Setting marks in %s...done" group)))) - nil) + (let (sequence) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + ;; Just send all the STORE commands without waiting for + ;; response. If they're successful, they're successful. + (dolist (action actions) + (destructuring-bind (range action marks) action + (let ((flags (nnimap-marks-to-flags marks))) + (when flags + (setq sequence (nnimap-send-command + "UID STORE %s %sFLAGS.SILENT (%s)" + (nnimap-article-ranges range) + (cond + ((eq action 'del) "-") + ((eq action 'add) "+") + ((eq action 'set) "")) + (mapconcat #'identity flags " "))))))) + ;; Wait for the last command to complete to avoid later + ;; syncronisation problems with the stream. + (when sequence + (nnimap-wait-for-response sequence)))))) -(defun nnimap-split-fancy () - "Like the function `nnmail-split-fancy', but uses `nnimap-split-fancy'." - (let ((nnmail-split-fancy nnimap-split-fancy)) - (nnmail-split-fancy))) +(deffoo nnimap-request-accept-article (group &optional server last) + (when (nnimap-possibly-change-group nil server) + (nnmail-check-syntax) + (let ((message-id (message-field-value "message-id")) + sequence message) + (nnimap-add-cr) + (setq message (buffer-substring-no-properties (point-min) (point-max))) + (with-current-buffer (nnimap-buffer) + ;; If we have this group open read-only, then unselect it + ;; before appending to it. + (when (equal (nnimap-examined nnimap-object) group) + (nnimap-unselect-group)) + (erase-buffer) + (setq sequence (nnimap-send-command + "APPEND %S {%d}" (utf7-encode group t) + (length message))) + (unless nnimap-streaming + (nnimap-wait-for-connection "^[+]")) + (process-send-string (get-buffer-process (current-buffer)) message) + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n")) + (let ((result (nnimap-get-response sequence))) + (if (not (car result)) + (progn + (nnheader-message 7 "%s" (nnheader-get-report-string 'nnimap)) + nil) + (cons group + (or (nnimap-find-uid-response "APPENDUID" (car result)) + (nnimap-find-article-by-message-id + group message-id))))))))) + +(defun nnimap-find-uid-response (name list) + (let ((result (car (last (nnimap-find-response-element name list))))) + (and result + (string-to-number result)))) + +(defun nnimap-find-response-element (name list) + (let (result) + (dolist (elem list) + (when (and (consp elem) + (equal name (car elem))) + (setq result elem))) + result)) + +(deffoo nnimap-request-replace-article (article group buffer) + (let (group-art) + (when (and (nnimap-possibly-change-group group nil) + ;; Put the article into the group. + (with-current-buffer buffer + (setq group-art + (nnimap-request-accept-article group nil t)))) + (nnimap-delete-article (list article)) + ;; Return the new article number. + (cdr group-art)))) + +(defun nnimap-add-cr () + (goto-char (point-min)) + (while (re-search-forward "\r?\n" nil t) + (replace-match "\r\n" t t))) + +(defun nnimap-get-groups () + (erase-buffer) + (let ((sequence (nnimap-send-command "LIST \"\" \"*\"")) + groups) + (nnimap-wait-for-response sequence) + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) + (goto-char (point-min)) + (nnimap-unfold-quoted-lines) + (goto-char (point-min)) + (while (search-forward "* LIST " nil t) + (let ((flags (read (current-buffer))) + (separator (read (current-buffer))) + (group (read (current-buffer)))) + (unless (member '%NoSelect flags) + (push (if (stringp group) + group + (format "%s" group)) + groups)))) + (nreverse groups))) -(defun nnimap-split-to-groups (rules) - ;; tries to match all rules in nnimap-split-rule against content of - ;; nntp-server-buffer, returns a list of groups that matched. +(deffoo nnimap-request-list (&optional server) + (nnimap-possibly-change-group nil server) (with-current-buffer nntp-server-buffer - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - (if (functionp rules) - (funcall rules) - (let (to-groups regrepp) - (catch 'split-done - (dolist (rule rules to-groups) - (let ((group (car rule)) - (regexp (cadr rule))) - (goto-char (point-min)) - (when (and (if (stringp regexp) - (progn - (if (not (stringp group)) - (setq group (eval group)) - (setq regrepp - (string-match "\\\\[0-9&]" group))) - (re-search-forward regexp nil t)) - (funcall regexp group)) - ;; Don't enter the article into the same group twice. - (not (assoc group to-groups))) - (push (if regrepp - (nnmail-expand-newtext group) + (erase-buffer) + (let ((groups + (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + sequences responses) + (when groups + (with-current-buffer (nnimap-buffer) + (setf (nnimap-group nnimap-object) nil) + (dolist (group groups) + (setf (nnimap-examined nnimap-object) group) + (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) group) - to-groups) - (or nnimap-split-crosspost - (throw 'split-done to-groups)))))))))) - -(defun nnimap-assoc-match (key alist) - (let (element) - (while (and alist (not element)) - (if (string-match (car (car alist)) key) - (setq element (car alist))) - (setq alist (cdr alist))) - element)) - -(defun nnimap-split-find-rule (server inbox) - (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule)) - (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule))) - ;; extended format - (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match - server nnimap-split-rule)))) - nnimap-split-rule)) - -(defun nnimap-split-find-inbox (server) - (if (listp nnimap-split-inbox) - nnimap-split-inbox - (list nnimap-split-inbox))) - -(defun nnimap-split-articles (&optional group server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nnimap-server-buffer - (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server))) - ;; iterate over inboxes - (while (and (setq inbox (pop inboxes)) - (nnimap-possibly-change-group inbox)) ;; SELECT - ;; find split rule for this server / inbox - (when (setq rule (nnimap-split-find-rule server inbox)) - ;; iterate over articles - (dolist (article (imap-search nnimap-split-predicate)) - (when (if (if (eq nnimap-split-download-body 'default) - nnimap-split-download-body-default - nnimap-split-download-body) - (and (nnimap-request-article article) - (with-current-buffer nntp-server-buffer (mail-narrow-to-head))) - (nnimap-request-head article)) - ;; copy article to right group(s) - (setq removeorig nil) - (dolist (to-group (nnimap-split-to-groups rule)) - (cond ((eq to-group 'junk) - (message "IMAP split removed %s:%s:%d" server inbox - article) - (setq removeorig t)) - ((imap-message-copy (number-to-string article) - to-group nil 'nocopyuid) - (message "IMAP split moved %s:%s:%d to %s" server - inbox article to-group) - (setq removeorig t) - (when nnmail-cache-accepted-message-ids - (with-current-buffer nntp-server-buffer - (let (msgid) - (and (setq msgid - (nnmail-fetch-field "message-id")) - (nnmail-cache-insert msgid - to-group - (nnmail-fetch-field "subject")))))) - ;; Add the group-art list to the history list. - (push (list (cons to-group 0)) nnmail-split-history)) - (t - (message "IMAP split failed to move %s:%s:%d to %s" - server inbox article to-group)))) - (if (if (eq nnimap-split-download-body 'default) - nnimap-split-download-body-default - nnimap-split-download-body) - (widen)) - ;; remove article if it was successfully copied somewhere - (and removeorig - (imap-message-flags-add (format "%d" article) - "\\Seen \\Deleted"))))) - (when (imap-mailbox-select inbox) ;; just in case - ;; todo: UID EXPUNGE (if available) to remove splitted articles - (imap-mailbox-expunge) - (imap-mailbox-close))) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-close)) + sequences)) + (nnimap-wait-for-response (caar sequences)) + (setq responses + (nnimap-get-responses (mapcar #'car sequences)))) + (dolist (response responses) + (let* ((sequence (car response)) + (response (cadr response)) + (group (cadr (assoc sequence sequences)))) + (when (and group + (equal (caar response) "OK")) + (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) + highest exists) + (dolist (elem response) + (when (equal (cadr elem) "EXISTS") + (setq exists (string-to-number (car elem))))) + (when uidnext + (setq highest (1- (string-to-number (car uidnext))))) + (cond + ((null highest) + (insert (format "%S 0 1 y\n" (utf7-decode group t)))) + ((zerop exists) + ;; Empty group. + (insert (format "%S %d %d y\n" + (utf7-decode group t) highest (1+ highest)))) + (t + ;; Return the widest possible range. + (insert (format "%S %d 1 y\n" (utf7-decode group t) + (or highest exists))))))))) t)))) -(deffoo nnimap-request-scan (&optional group server) - (nnimap-split-articles group server)) - (deffoo nnimap-request-newgroups (date &optional server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nntp-server-buffer - (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..." - (if (> (length server) 0) " on " "") server) - (erase-buffer) - (nnimap-before-find-minmax-bugworkaround) - (dolist (pattern (nnimap-pattern-to-list-arguments - nnimap-list-pattern)) - (dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil - nnimap-server-buffer)) - (or (catch 'found - (dolist (mailbox (imap-mailbox-get 'list-flags mbx - nnimap-server-buffer)) - (if (string= (downcase mailbox) "\\noselect") - (throw 'found t))) - nil) - (let ((info (nnimap-find-minmax-uid mbx 'examine))) - (when info - (insert (format "\"%s\" %d %d y\n" - mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))) - (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done" - (if (> (length server) 0) " on " "") server)) + (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (group (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + (unless (assoc group nnimap-current-infos) + ;; Insert dummy numbers here -- they don't matter. + (insert (format "%S 0 1 y\n" group)))) t)) -(deffoo nnimap-request-create-group (group &optional server args) - (when (nnimap-possibly-change-server server) - (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer) - (imap-mailbox-create group nnimap-server-buffer) - (nnheader-report 'nnimap "%S" - (imap-error-text nnimap-server-buffer))))) - -(defun nnimap-time-substract (time1 time2) - "Return TIME for TIME1 - TIME2." - (let* ((ms (- (car time1) (car time2))) - (ls (- (nth 1 time1) (nth 1 time2)))) - (if (< ls 0) - (list (- ms 1) (+ (expt 2 16) ls)) - (list ms ls)))) - -(eval-when-compile (require 'parse-time)) -(defun nnimap-date-days-ago (daysago) - "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago." - (require 'parse-time) - (let* ((time (nnimap-time-substract (current-time) (days-to-time daysago))) - (date (format-time-string - (format "%%d-%s-%%Y" - (capitalize (car (rassoc (nth 4 (decode-time time)) - parse-time-months)))) - time))) - (if (eq ?0 (string-to-char date)) - (substring date 1) - date))) - -(defun nnimap-request-expire-articles-progress () - (gnus-message 5 "nnimap: Marking article %d for deletion..." - imap-current-message)) - -(defun nnimap-expiry-target (arts group server) - (unless (eq nnmail-expiry-target 'delete) - (with-temp-buffer - (dolist (art arts) - (nnimap-request-article art group server (current-buffer)) - ;; hints for optimization in `nnimap-request-accept-article' - (let ((nnimap-current-move-article art) - (nnimap-current-move-group group) - (nnimap-current-move-server server)) - (nnmail-expiry-target-group nnmail-expiry-target group)))) - ;; It is not clear if `nnmail-expiry-target' somehow cause the - ;; current group to be changed or not, so we make sure here. - (nnimap-possibly-change-group group server))) - -;; Notice that we don't actually delete anything, we just mark them deleted. -(deffoo nnimap-request-expire-articles (articles group &optional server force) - (let ((artseq (gnus-compress-sequence articles))) - (when (and artseq (nnimap-possibly-change-group group server)) - (with-current-buffer nnimap-server-buffer - (let ((days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function group)) - nnmail-expiry-wait))) - (cond ((or force (eq days 'immediate)) - (let ((oldarts (imap-search - (concat "UID " - (imap-range-to-message-set artseq))))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts)))))) - ((and nnimap-search-uids-not-since-is-evil (numberp days)) - (let* ((all-new-articles +(deffoo nnimap-retrieve-group-data-early (server infos) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (setf (nnimap-group nnimap-object) nil) + (let ((qresyncp (nnimap-capability "QRESYNC")) + params groups sequences active uidvalidity modseq group) + ;; Go through the infos and gather the data needed to know + ;; what and how to request the data. + (dolist (info infos) + (setq params (gnus-info-params info) + group (gnus-group-real-name (gnus-info-group info)) + active (cdr (assq 'active params)) + uidvalidity (cdr (assq 'uidvalidity params)) + modseq (cdr (assq 'modseq params))) + (setf (nnimap-examined nnimap-object) group) + (if (and qresyncp + uidvalidity + modseq) + (push + (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" + (utf7-encode group t) + (nnimap-quirk "QRESYNC") + uidvalidity modseq) + 'qresync + nil group 'qresync) + sequences) + (let ((start + (if (and active uidvalidity) + ;; Fetch the last 100 flags. + (max 1 (- (cdr active) 100)) + 1)) + (command + (if uidvalidity + "EXAMINE" + ;; If we don't have a UIDVALIDITY, then this is + ;; the first time we've seen the group, so we + ;; have to do a SELECT (which is slower than an + ;; examine), but will tell us whether the group + ;; is read-only or not. + "SELECT"))) + (push (list (nnimap-send-command "%s %S" command + (utf7-encode group t)) + (nnimap-send-command "UID FETCH %d:* FLAGS" start) + start group command) + sequences)))) + sequences)))) + +(defun nnimap-quirk (command) + (let ((quirk (assoc command nnimap-quirks))) + ;; If this server is of a type that matches a quirk, then return + ;; the "quirked" command instead of the proper one. + (if (or (null quirk) + (not (string-match (nth 1 quirk) (nnimap-greeting nnimap-object)))) + command + (nth 2 quirk)))) + +(deffoo nnimap-finish-retrieve-group-infos (server infos sequences) + (when (and sequences + (nnimap-possibly-change-group nil server)) + (with-current-buffer (nnimap-buffer) + ;; Wait for the final data to trickle in. + (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync) + (caar sequences) + (cadar sequences)) + t) + ;; Now we should have most of the data we need, no matter + ;; whether we're QRESYNCING, fetching all the flags from + ;; scratch, or just fetching the last 100 flags per group. + (nnimap-update-infos (nnimap-flags-to-marks + (nnimap-parse-flags + (nreverse sequences))) + infos) + ;; Finally, just return something resembling an active file in + ;; the nntp buffer, so that the agent can save the info, too. + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (info infos) + (let* ((group (gnus-info-group info)) + (active (gnus-active group))) + (when active + (insert (format "%S %d %d y\n" + (gnus-group-real-name group) + (cdr active) + (car active))))))))))) + +(defun nnimap-update-infos (flags infos) + (dolist (info infos) + (let* ((group (gnus-group-real-name (gnus-info-group info))) + (marks (cdr (assoc group flags)))) + (when marks + (nnimap-update-info info marks))))) + +(defun nnimap-update-info (info marks) + (destructuring-bind (existing flags high low uidnext start-article + permanent-flags uidvalidity + vanished highestmodseq) marks + (cond + ;; Ignore groups with no UIDNEXT/marks. This happens for + ;; completely empty groups. + ((and (not existing) + (not uidnext)) + (let ((active (cdr (assq 'active (gnus-info-params info))))) + (when active + (gnus-set-active (gnus-info-group info) active)))) + ;; We have a mismatch between the old and new UIDVALIDITY + ;; identifiers, so we have to re-request the group info (the next + ;; time). This virtually never happens. + ((let ((old-uidvalidity + (cdr (assq 'uidvalidity (gnus-info-params info))))) + (and old-uidvalidity + (not (equal old-uidvalidity uidvalidity)) + (> start-article 1))) + (gnus-group-remove-parameter info 'uidvalidity) + (gnus-group-remove-parameter info 'modseq)) + ;; We have the data needed to update. + (t + (let* ((group (gnus-info-group info)) + (completep (and start-article + (= start-article 1))) + (active (or (gnus-active group) + (cdr (assq 'active (gnus-info-params info)))))) + (when uidnext + (setq high (1- uidnext))) + ;; First set the active ranges based on high/low. + (if (or completep + (not (gnus-active group))) + (gnus-set-active group + (cond + (active + (cons (min (or low (car active)) + (car active)) + (max (or high (cdr active)) + (cdr active)))) + ((and low high) + (cons low high)) + (uidnext + ;; No articles in this group. + (cons uidnext (1- uidnext))) + (start-article + (cons start-article (1- start-article))) + (t + ;; No articles and no uidnext. + nil))) + (gnus-set-active + group + (cons (car active) + (or high (1- uidnext))))) + ;; See whether this is a read-only group. + (unless (eq permanent-flags 'not-scanned) + (gnus-group-set-parameter + info 'permanent-flags + (and (or (memq '%* permanent-flags) + (memq '%Seen permanent-flags)) + permanent-flags))) + ;; Update marks and read articles if this isn't a + ;; read-only IMAP group. + (when (setq permanent-flags + (cdr (assq 'permanent-flags (gnus-info-params info)))) + (if (and highestmodseq + (not start-article)) + ;; We've gotten the data by QRESYNCing. + (nnimap-update-qresync-info + info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags) + ;; Do normal non-QRESYNC flag updates. + ;; Update the list of read articles. + (let* ((unread + (gnus-compress-sequence + (gnus-set-difference + (gnus-set-difference + existing + (cdr (assoc '%Seen flags))) + (cdr (assoc '%Flagged flags))))) + (read (gnus-range-difference + (cons start-article high) unread))) + (when (> start-article 1) + (setq read + (gnus-range-nconcat + (if (> start-article 1) + (gnus-sorted-range-intersection + (cons 1 (1- start-article)) + (gnus-info-read info)) + (gnus-info-read info)) + read))) + (when (or (not (listp permanent-flags)) + (memq '%Seen permanent-flags)) + (gnus-info-set-read info read)) + ;; Update the marks. + (setq marks (gnus-info-marks info)) + (dolist (type (cdr nnimap-mark-alist)) + (when (or (not (listp permanent-flags)) + (memq (car (assoc (caddr type) flags)) + permanent-flags) + (memq '%* permanent-flags)) + (let ((old-marks (assoc (car type) marks)) + (new-marks (gnus-compress-sequence - (imap-search (format "SINCE %s" - (nnimap-date-days-ago days))))) - (oldartseq - (gnus-range-difference artseq all-new-articles)) - (oldarts (gnus-uncompress-range oldartseq))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set oldartseq) - "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts)))))) - ((numberp days) - (let ((oldarts (imap-search - (format nnimap-expunge-search-string - (imap-range-to-message-set artseq) - (nnimap-date-days-ago days)))) - (imap-fetch-data-hook - '(nnimap-request-expire-articles-progress))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts))))))))))) - ;; return articles not deleted - articles) - -(deffoo nnimap-request-move-article (article group server accept-form - &optional last move-is-internal) - (when (nnimap-possibly-change-server server) - (save-excursion - (let ((buf (get-buffer-create " *nnimap move*")) - (nnimap-current-move-article article) - (nnimap-current-move-group group) - (nnimap-current-move-server nnimap-current-server) - result) - (gnus-message 10 "nnimap-request-move-article: this is an %s move" - (if move-is-internal - "internal" - "external")) - ;; request the article only when the move is NOT internal - (and (or move-is-internal - (nnimap-request-article article group server)) - (with-current-buffer buf - (buffer-disable-undo (current-buffer)) - (insert-buffer-substring nntp-server-buffer) - (setq result (eval accept-form)) - (kill-buffer buf) - result) - (nnimap-possibly-change-group group server) - (imap-message-flags-add - (imap-range-to-message-set (list article)) - "\\Deleted" 'silent nnimap-server-buffer)) - result)))) - -(deffoo nnimap-request-accept-article (group &optional server last) - (when (nnimap-possibly-change-server server) - (let (uid) - (if (setq uid - (if (string= nnimap-current-server nnimap-current-move-server) - ;; moving article within same server, speed it up... - (and (nnimap-possibly-change-group - nnimap-current-move-group) - (imap-message-copy (number-to-string - nnimap-current-move-article) - group 'dontcreate nil - nnimap-server-buffer)) - (with-current-buffer (current-buffer) - (goto-char (point-min)) - ;; remove any 'From blabla' lines, some IMAP servers - ;; reject the entire message otherwise. - (when (looking-at "^From[^:]") - (delete-region (point) (progn (forward-line) (point)))) - ;; turn into rfc822 format (\r\n eol's) - (while (search-forward "\n" nil t) - (replace-match "\r\n")) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") - group - (nnmail-fetch-field "subject")))) - (when (and last nnmail-cache-accepted-message-ids) - (nnmail-cache-close)) - ;; this 'or' is for Cyrus server bug - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) - (imap-message-append group (current-buffer) nil nil - nnimap-server-buffer))) - (cons group (nth 1 uid)) - (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer)))))) - -(deffoo nnimap-request-delete-group (group force &optional server) - (when (nnimap-possibly-change-server server) - (when (string= group (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) - (with-current-buffer nnimap-server-buffer - (if force - (or (null (imap-mailbox-status group 'uidvalidity)) - (imap-mailbox-delete group)) - ;; UNSUBSCRIBE? - t)))) + (cdr (or (assoc (caddr type) flags) ; %Flagged + (assoc (intern (cadr type) obarray) flags) + (assoc (cadr type) flags)))))) ; "\Flagged" + (setq marks (delq old-marks marks)) + (pop old-marks) + (when (and old-marks + (> start-article 1)) + (setq old-marks (gnus-range-difference + old-marks + (cons start-article high))) + (setq new-marks (gnus-range-nconcat old-marks new-marks))) + (when new-marks + (push (cons (car type) new-marks) marks))))) + (gnus-info-set-marks info marks t)))) + ;; Note the active level for the next run-through. + (gnus-group-set-parameter info 'active (gnus-active group)) + (gnus-group-set-parameter info 'uidvalidity uidvalidity) + (gnus-group-set-parameter info 'modseq highestmodseq) + (nnimap-store-info info (gnus-active group))))))) + +(defun nnimap-update-qresync-info (info existing vanished flags) + ;; Add all the vanished articles to the list of read articles. + (gnus-info-set-read + info + (gnus-add-to-range + (gnus-add-to-range + (gnus-range-add (gnus-info-read info) + vanished) + (cdr (assq '%Flagged flags))) + (cdr (assq '%Seen flags)))) + (let ((marks (gnus-info-marks info))) + (dolist (type (cdr nnimap-mark-alist)) + (let ((ticks (assoc (car type) marks)) + (new-marks + (cdr (or (assoc (caddr type) flags) ; %Flagged + (assoc (intern (cadr type) obarray) flags) + (assoc (cadr type) flags))))) ; "\Flagged" + (setq marks (delq ticks marks)) + (pop ticks) + ;; Add the new marks we got. + (setq ticks (gnus-add-to-range ticks new-marks)) + ;; Remove the marks from messages that don't have them. + (setq ticks (gnus-remove-from-range + ticks + (gnus-compress-sequence + (gnus-sorted-complement existing new-marks)))) + (when ticks + (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)))) + +(defun nnimap-imap-ranges-to-gnus-ranges (irange) + (if (zerop (length irange)) + nil + (let ((result nil)) + (dolist (elem (split-string irange ",")) + (push + (if (string-match ":" elem) + (let ((numbers (split-string elem ":"))) + (cons (string-to-number (car numbers)) + (string-to-number (cadr numbers)))) + (string-to-number elem)) + result)) + (nreverse result)))) + +(defun nnimap-store-info (info active) + (let* ((group (gnus-group-real-name (gnus-info-group info))) + (entry (assoc group nnimap-current-infos))) + (if entry + (setcdr entry (list info active)) + (push (list group info active) nnimap-current-infos)))) + +(defun nnimap-flags-to-marks (groups) + (let (data group totalp uidnext articles start-article mark permanent-flags + uidvalidity vanished highestmodseq) + (dolist (elem groups) + (setq group (car elem) + uidnext (nth 1 elem) + start-article (nth 2 elem) + permanent-flags (nth 3 elem) + uidvalidity (nth 4 elem) + vanished (nth 5 elem) + highestmodseq (nth 6 elem) + articles (nthcdr 7 elem)) + (let ((high (caar articles)) + marks low existing) + (dolist (article articles) + (setq low (car article)) + (push (car article) existing) + (dolist (flag (cdr article)) + (setq mark (assoc flag marks)) + (if (not mark) + (push (list flag (car article)) marks) + (setcdr mark (cons (car article) (cdr mark)))))) + (push (list group existing marks high low uidnext start-article + permanent-flags uidvalidity vanished highestmodseq) + data))) + data)) + +(defun nnimap-parse-flags (sequences) + (goto-char (point-min)) + ;; Change \Delete etc to %Delete, so that the reader can read it. + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) + (let (start end articles groups uidnext elems permanent-flags + uidvalidity vanished highestmodseq) + (dolist (elem sequences) + (destructuring-bind (group-sequence flag-sequence totalp group command) + elem + (setq start (point)) + (when (and + ;; The EXAMINE was successful. + (search-forward (format "\n%d OK " group-sequence) nil t) + (progn + (forward-line 1) + (setq end (point)) + (goto-char start) + (setq permanent-flags + (if (equal command "SELECT") + (and (search-forward "PERMANENTFLAGS " + (or end (point-min)) t) + (read (current-buffer))) + 'not-scanned)) + (goto-char start) + (setq uidnext + (and (search-forward "UIDNEXT " + (or end (point-min)) t) + (read (current-buffer)))) + (goto-char start) + (setq uidvalidity + (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)" + (or end (point-min)) t) + ;; Store UIDVALIDITY as a string, as it's + ;; too big for 32-bit Emacsen, usually. + (match-string 1))) + (goto-char start) + (setq vanished + (and (eq flag-sequence 'qresync) + (re-search-forward "^\\* VANISHED .* \\([0-9:,]+\\)" + (or end (point-min)) t) + (match-string 1))) + (goto-char start) + (setq highestmodseq + (and (search-forward "HIGHESTMODSEQ " + (or end (point-min)) t) + (read (current-buffer)))) + (goto-char end) + (forward-line -1)) + ;; The UID FETCH FLAGS was successful. + (or (eq flag-sequence 'qresync) + (search-forward (format "\n%d OK " flag-sequence) nil t))) + (if (eq flag-sequence 'qresync) + (progn + (goto-char start) + (setq start end)) + (setq start (point)) + (goto-char end)) + (while (re-search-forward "^\\* [0-9]+ FETCH " start t) + (setq elems (read (current-buffer))) + (push (cons (cadr (memq 'UID elems)) + (cadr (memq 'FLAGS elems))) + articles)) + (push (nconc (list group uidnext totalp permanent-flags uidvalidity + vanished highestmodseq) + articles) + groups) + (goto-char end) + (setq articles nil)))) + groups)) + +(defun nnimap-find-process-buffer (buffer) + (cadr (assoc buffer nnimap-connection-alist))) -(deffoo nnimap-request-rename-group (group new-name &optional server) - (when (nnimap-possibly-change-server server) - (imap-mailbox-rename group new-name nnimap-server-buffer))) - -(defun nnimap-expunge (mailbox server) - (when (nnimap-possibly-change-group mailbox server) - (imap-mailbox-expunge nil nnimap-server-buffer))) - -(defun nnimap-acl-get (mailbox server) - (when (nnimap-possibly-change-server server) - (and (imap-capability 'ACL nnimap-server-buffer) - (imap-mailbox-acl-get mailbox nnimap-server-buffer)))) - -(defun nnimap-acl-edit (mailbox method old-acls new-acls) - (when (nnimap-possibly-change-server (cadr method)) - (unless (imap-capability 'ACL nnimap-server-buffer) - (error "Your server does not support ACL editing")) - (with-current-buffer nnimap-server-buffer - ;; delete all removed identifiers - (mapc (lambda (old-acl) - (unless (assoc (car old-acl) new-acls) - (or (imap-mailbox-acl-delete (car old-acl) mailbox) - (error "Can't delete ACL for %s" (car old-acl))))) - old-acls) - ;; set all changed acl's - (mapc (lambda (new-acl) - (let ((new-rights (cdr new-acl)) - (old-rights (cdr (assoc (car new-acl) old-acls)))) - (unless (and old-rights new-rights - (string= old-rights new-rights)) - (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox) - (error "Can't set ACL for %s to %s" (car new-acl) - new-rights))))) - new-acls) - t))) +(deffoo nnimap-request-post (&optional server) + (setq nnimap-status-string "Read-only server") + nil) - -;;; Internal functions - -;; -;; This is confusing. -;; -;; mark => read, tick, draft, reply etc -;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc -;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc -;; -;; Mark should not really contain 'read since it's not a "mark" in the Gnus -;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read). -;; - -(defconst nnimap-mark-to-predicate-alist - (mapcar - (lambda (pair) ; cdr is the mark - (or (assoc (cdr pair) - '((read . "SEEN") - (tick . "FLAGGED") - (draft . "DRAFT") - (recent . "RECENT") - (reply . "ANSWERED"))) - (cons (cdr pair) - (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) - (cons '(read . read) gnus-article-mark-lists))) - -(defun nnimap-mark-to-predicate (pred) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate. -This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\", -to be used within a IMAP SEARCH query." - (cdr (assq pred nnimap-mark-to-predicate-alist))) - -(defconst nnimap-mark-to-flag-alist - (mapcar - (lambda (pair) - (or (assoc (cdr pair) - '((read . "\\Seen") - (tick . "\\Flagged") - (draft . "\\Draft") - (recent . "\\Recent") - (reply . "\\Answered"))) - (cons (cdr pair) - (format "gnus-%s" (symbol-name (cdr pair)))))) - (cons '(read . read) gnus-article-mark-lists))) - -(defun nnimap-mark-to-flag-1 (preds) - (if (and (not (null preds)) (listp preds)) - (cons (nnimap-mark-to-flag (car preds)) - (nnimap-mark-to-flag (cdr preds))) - (cdr (assoc preds nnimap-mark-to-flag-alist)))) - -(defun nnimap-mark-to-flag (preds &optional always-list make-string) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag. -This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to -be used in a STORE FLAGS command." - (let ((result (nnimap-mark-to-flag-1 preds))) - (setq result (if (and (or make-string always-list) - (not (listp result))) - (list result) - result)) - (if make-string - (mapconcat (lambda (flag) - (if (listp flag) - (mapconcat 'identity flag " ") - flag)) - result " ") - result))) - -(defun nnimap-mark-permanent-p (mark &optional group) - "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." - (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) - -(when nnimap-debug - (require 'trace) - (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f nnimap-debug-buffer)) - '( - nnimap-possibly-change-server - nnimap-verify-uidvalidity - nnimap-find-minmax-uid - nnimap-before-find-minmax-bugworkaround - nnimap-possibly-change-group - ;;nnimap-replace-whitespace - nnimap-retrieve-headers-progress - nnimap-retrieve-which-headers - nnimap-group-overview-filename - nnimap-retrieve-headers-from-file - nnimap-retrieve-headers-from-server - nnimap-retrieve-headers - nnimap-open-connection - nnimap-open-server - nnimap-server-opened - nnimap-close-server - nnimap-request-close - nnimap-status-message - ;;nnimap-demule - nnimap-request-article-part - nnimap-request-article - nnimap-request-head - nnimap-request-body - nnimap-request-group - nnimap-close-group - nnimap-pattern-to-list-arguments - nnimap-request-list - nnimap-request-post - nnimap-retrieve-groups - nnimap-request-update-info-internal - nnimap-request-type - nnimap-request-set-mark - nnimap-split-to-groups - nnimap-split-find-rule - nnimap-split-find-inbox - nnimap-split-articles - nnimap-request-scan - nnimap-request-newgroups - nnimap-request-create-group - nnimap-time-substract - nnimap-date-days-ago - nnimap-request-expire-articles-progress - nnimap-request-expire-articles - nnimap-request-move-article - nnimap-request-accept-article - nnimap-request-delete-group - nnimap-request-rename-group - gnus-group-nnimap-expunge - gnus-group-nnimap-edit-acl - gnus-group-nnimap-edit-acl-done - nnimap-group-mode-hook - nnimap-mark-to-predicate - nnimap-mark-to-flag-1 - nnimap-mark-to-flag - nnimap-mark-permanent-p - ))) +(deffoo nnimap-request-thread (header) + (let* ((id (mail-header-id header)) + (refs (split-string + (or (mail-header-references header) + ""))) + (cmd (let ((value + (format + "(OR HEADER REFERENCES %s HEADER Message-Id %s)" + id id))) + (dolist (refid refs value) + (setq value (format + "(OR (OR HEADER Message-Id %s HEADER REFERENCES %s) %s)" + refid refid value))))) + (result (with-current-buffer (nnimap-buffer) + (nnimap-command "UID SEARCH %s" cmd)))) + (gnus-fetch-headers + (and (car result) (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))) + nil t))) + +(defun nnimap-possibly-change-group (group server) + (let ((open-result t)) + (when (and server + (not (nnimap-server-opened server))) + (setq open-result (nnimap-open-server server))) + (cond + ((not open-result) + nil) + ((not group) + t) + (t + (with-current-buffer (nnimap-buffer) + (if (equal group (nnimap-group nnimap-object)) + t + (let ((result (nnimap-command "SELECT %S" (utf7-encode group t)))) + (when (car result) + (setf (nnimap-group nnimap-object) group + (nnimap-select-result nnimap-object) result) + result)))))))) + +(defun nnimap-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((entry (assoc buffer nnimap-connection-alist))) + (when entry + (if (and (buffer-name (cadr entry)) + (get-buffer-process (cadr entry)) + (memq (process-status (get-buffer-process (cadr entry))) + '(open run))) + (get-buffer-process (cadr entry)) + (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) + nil)))) + +(defvar nnimap-sequence 0) + +(defun nnimap-send-command (&rest args) + (process-send-string + (get-buffer-process (current-buffer)) + (nnimap-log-command + (format "%d %s%s\n" + (incf nnimap-sequence) + (apply #'format args) + (if (nnimap-newlinep nnimap-object) + "" + "\r")))) + ;; Some servers apparently can't have many outstanding + ;; commands, so throttle them. + (unless nnimap-streaming + (nnimap-wait-for-response nnimap-sequence)) + nnimap-sequence) + +(defun nnimap-log-command (command) + (with-current-buffer (get-buffer-create "*imap log*") + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") " " command)) + command) + +(defun nnimap-command (&rest args) + (erase-buffer) + (setf (nnimap-last-command-time nnimap-object) (current-time)) + (let* ((sequence (apply #'nnimap-send-command args)) + (response (nnimap-get-response sequence))) + (if (equal (caar response) "OK") + (cons t response) + (nnheader-report 'nnimap "%s" + (mapconcat (lambda (a) + (format "%s" a)) + (car response) " ")) + nil))) + +(defun nnimap-get-response (sequence) + (nnimap-wait-for-response sequence) + (nnimap-parse-response)) + +(defun nnimap-wait-for-connection (&optional regexp) + (nnimap-wait-for-line (or regexp "^[*.] .*\n") "[*.] \\([A-Z0-9]+\\)")) + +(defun nnimap-wait-for-line (regexp &optional response-regexp) + (let ((process (get-buffer-process (current-buffer)))) + (goto-char (point-min)) + (while (and (memq (process-status process) + '(open run)) + (not (re-search-forward regexp nil t))) + (nnheader-accept-process-output process) + (goto-char (point-min))) + (forward-line -1) + (and (looking-at (or response-regexp regexp)) + (match-string 1)))) + +(defun nnimap-wait-for-response (sequence &optional messagep) + (let ((process (get-buffer-process (current-buffer))) + openp) + (condition-case nil + (progn + (goto-char (point-max)) + (while (and (setq openp (memq (process-status process) + '(open run))) + (not (re-search-backward + (format "^%d .*\n" sequence) + (if nnimap-streaming + (max (point-min) + (min + (- (point) 500) + (save-excursion + (forward-line -3) + (point)))) + (point-min)) + t))) + (when messagep + (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000))) + (nnheader-accept-process-output process) + (goto-char (point-max))) + openp) + (quit + ;; The user hit C-g while we were waiting: kill the process, in case + ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind + ;; NAT routers). + (delete-process process) + nil)))) + +(defun nnimap-parse-response () + (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) + result) + (dolist (line lines) + (push (cdr (nnimap-parse-line line)) result)) + ;; Return the OK/error code first, and then all the "continuation + ;; lines" afterwards. + (cons (pop result) + (nreverse result)))) + +;; Parse an IMAP response line lightly. They look like +;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse +;; the lines into a list of strings and lists of string. +(defun nnimap-parse-line (line) + (let (char result) + (with-temp-buffer + (mm-disable-multibyte) + (insert line) + (goto-char (point-min)) + (while (not (eobp)) + (if (eql (setq char (following-char)) ? ) + (forward-char 1) + (push + (cond + ((eql char ?\[) + (split-string + (buffer-substring + (1+ (point)) + (if (search-forward "]" (line-end-position) 'move) + (1- (point)) + (point))))) + ((eql char ?\() + (split-string + (buffer-substring + (1+ (point)) + (if (search-forward ")" (line-end-position) 'move) + (1- (point)) + (point))))) + ((eql char ?\") + (forward-char 1) + (buffer-substring + (point) + (1- (or (search-forward "\"" (line-end-position) 'move) + (point))))) + (t + (buffer-substring (point) (if (search-forward " " nil t) + (1- (point)) + (goto-char (point-max)))))) + result))) + (nreverse result)))) + +(defun nnimap-last-response-string () + (save-excursion + (forward-line 1) + (let ((end (point))) + (forward-line -1) + (when (not (bobp)) + (forward-line -1) + (while (and (not (bobp)) + (eql (following-char) ?*)) + (forward-line -1)) + (unless (eql (following-char) ?*) + (forward-line 1))) + (buffer-substring (point) end)))) + +(defun nnimap-get-responses (sequences) + (let (responses) + (dolist (sequence sequences) + (goto-char (point-min)) + (when (re-search-forward (format "^%d " sequence) nil t) + (push (list sequence (nnimap-parse-response)) + responses))) + responses)) + +(defvar nnimap-incoming-split-list nil) + +(defun nnimap-fetch-inbox (articles) + (erase-buffer) + (nnimap-wait-for-response + (nnimap-send-command + "UID FETCH %s %s" + (nnimap-article-ranges articles) + (format "(UID %s%s)" + (format + (if (nnimap-ver4-p) + "BODY.PEEK[HEADER] BODY.PEEK" + "RFC822.PEEK")) + (if nnimap-split-download-body-default + "[]" + "[1]"))) + t)) + +(defun nnimap-split-incoming-mail () + (with-current-buffer (nnimap-buffer) + (let ((nnimap-incoming-split-list nil) + (nnmail-split-methods (if (eq nnimap-split-methods 'default) + nnmail-split-methods + nnimap-split-methods)) + (nnmail-split-fancy (or nnimap-split-fancy + nnmail-split-fancy)) + (nnmail-inhibit-default-split-group t) + (groups (nnimap-get-groups)) + new-articles) + (erase-buffer) + (nnimap-command "SELECT %S" nnimap-inbox) + (setf (nnimap-group nnimap-object) nnimap-inbox) + (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*"))) + (when new-articles + (nnimap-fetch-inbox new-articles) + (nnimap-transform-split-mail) + (nnheader-ms-strip-cr) + (nnmail-cache-open) + (nnmail-split-incoming (current-buffer) + #'nnimap-save-mail-spec + nil nil + #'nnimap-dummy-active-number + #'nnimap-save-mail-spec) + (when nnimap-incoming-split-list + (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list)) + sequences junk-articles) + ;; Create any groups that doesn't already exist on the + ;; server first. + (dolist (spec specs) + (when (and (not (member (car spec) groups)) + (not (eq (car spec) 'junk))) + (nnimap-command "CREATE %S" (utf7-encode (car spec) t)))) + ;; Then copy over all the messages. + (erase-buffer) + (dolist (spec specs) + (let ((group (car spec)) + (ranges (cdr spec))) + (if (eq group 'junk) + (setq junk-articles ranges) + (push (list (nnimap-send-command + "UID COPY %s %S" + (nnimap-article-ranges ranges) + (utf7-encode group t)) + ranges) + sequences)))) + ;; Wait for the last COPY response... + (when sequences + (nnimap-wait-for-response (caar sequences)) + ;; And then mark the successful copy actions as deleted, + ;; and possibly expunge them. + (nnimap-mark-and-expunge-incoming + (nnimap-parse-copied-articles sequences))) + (nnimap-mark-and-expunge-incoming junk-articles))))))) + +(defun nnimap-mark-and-expunge-incoming (range) + (when range + (setq range (nnimap-article-ranges range)) + (erase-buffer) + (let ((sequence + (nnimap-send-command + "UID STORE %s +FLAGS.SILENT (\\Deleted)" range))) + (cond + ;; If the server supports it, we now delete the message we have + ;; just copied over. + ((nnimap-capability "UIDPLUS") + (setq sequence (nnimap-send-command "UID EXPUNGE %s" range))) + ;; If it doesn't support UID EXPUNGE, then we only expunge if the + ;; user has configured it. + (nnimap-expunge + (setq sequence (nnimap-send-command "EXPUNGE")))) + (nnimap-wait-for-response sequence)))) + +(defun nnimap-parse-copied-articles (sequences) + (let (sequence copied range) + (goto-char (point-min)) + (while (re-search-forward "^\\([0-9]+\\) OK " nil t) + (setq sequence (string-to-number (match-string 1))) + (when (setq range (cadr (assq sequence sequences))) + (push (gnus-uncompress-range range) copied))) + (gnus-compress-sequence (sort (apply #'nconc copied) #'<)))) + +(defun nnimap-new-articles (flags) + (let (new) + (dolist (elem flags) + (unless (gnus-list-memq-of-list nnimap-unsplittable-articles + (cdr elem)) + (push (car elem) new))) + (gnus-compress-sequence (nreverse new)))) + +(defun nnimap-make-split-specs (list) + (let ((specs nil) + entry) + (dolist (elem list) + (destructuring-bind (article spec) elem + (dolist (group (delete nil (mapcar #'car spec))) + (unless (setq entry (assoc group specs)) + (push (setq entry (list group)) specs)) + (setcdr entry (cons article (cdr entry)))))) + (dolist (entry specs) + (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<)))) + specs)) + +(defun nnimap-transform-split-mail () + (goto-char (point-min)) + (let (article bytes) + (block nil + (while (not (eobp)) + (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (delete-region (point) (progn (forward-line 1) (point))) + (when (eobp) + (return))) + (setq article (match-string 1) + bytes (nnimap-get-length)) + (delete-region (line-beginning-position) (line-end-position)) + ;; Insert MMDF separator, and a way to remember what this + ;; article UID is. + (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article)) + (forward-char (1+ bytes)) + (setq bytes (nnimap-get-length)) + (delete-region (line-beginning-position) (line-end-position)) + ;; There's a body; skip past that. + (when bytes + (forward-char (1+ bytes)) + (delete-region (line-beginning-position) (line-end-position))))))) + +(defun nnimap-dummy-active-number (group &optional server) + 1) + +(defun nnimap-save-mail-spec (group-art &optional server full-nov) + (let (article) + (goto-char (point-min)) + (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t)) + (error "Invalid nnimap mail") + (setq article (string-to-number (match-string 1)))) + (push (list article + (if (eq group-art 'junk) + (list (cons 'junk 1)) + group-art)) + nnimap-incoming-split-list))) (provide 'nnimap) -;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b ;;; nnimap.el ends here diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 14d1abd5bb..0fc00770c8 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -32,163 +32,41 @@ ;; TODO: Documentation in the Gnus manual -;; From: Reiner Steib -;; Subject: Re: Including nnir.el -;; Newsgroups: gmane.emacs.gnus.general -;; Message-ID: <[email protected]> -;; Date: 2006-06-05 22:49:01 GMT -;; -;; On Sun, Jun 04 2006, Sascha Wilde wrote: -;; -;; > The one thing most hackers like to forget: Documentation. By now the -;; > documentation is only in the comments at the head of the source, I -;; > would use it as basis to cook up some minimal texinfo docs. -;; > -;; > Where in the existing gnus manual would this fit best? - -;; Maybe (info "(gnus)Combined Groups") for a general description. -;; `gnus-group-make-nnir-group' might be described in (info -;; "(gnus)Foreign Groups") as well. - - -;; The most recent version of this can always be fetched from the Gnus -;; repository. See http://www.gnus.org/ for more information. - -;; This code is still in the development stage but I'd like other -;; people to have a look at it. Please do not hesitate to contact me -;; with your ideas. +;; Where in the existing gnus manual would this fit best? -;; What does it do? Well, it allows you to index your mail using some -;; search engine (freeWAIS-sf, swish-e and others -- see later), -;; then type `G G' in the Group buffer and issue a query to the search -;; engine. You will then get a buffer which shows all articles -;; matching the query, sorted by Retrieval Status Value (score). +;; What does it do? Well, it allows you to search your mail using +;; some search engine (imap, namazu, swish-e, gmane and others -- see +;; later) by typing `G G' in the Group buffer. You will then get a +;; buffer which shows all articles matching the query, sorted by +;; Retrieval Status Value (score). ;; When looking at the retrieval result (in the Summary buffer) you -;; can type `G T' (aka M-x gnus-summary-nnir-goto-thread RET) on an -;; article. You will be teleported into the group this article came -;; from, showing the thread this article is part of. (See below for -;; restrictions.) - -;; The Lisp installation is simple: just put this file on your -;; load-path, byte-compile it, and load it from ~/.gnus or something. -;; This will install a new command `G G' in your Group buffer for -;; searching your mail. Note that you also need to configure a number -;; of variables, as described below. - -;; Restrictions: -;; -;; * If you don't use HyREX as your search engine, this expects that -;; you use nnml or another one-file-per-message backend, because the -;; others doesn't support nnfolder. -;; * It can only search the mail backend's which are supported by one -;; search engine, because of different query languages. -;; * There are restrictions to the Wais setup. -;; * There are restrictions to the imap setup. -;; * gnus-summary-nnir-goto-thread: Fetches whole group first, before -;; limiting to the right articles. This is much too slow, of -;; course. May issue a query for number of articles to fetch; you -;; must accept the default of all articles at this point or things -;; may break. - -;; The Lisp setup involves setting a few variables and setting up the +;; 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 T' +;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and +;; also show the thread this article is part of. + +;; The Lisp setup may involve setting a few variables and setting up the ;; search engine. You can define the variables in the server definition ;; like this : ;; (setq gnus-secondary-select-methods '( ;; (nnimap "" (nnimap-address "localhost") -;; (nnir-search-engine hyrex) -;; (nnir-hyrex-additional-switches ("-d" "ddl-nnimap.xml")) +;; (nnir-search-engine namazu) ;; ))) -;; Or you can define the global ones. The variables set in the mailer- -;; definition will be used first. -;; The variable to set is `nnir-search-engine'. Choose one of the engines -;; listed in `nnir-engines'. (Actually `nnir-engines' is an alist, -;; type `C-h v nnir-engines RET' for more information; this includes -;; examples for setting `nnir-search-engine', too.) -;; -;; The variable nnir-mail-backend isn't used anymore. -;; +;; The main variable to set is `nnir-search-engine'. Choose one of +;; the engines listed in `nnir-engines'. (Actually `nnir-engines' is +;; an alist, type `C-h v nnir-engines RET' for more information; this +;; includes examples for setting `nnir-search-engine', too.) -;; You must also set up a search engine. I'll tell you about the two -;; search engines currently supported: +;; If you use one of the local indices (namazu, find-grep, swish) you +;; must also set up a search engine backend. -;; 1. freeWAIS-sf -;; -;; As always with freeWAIS-sf, you need a so-called `format file'. I -;; use the following file: -;; -;; ,----- -;; | # Kai's format file for freeWAIS-sf for indexing mails. -;; | # Each mail is in a file, much like the MH format. -;; | -;; | # Document separator should never match -- each file is a document. -;; | record-sep: /^@this regex should never match@$/ -;; | -;; | # Searchable fields specification. -;; | -;; | region: /^[sS]ubject:/ /^[sS]ubject: */ -;; | subject "Subject header" stemming TEXT BOTH -;; | end: /^[^ \t]/ -;; | -;; | region: /^([tT][oO]|[cC][cC]):/ /^([tT][oO]|[cC][cC]): */ -;; | to "To and Cc headers" SOUNDEX BOTH -;; | end: /^[^ \t]/ -;; | -;; | region: /^[fF][rR][oO][mM]:/ /^[fF][rR][oO][mM]: */ -;; | from "From header" SOUNDEX BOTH -;; | end: /^[^ \t]/ -;; | -;; | region: /^$/ -;; | stemming TEXT GLOBAL -;; | end: /^@this regex should never match@$/ -;; `----- -;; -;; 1998-07-22: waisindex would dump core on me for large articles with -;; the above settings. I used /^$/ as the end regex for the global -;; field. That seemed to work okay. - -;; There is a Perl module called `WAIS.pm' which is available from -;; CPAN as well as ls6-ftp.cs.uni-dortmund.de:/pub/wais/Perl. This -;; module comes with a nifty tool called `makedb', which I use for -;; indexing. Here's my `makedb.conf': -;; -;; ,----- -;; | # Config file for makedb -;; | -;; | # Global options -;; | waisindex = /usr/local/bin/waisindex -;; | wais_opt = -stem -t fields -;; | # `-stem' option necessary when `stemming' is specified for the -;; | # global field in the *.fmt file -;; | -;; | # Own variables -;; | homedir = /home/kai -;; | -;; | # The mail database. -;; | database = mail -;; | files = `find $homedir/Mail -name \*[0-9] -print` -;; | dbdir = $homedir/.wais -;; | limit = 100 -;; `----- -;; -;; The Lisp setup involves the `nnir-wais-*' variables. The most -;; difficult to understand variable is probably -;; `nnir-wais-remove-prefix'. Here's what it does: the output of -;; `waissearch' basically contains the file name and the (full) -;; directory name. As Gnus works with group names rather than -;; directory names, the directory name is transformed into a group -;; name as follows: first, a prefix is removed from the (full) -;; directory name, then all `/' are replaced with `.'. The variable -;; `nnir-wais-remove-prefix' should contain a regex matching exactly -;; this prefix. It defaults to `$HOME/Mail/' (note the trailing -;; slash). - -;; 2. Namazu +;; 1. Namazu ;; ;; The Namazu backend requires you to have one directory containing all ;; index files, this is controlled by the `nnir-namazu-index-directory' ;; variable. To function the `nnir-namazu-remove-prefix' variable must -;; also be correct, see the documentation for `nnir-wais-remove-prefix' +;; also be correct, see the documentation for `nnir-namazu-remove-prefix' ;; above. ;; ;; It is particularly important not to pass any any switches to namazu @@ -227,18 +105,7 @@ ;; For maximum searching efficiency I have a cron job set to run this ;; command every four hours. -;; 3. HyREX -;; -;; The HyREX backend requires you to have one directory from where all -;; your relative paths are to, if you use them. This directory must be -;; set in the `nnir-hyrex-index-directory' variable, which defaults to -;; your home directory. You must also pass the base, class and -;; directory options or simply your dll to the `nnir-hyrex-programm' by -;; setting the `nnir-hyrex-additional-switches' variable accordently. -;; To function the `nnir-hyrex-remove-prefix' variable must also be -;; correct, see the documentation for `nnir-wais-remove-prefix' above. - -;; 4. find-grep +;; 2. find-grep ;; ;; The find-grep engine simply runs find(1) to locate eligible ;; articles and searches them with grep(1). This, of course, is much @@ -263,10 +130,10 @@ ;; I have tried to make the code expandable. Basically, it is divided ;; into two layers. The upper layer is somewhat like the `nnvirtual' -;; or `nnkiboze' backends: given a specification of what articles to -;; show from another backend, it creates a group containing exactly -;; those articles. The lower layer issues a query to a search engine -;; and produces such a specification of what articles to show from the +;; backend: given a specification of what articles to show from +;; another backend, it creates a group containing exactly those +;; articles. The lower layer issues a query to a search engine and +;; produces such a specification of what articles to show from the ;; other backend. ;; The interface between the two layers consists of the single @@ -294,177 +161,187 @@ ;; function should return the list of articles as a vector, as ;; described above. Then, you need to register this backend in ;; `nnir-engines'. Then, users can choose the backend by setting -;; `nnir-search-engine'. - -;; Todo, or future ideas: +;; `nnir-search-engine' as a server variable. -;; * It should be possible to restrict search to certain groups. -;; -;; * There is currently no error checking. -;; -;; * The summary buffer display is currently really ugly, with all the -;; added information in the subjects. How could I make this -;; prettier? -;; -;; * A function which can be called from an nnir summary buffer which -;; teleports you into the group the current article came from and -;; shows you the whole thread this article is part of. -;; Implementation suggestions? -;; (1998-07-24: There is now a preliminary implementation, but -;; it is much too slow and quite fragile.) -;; -;; * Support other mail backends. In particular, probably quite a few -;; people use nnfolder. How would one go about searching nnfolders -;; and producing the right data needed? The group name and the RSV -;; are simple, but what about the article number? -;; - The article number is encoded in the `X-Gnus-Article-Number' -;; header of each mail. -;; - The HyREX engine supports nnfolder. -;; -;; * Support compressed mail files. Probably, just stripping off the -;; `.gz' or `.Z' file name extension is sufficient. -;; -;; * At least for imap, the query is performed twice. -;; +;;; Code: -;; Have you got other ideas? +;;; Setup: -;;; Setup Code: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'nnoo) (require 'gnus-group) -(require 'gnus-sum) (require 'message) (require 'gnus-util) (eval-when-compile (require 'cl)) -(nnoo-declare nnir) -(nnoo-define-basics nnir) +;;; Internal Variables: -(gnus-declare-backend "nnir" 'mail) +(defvar nnir-current-query nil + "Internal: stores current query (= group name).") + +(defvar nnir-current-server nil + "Internal: stores current server (does it ever change?).") + +(defvar nnir-current-group-marked nil + "Internal: stores current list of process-marked groups.") + +(defvar nnir-artlist nil + "Internal: stores search result.") + +(defvar nnir-tmp-buffer " *nnir*" + "Internal: temporary buffer.") + +(defvar nnir-search-history () + "Internal: the history for querying search options in nnir") -(defvar nnir-imap-search-field "TEXT" - "The IMAP search item when doing an nnir search") +(defvar nnir-extra-parms nil + "Internal: stores request for extra search parms") + +;; Imap variables (defvar nnir-imap-search-arguments '(("Whole message" . "TEXT") ("Subject" . "SUBJECT") ("To" . "TO") ("From" . "FROM") - (nil . "HEADER \"%s\"")) - "Mapping from user readable strings to IMAP search items for use in nnir") + ("Imap" . "")) + "Mapping from user readable keys to IMAP search items for use in nnir") + +(defvar nnir-imap-search-other "HEADER %S" + "The IMAP search item to use for anything other than + `nnir-imap-search-arguments'. By default this is the name of an + email header field") (defvar nnir-imap-search-argument-history () "The history for querying search options in nnir") -;;; Developer Extension Variable: +;;; Helper macros -(defvar nnir-engines - `((wais nnir-run-waissearch - ()) - (imap nnir-run-imap - ((criteria - "Search in: " ; Prompt - ,nnir-imap-search-arguments ; alist for completing - nil ; no filtering - nil ; allow any user input - nil ; initial value - nnir-imap-search-argument-history ; the history to use - ,nnir-imap-search-field ; default - ))) - (swish++ nnir-run-swish++ - ((group . "Group spec: "))) - (swish-e nnir-run-swish-e - ((group . "Group spec: "))) - (namazu nnir-run-namazu - ()) - (hyrex nnir-run-hyrex - ((group . "Group spec: "))) - (find-grep nnir-run-find-grep - ((grep-options . "Grep options: ")))) - "Alist of supported search engines. -Each element in the alist is a three-element list (ENGINE FUNCTION ARGS). -ENGINE is a symbol designating the searching engine. FUNCTION is also -a symbol, giving the function that does the search. The third element -ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query, -the FUNCTION will issue a query for each of the PARAMs, using PROMPT. +;; Data type article list. -The value of `nnir-search-engine' must be one of the ENGINE symbols. -For example, use the following line for searching using freeWAIS-sf: - (setq nnir-search-engine 'wais) -Use the following line if you read your mail via IMAP and your IMAP -server supports searching: - (setq nnir-search-engine 'imap) -Note that you have to set additional variables for most backends. For -example, the `wais' backend needs the variables `nnir-wais-program', -`nnir-wais-database' and `nnir-wais-remove-prefix'. +(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) + (mapc + (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))) + +;;; Finish setup: + +(require 'gnus-sum) + +(eval-when-compile + (autoload 'nnimap-buffer "nnimap") + (autoload 'nnimap-command "nnimap") + (autoload 'nnimap-possibly-change-group "nnimap") + (autoload 'gnus-registry-action "gnus-registry") + (defvar gnus-registry-install)) + + +(nnoo-declare nnir) +(nnoo-define-basics nnir) + +(gnus-declare-backend "nnir" 'mail) -Add an entry here when adding a new search engine.") ;;; User Customizable Variables: (defgroup nnir nil - "Search nnmh and nnml groups in Gnus with swish-e, freeWAIS-sf, or EWS." + "Search groups in Gnus with assorted seach engines." :group 'gnus) -;; Mail backend. - -;; TODO: -;; If `nil', use server parameters to find out which server to search. CCC -;; -(defcustom nnir-mail-backend '(nnml "") - "*Specifies which backend should be searched. -More precisely, this is used to determine from which backend to fetch the -messages found. - -This must be equal to an existing server, so maybe it is best to use -something like the following: - (setq nnir-mail-backend (nth 0 gnus-secondary-select-methods)) -The above line works fine if the mail backend you want to search is -the first element of gnus-secondary-select-methods (`nth' starts counting -at zero)." - :type '(sexp) +(defcustom nnir-ignored-newsgroups "" + "*A regexp to match newsgroups in the active file that should + be skipped when searching." + :type '(regexp) :group 'nnir) -;; Search engine to use. +(defcustom nnir-summary-line-format nil + "*The format specification of the lines in an nnir summary buffer. -(defcustom nnir-search-engine 'wais - "*The search engine to use. Must be a symbol. -See `nnir-engines' for a list of supported engines, and for example -settings of `nnir-search-engine'." - :type '(sexp) - :group 'nnir) +All the items from `gnus-summary-line-format' are available, along +with three items unique to nnir summary buffers: -;; freeWAIS-sf. +%Z Search retrieval score value (integer) +%G Article original full group name (string) +%g Article original short group name (string) -(defcustom nnir-wais-program "waissearch" - "*Name of waissearch executable." +If nil this will use `gnus-summary-line-format'." :type '(string) :group 'nnir) -(defcustom nnir-wais-database (expand-file-name "~/.wais/mail") - "*Name of Wais database containing the mail. +(defcustom 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. -Note that this should be a file name without extension. For example, -if you have a file /home/john/.wais/mail.fmt, use this: - (setq nnir-wais-database \"/home/john/.wais/mail\") -The string given here is passed to `waissearch -d' as-is." - :type '(file) +If this variable is nil, or if the provided function returns nil for a search +result, `gnus-retrieve-headers' will be called instead." + :type '(function) :group 'nnir) -(defcustom nnir-wais-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each directory name returned by waissearch -in order to get a group name (albeit with / instead of .). This is a -regular expression. - -For example, suppose that Wais returns file names such as -\"/home/john/Mail/mail/misc/42\". For this example, use the following -setting: (setq nnir-wais-remove-prefix \"/home/john/Mail/\") -Note the trailing slash. Removing this prefix gives \"mail/misc/42\". -`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to -arrive at the correct group name, \"mail.misc\"." - :type '(regexp) +(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\"." + :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) + nnir-imap-search-arguments)) :group 'nnir) (defcustom nnir-swish++-configuration-file @@ -493,14 +370,13 @@ Instead, use this: in order to get a group name (albeit with / instead of .). This is a regular expression. -This variable is very similar to `nnir-wais-remove-prefix', except -that it is for swish++, not Wais." +This variable is very similar to `nnir-namazu-remove-prefix', except +that it is for swish++, not Namazu." :type '(regexp) :group 'nnir) ;; Swish-E. -;; URL: http://sunsite.berkeley.edu/SWISH-E/ -;; New version: http://www.boe.es/swish-e +;; URL: http://swish-e.org/ ;; Variables `nnir-swish-e-index-file', `nnir-swish-e-program' and ;; `nnir-swish-e-additional-switches' @@ -545,8 +421,8 @@ This could be a server parameter." in order to get a group name (albeit with / instead of .). This is a regular expression. -This variable is very similar to `nnir-wais-remove-prefix', except -that it is for swish-e, not Wais. +This variable is very similar to `nnir-namazu-remove-prefix', except +that it is for swish-e, not Namazu. This could be a server parameter." :type '(regexp) @@ -586,7 +462,7 @@ arrive at the correct group name, \"mail.misc\"." :type '(directory) :group 'nnir) -;; Namazu engine, see <URL:http://ww.namazu.org/> +;; Namazu engine, see <URL:http://www.namazu.org/> (defcustom nnir-namazu-program "namazu" "*Name of Namazu search executable." @@ -614,118 +490,97 @@ Instead, use this: "*The prefix to remove from each file name returned by Namazu in order to get a group name (albeit with / instead of .). -This variable is very similar to `nnir-wais-remove-prefix', except -that it is for Namazu, not Wais." +For example, suppose that Namazu returns file names such as +\"/home/john/Mail/mail/misc/42\". For this example, use the following +setting: (setq nnir-namazu-remove-prefix \"/home/john/Mail/\") +Note the trailing slash. Removing this prefix gives \"mail/misc/42\". +`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to +arrive at the correct group name, \"mail.misc\"." :type '(directory) :group 'nnir) -;;; Internal Variables: - -(defvar nnir-current-query nil - "Internal: stores current query (= group name).") - -(defvar nnir-current-server nil - "Internal: stores current server (does it ever change?).") +;;; Developer Extension Variable: -(defvar nnir-current-group-marked nil - "Internal: stores current list of process-marked groups.") +(defvar nnir-engines + `((imap nnir-run-imap + ((criteria + "Imap Search in" ; Prompt + ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing + nil ; allow any user input + nil ; initial value + nnir-imap-search-argument-history ; the history to use + ,nnir-imap-default-search-key ; default + ))) + (gmane nnir-run-gmane + ((author . "Gmane Author: "))) + (swish++ nnir-run-swish++ + ((group . "Swish++ Group spec: "))) + (swish-e nnir-run-swish-e + ((group . "Swish-e Group spec: "))) + (namazu nnir-run-namazu + ()) + (hyrex nnir-run-hyrex + ((group . "Hyrex Group spec: "))) + (find-grep nnir-run-find-grep + ((grep-options . "Grep options: ")))) + "Alist of supported search engines. +Each element in the alist is a three-element list (ENGINE FUNCTION ARGS). +ENGINE is a symbol designating the searching engine. FUNCTION is also +a symbol, giving the function that does the search. The third element +ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query, +the FUNCTION will issue a query for each of the PARAMs, using PROMPT. -(defvar nnir-artlist nil - "Internal: stores search result.") +The value of `nnir-search-engine' must be one of the ENGINE symbols. +For example, for searching a server using namazu include + (nnir-search-engine namazu) +in the server definition. Note that you have to set additional +variables for most backends. For example, the `namazu' backend +needs the variables `nnir-namazu-program', +`nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'. -(defvar nnir-tmp-buffer " *nnir*" - "Internal: temporary buffer.") +Add an entry here when adding a new search engine.") -;;; Code: +(defcustom nnir-method-default-engines + '((nnimap . imap) + (nntp . gmane)) + "*Alist of default search engines keyed by server method." + :type `(repeat (cons (choice (const nnimap) (const nttp) (const nnspool) + (const nneething) (const nndir) (const nnmbox) + (const nnml) (const nnmh) (const nndraft) + (const nnfolder) (const nnmaildir)) + (choice + ,@(mapcar (lambda (elem) (list 'const (car elem))) + nnir-engines)))) + :group 'nnir) ;; Gnus glue. -(defun gnus-group-make-nnir-group (extra-parms query) +(defun gnus-group-make-nnir-group (nnir-extra-parms) "Create an nnir group. Asks for query." - (interactive "P\nsQuery: ") + (interactive "P") (setq nnir-current-query nil nnir-current-server nil nnir-current-group-marked nil nnir-artlist nil) - (let ((parms nil)) - (if extra-parms - (setq parms (nnir-read-parms query)) - (setq parms (list (cons 'query query)))) + (let* ((query (read-string "Query: " nil 'nnir-search-history)) + (parms (list (cons 'query query))) + (srv (if (gnus-server-server-name) + "all" ""))) (add-to-list 'parms (cons 'unique-id (message-unique-id)) t) (gnus-group-read-ephemeral-group - (concat "nnir:" (prin1-to-string parms)) '(nnir "") t - (cons (current-buffer) - gnus-current-window-configuration) + (concat "nnir:" (prin1-to-string parms)) (list 'nnir srv) t + (cons (current-buffer) gnus-current-window-configuration) nil))) -(eval-when-compile - (when (featurep 'xemacs) - ;; The `kbd' macro requires that the `read-kbd-macro' macro is available. - (require 'edmacro))) - -(defun nnir-group-mode-hook () - (define-key gnus-group-mode-map (kbd "G G") - 'gnus-group-make-nnir-group)) -(add-hook 'gnus-group-mode-hook 'nnir-group-mode-hook) - -;; Why is this needed? Is this for compatibility with old/new gnusae? Using -;; gnus-group-server instead works for me. -- Justus Piater -(defmacro nnir-group-server (group) - "Return the server for a newsgroup GROUP. -The returned format is as `gnus-server-to-method' needs it. See -`gnus-group-real-prefix' and `gnus-group-real-name'." - `(let ((gname ,group)) - (if (string-match "^\\([^:]+\\):" gname) - (progn - (setq gname (match-string 1 gname)) - (if (string-match "^\\([^+]+\\)\\+\\(.+\\)$" gname) - (format "%s:%s" (match-string 1 gname) (match-string 2 gname)) - (concat gname ":"))) - (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method))))) - -;; Summary mode commands. - -(defun gnus-summary-nnir-goto-thread () - "Only applies to nnir groups. Go to group this article came from -and show thread that contains this article." - (interactive) - (unless (eq 'nnir (car (gnus-find-method-for-group gnus-newsgroup-name))) - (error "Can't execute this command unless in nnir group")) - (let* ((cur (gnus-summary-article-number)) - (group (nnir-artlist-artitem-group nnir-artlist cur)) - (backend-number (nnir-artlist-artitem-number nnir-artlist cur)) - server backend-group) - (setq server (nnir-group-server group)) - (setq backend-group (gnus-group-real-name group)) - (gnus-group-read-ephemeral-group - backend-group - (gnus-server-to-method server) - t ; activate - (cons (current-buffer) - 'summary) ; window config - nil - (list backend-number)) - (gnus-summary-limit (list backend-number)) - (gnus-summary-refer-thread))) - -(if (fboundp 'eval-after-load) - (eval-after-load "gnus-sum" - '(define-key gnus-summary-goto-map - "T" 'gnus-summary-nnir-goto-thread)) - (add-hook 'gnus-summary-mode-hook - (function (lambda () - (define-key gnus-summary-goto-map - "T" 'gnus-summary-nnir-goto-thread))))) - - ;; Gnus backend interface functions. (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) +(deffoo nnir-request-group (group &optional server fast info) "GROUP is the query string." (nnir-possibly-change-server server) ;; Check for cache and return that if appropriate. @@ -735,111 +590,140 @@ and show thread that contains this article." (equal server nnir-current-server))) nnir-artlist ;; Cache miss. - (setq nnir-artlist (nnir-run-query group))) - (save-excursion - (set-buffer nntp-server-buffer) + (setq nnir-artlist (nnir-run-query group server))) + (with-current-buffer nntp-server-buffer + (setq nnir-current-query group) + (when server (setq nnir-current-server server)) + (setq nnir-current-group-marked gnus-group-marked) (if (zerop (length nnir-artlist)) - (progn - (setq nnir-current-query nil - nnir-current-server nil - nnir-current-group-marked nil - nnir-artlist nil) - (nnheader-report 'nnir "Search produced empty results.")) + (nnheader-report 'nnir "Search produced empty results.") ;; Remember data for cache. - (setq nnir-current-query group) - (when server (setq nnir-current-server server)) - (setq nnir-current-group-marked gnus-group-marked) (nnheader-insert "211 %d %d %d %s\n" (nnir-artlist-length nnir-artlist) ; total # 1 ; first # (nnir-artlist-length nnir-artlist) ; last # - group)))) ; group name + 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 (nnir-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))) - (case (setq foo (gnus-retrieve-headers (list artno) artfullgroup nil)) + (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 - (goto-char (point-min)) - (setq novitem (nnheader-parse-nov)) - (unless novitem - (pop-to-buffer nntp-server-buffer) - (error - "nnheader-parse-nov returned nil for article %s in group %s" - artno artfullgroup))) + (setq parsefunc 'nnheader-parse-nov)) (headers - (goto-char (point-min)) - (setq novitem (nnheader-parse-head)) - (unless novitem - (pop-to-buffer nntp-server-buffer) - (error - "nnheader-parse-head returned nil for article %s in group %s" - artno artfullgroup))) - (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 - (mail-header-set-number novitem art) - (mail-header-set-from novitem - (mail-header-from novitem)) - (mail-header-set-subject - novitem - (format "[%d: %s/%d] %s" - artrsv artgroup artno - (mail-header-subject novitem))) - ;;-(mail-header-set-extra novitem nil) - (push novitem novdata) - (setq artlist (cdr artlist))) - (setq novdata (nreverse novdata)) - (set-buffer nntp-server-buffer) (erase-buffer) - (mapc 'nnheader-insert-nov novdata) + (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 (rassq artno articleids)))) + (when art + (mail-header-set-number novitem art) + (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))) - (set-buffer nntp-server-buffer) - (erase-buffer) + (let ((artfullgroup (nnir-article-group article)) + (artno (nnir-article-number article))) (message "Requesting article %d from group %s" artno artfullgroup) - (gnus-request-article artno artfullgroup nntp-server-buffer) + (if to-buffer + (with-current-buffer to-buffer + (let ((gnus-article-decode-hook nil)) + (gnus-request-article-this-buffer artno artfullgroup))) + (gnus-request-article artno artfullgroup)) (cons artfullgroup artno))))) +(deffoo nnir-request-move-article (article group server accept-form + &optional last internal-move-group) + (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)) + (move-is-internal (gnus-server-equal from-method to-method))) + (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 + (nth 1 from-method) + accept-form + last + (and move-is-internal + to-newsgroup ; Not respooling + (gnus-group-real-name to-newsgroup))))) + +(deffoo nnir-request-expire-articles (articles group &optional server force) + (if force + (let ((articles-by-group (nnir-categorize + articles nnir-article-group nnir-article-ids)) + not-deleted) + (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) '<))) + (unless (gnus-check-backend-function 'request-expire-articles + artgroup) + (error "The group %s does not support article deletion" artgroup)) + (unless (gnus-check-server (gnus-find-method-for-group artgroup)) + (error "Couldn't open server for group %s" artgroup)) + (push (gnus-request-expire-articles + artlist artgroup force) + not-deleted))) + (sort (delq nil not-deleted) '<)) + articles)) + +(deffoo nnir-warp-to-article () + (let* ((cur (if (> (gnus-summary-article-number) 0) + (gnus-summary-article-number) + (error "This is not a real article."))) + (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)))) (nnoo-define-skeleton nnir) @@ -866,7 +750,9 @@ ready to be added to the list of search results." (when (file-readable-p (concat prefix dirnam article)) ;; remove trailing slash and, for nnmaildir, cur/new/tmp (setq dirnam - (substring dirnam 0 (if (string= server "nnmaildir:") -5 -1))) + (substring dirnam 0 + (if (string= (gnus-group-server server) "nnmaildir") + -5 -1))) ;; Set group to dirnam without any leading dots or slashes, ;; and with all subsequent slashes replaced by dots @@ -874,8 +760,8 @@ ready to be added to the list of search results." (gnus-replace-in-string dirnam "^[./\\]" "" t) "[/\\]" "." t))) - (vector (nnir-group-full-name group server) - (if (string= server "nnmaildir:") + (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)) group nil) @@ -884,94 +770,50 @@ ready to be added to the list of search results." ;;; Search Engine Interfaces: -;; freeWAIS-sf interface. -(defun nnir-run-waissearch (query server &optional group) - "Run given query agains waissearch. Returns vector of (group name, file name) -pairs (also vectors, actually)." - (when group - (error "The freeWAIS-sf backend cannot search specific groups")) - (save-excursion - (let ((qstring (cdr (assq 'query query))) - (prefix (nnir-read-server-parm 'nnir-wais-remove-prefix server)) - artlist score artno dirnam) - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - (message "Doing WAIS query %s..." query) - (call-process nnir-wais-program - nil ; input from /dev/null - t ; output to current buffer - nil ; don't redisplay - "-d" (nnir-read-server-parm 'nnir-wais-database server) ; database to search - qstring) - (message "Massaging waissearch output...") - ;; remove superfluous lines - (keep-lines "Score:") - ;; extract data from result lines - (goto-char (point-min)) - (while (re-search-forward - "Score: +\\([0-9]+\\).*'\\([0-9]+\\) +\\([^']+\\)/'" nil t) - (setq score (match-string 1) - artno (match-string 2) - dirnam (match-string 3)) - (unless (string-match prefix dirnam) - (nnheader-report 'nnir "Dir name %s doesn't contain prefix %s" - dirnam prefix)) - (setq group (gnus-replace-in-string - (replace-match "" t t dirnam) "/" ".")) - (push (vector (nnir-group-full-name group server) - (string-to-number artno) - (string-to-number score)) - artlist)) - (message "Massaging waissearch output...done") - (apply 'vector - (sort artlist - (function (lambda (x y) - (> (nnir-artitem-rsv x) - (nnir-artitem-rsv y))))))))) - -;; IMAP interface. -;; todo: -;; nnir invokes this two (2) times???! -;; we should not use nnimap at all but open our own server connection -;; we should not LIST * but use nnimap-list-pattern from defs -;; send queries as literals -;; handle errors - -(autoload 'nnimap-open-server "nnimap") -(defvar nnimap-server-buffer) ;; nnimap.el -(autoload 'imap-mailbox-select "imap") -(autoload 'imap-search "imap") -(autoload 'imap-quote-specials "imap") - -(defun nnir-run-imap (query srv &optional group-option) +;; imap interface +(defun nnir-run-imap (query srv &optional groups) "Run a search against an IMAP back-end server. This uses a custom query language parser; see `nnir-imap-make-query' for details on the language and supported extensions" (save-excursion (let ((qstring (cdr (assq 'query query))) - (server (cadr (gnus-server-to-method srv))) - (group (or group-option (gnus-group-group-name))) - (defs (caddr (gnus-server-to-method srv))) - (criteria (or (cdr (assq 'criteria query)) - nnir-imap-search-field)) - artlist buf) + (server (cadr (gnus-server-to-method srv))) + (defs (caddr (gnus-server-to-method srv))) + (criteria (or (cdr (assq 'criteria query)) + (cdr (assoc nnir-imap-default-search-key + nnir-imap-search-arguments)))) + (gnus-inhibit-demon t) + (groups (or groups (nnir-get-active srv)))) (message "Opening server %s" server) - (condition-case () - (when (nnimap-open-server server defs) ;; xxx - (setq buf nnimap-server-buffer) ;; xxx - (message "Searching %s..." group) - (let ((arts 0) - (mbx (gnus-group-real-name group))) - (when (imap-mailbox-select mbx nil buf) - (mapc - (lambda (artnum) - (push (vector group artnum 1) artlist) - (setq arts (1+ arts))) - (imap-search (nnir-imap-make-query criteria qstring) buf)) - (message "Searching %s... %d matches" mbx arts))) - (message "Searching %s...done" group)) - (quit nil)) - (reverse artlist)))) + (apply + 'vconcat + (mapcar + (lambda (group) + (let (artlist) + (condition-case () + (when (nnimap-possibly-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (message "Searching %s..." group) + (let ((arts 0) + (result (nnimap-command "UID SEARCH %s" + (if (string= criteria "") + qstring + (nnir-imap-make-query + criteria qstring))))) + (mapc + (lambda (artnum) + (let ((artn (string-to-number artnum))) + (when (> artn 0) + (push (vector group artn 100) + artlist) + (setq arts (1+ arts))))) + (and (car result) (cdr (assoc "SEARCH" (cdr result))))) + (message "Searching %s... %d matches" group arts))) + (message "Searching %s...done" group)) + (quit nil)) + (nreverse artlist))) + groups))))) (defun nnir-imap-make-query (criteria qstring) "Parse the query string and criteria into an appropriate IMAP search @@ -1027,7 +869,7 @@ In future the following will be added to the language: (cond ;; Simple string term ((stringp expr) - (format "%s \"%s\"" criteria (imap-quote-specials expr))) + (format "%s %S" criteria expr)) ;; Trivial term: and ((eq expr 'and) nil) ;; Composite term: or expression @@ -1161,8 +1003,8 @@ actually). Tested with swish++ 4.7 on GNU/Linux and with swish++ 5.0b2 on Windows NT 4.0." - (when group - (error "The swish++ backend cannot search specific groups")) + ;; (when group + ;; (error "The swish++ backend cannot search specific groups")) (save-excursion (let ( (qstring (cdr (assq 'query query))) @@ -1173,7 +1015,7 @@ Windows NT 4.0." ;; is sufficient. Note that we can't only use the value of ;; nnml-use-compressed-files because old articles might have been ;; saved with a different value. - (article-pattern (if (string= server "nnmaildir:") + (article-pattern (if (string= (gnus-group-server server) "nnmaildir") ":[0-9]+" "^[0-9]+\\(\\.[a-z0-9]+\\)?$")) score artno dirnam filenam) @@ -1250,8 +1092,8 @@ actually). Tested with swish-e-2.0.1 on Windows NT 4.0." ;; swish-e crashes with empty parameter to "-w" on commandline... - (when group - (error "The swish-e backend cannot search specific groups")) + ;; (when group + ;; (error "The swish-e backend cannot search specific groups")) (save-excursion (let ((qstring (cdr (assq 'query query))) @@ -1321,7 +1163,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; Windows "\\" -> "." (setq group (gnus-replace-in-string group "\\\\" ".")) - (push (vector (nnir-group-full-name group server) + (push (vector (gnus-group-full-name group server) (string-to-number artno) (string-to-number score)) artlist)))) @@ -1343,19 +1185,13 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (qstring (cdr (assq 'query query))) (prefix (nnir-read-server-parm 'nnir-hyrex-remove-prefix server)) score artno dirnam) - (when (and group groupspec) - (error (concat "It does not make sense to use a group spec" - " with process-marked groups."))) - (when group - (setq groupspec (gnus-group-real-name group))) - (when (and group (not (equal group (nnir-group-full-name groupspec server)))) - (message "%s vs. %s" group (nnir-group-full-name groupspec server)) - (error "Server with groupspec doesn't match group !")) + (when (and (not groupspec) group) + (setq groupspec + (regexp-opt + (mapcar (lambda (x) (gnus-group-real-name x)) group)))) (set-buffer (get-buffer-create nnir-tmp-buffer)) (erase-buffer) - (if groupspec - (message "Doing hyrex-search query %s on %s..." query groupspec) - (message "Doing hyrex-search query %s..." query)) + (message "Doing hyrex-search query %s..." query) (let* ((cp-list `( ,nnir-hyrex-program nil ; input from /dev/null @@ -1377,16 +1213,14 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; the user wants it. (when (> gnus-verbose 6) (display-buffer nnir-tmp-buffer)))) ;; FIXME: Dont clear buffer ! - (if groupspec - (message "Doing hyrex-search query \"%s\" on %s...done" qstring groupspec) - (message "Doing hyrex-search query \"%s\"...done" qstring)) + (message "Doing hyrex-search query \"%s\"...done" qstring) (sit-for 0) ;; nnir-search returns: ;; for nnml/nnfolder: "filename mailid weigth" ;; for nnimap: "group mailid weigth" (goto-char (point-min)) (delete-non-matching-lines "^\\S + [0-9]+ [0-9]+$") - ;; HyREX couldn't search directly in groups -- so filter out here. + ;; HyREX doesn't search directly in groups -- so filter out here. (when groupspec (keep-lines groupspec)) ;; extract data from result lines @@ -1398,7 +1232,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." score (match-string 3)) (when (string-match prefix dirnam) (setq dirnam (replace-match "" t t dirnam))) - (push (vector (nnir-group-full-name + (push (vector (gnus-group-full-name (gnus-replace-in-string dirnam "/" ".") server) (string-to-number artno) (string-to-number score)) @@ -1420,10 +1254,10 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." pairs (also vectors, actually). Tested with Namazu 2.0.6 on a GNU/Linux system." - (when group - (error "The Namazu backend cannot search specific groups")) + ;; (when group + ;; (error "The Namazu backend cannot search specific groups")) (save-excursion - (let ((article-pattern (if (string= server "nnmaildir:") + (let ((article-pattern (if (string= (gnus-group-server server) "nnmaildir") ":[0-9]+" "^[0-9]+$")) artlist @@ -1483,7 +1317,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (> (nnir-artitem-rsv x) (nnir-artitem-rsv y))))))))) -(defun nnir-run-find-grep (query server &optional group) +(defun nnir-run-find-grep (query server &optional grouplist) "Run find and grep to obtain matching articles." (let* ((method (gnus-server-to-method server)) (sym (intern @@ -1491,73 +1325,138 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (directory (cadr (assoc sym (cddr method)))) (regexp (cdr (assoc 'query query))) (grep-options (cdr (assoc 'grep-options query))) + (grouplist (or grouplist (nnir-get-active server))) artlist) (unless directory (error "No directory found in method specification of server %s" server)) - (message "Searching %s using find-grep..." (or group server)) - (save-window-excursion - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - (if (> gnus-verbose 6) - (pop-to-buffer (current-buffer))) - (cd directory) ; Using relative paths simplifies postprocessing. - (let ((group - (if (not group) - "." - ;; Try accessing the group literally as well as - ;; interpreting dots as directory separators so the - ;; engine works with plain nnml as well as the Gnus Cache. - (let ((group (gnus-group-real-name group))) - ;; Replace cl-func find-if. - (if (file-directory-p group) - group - (if (file-directory-p - (setq group (gnus-replace-in-string group "\\." "/" t))) - group)))))) - (unless group - (error "Cannot locate directory for group")) - (save-excursion - (apply - 'call-process "find" nil t - "find" group "-type" "f" "-name" "[0-9]*" "-exec" - "grep" - `("-l" ,@(and grep-options - ;; Note: the 3rd arg of `split-string' is not - ;; available in Emacs 21. - (delete "" (split-string grep-options "\\s-"))) - "-e" ,regexp "{}" "+")))) - - ;; Translate relative paths to group names. - (while (not (eobp)) - (let* ((path (delete - "" - (split-string - (buffer-substring (point) (line-end-position)) "/"))) - (art (string-to-number (car (last path))))) - (while (string= "." (car path)) - (setq path (cdr path))) - (let ((group (mapconcat 'identity - ;; Replace cl-func: (subseq path 0 -1) - (let ((end (1- (length path))) - res) - (while (>= (setq end (1- end)) 0) - (push (pop path) res)) - (nreverse res)) - "."))) - (push (vector (nnir-group-full-name group server) art 0) - artlist)) - (forward-line 1))) - (message "Searching %s using find-grep...done" (or group server)) - artlist))) + (apply + 'vconcat + (mapcar (lambda (x) + (let ((group x)) + (message "Searching %s using find-grep..." + (or group server)) + (save-window-excursion + (set-buffer (get-buffer-create nnir-tmp-buffer)) + (erase-buffer) + (if (> gnus-verbose 6) + (pop-to-buffer (current-buffer))) + (cd directory) ; Using relative paths simplifies + ; postprocessing. + (let ((group + (if (not group) + "." + ;; Try accessing the group literally as + ;; well as interpreting dots as directory + ;; separators so the engine works with + ;; plain nnml as well as the Gnus Cache. + (let ((group (gnus-group-real-name group))) + ;; Replace cl-func find-if. + (if (file-directory-p group) + group + (if (file-directory-p + (setq group + (gnus-replace-in-string + group + "\\." "/" t))) + group)))))) + (unless group + (error "Cannot locate directory for group")) + (save-excursion + (apply + 'call-process "find" nil t + "find" group "-type" "f" "-name" "[0-9]*" "-exec" + "grep" + `("-l" ,@(and grep-options + (split-string grep-options "\\s-" t)) + "-e" ,regexp "{}" "+")))) + + ;; Translate relative paths to group names. + (while (not (eobp)) + (let* ((path (split-string + (buffer-substring + (point) + (line-end-position)) "/" t)) + (art (string-to-number (car (last path))))) + (while (string= "." (car path)) + (setq path (cdr path))) + (let ((group (mapconcat 'identity + ;; Replace cl-func: + ;; (subseq path 0 -1) + (let ((end (1- (length path))) + res) + (while + (>= (setq end (1- end)) 0) + (push (pop path) res)) + (nreverse res)) + "."))) + (push + (vector (gnus-group-full-name group server) art 0) + artlist)) + (forward-line 1))) + (message "Searching %s using find-grep...done" + (or group server)) + artlist))) + grouplist)))) + +(declare-function mm-url-insert "mm-url" (url &optional follow-refresh)) +(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs)) + +;; gmane interface +(defun nnir-run-gmane (query srv &optional groups) + "Run a search against a gmane back-end server." + (let* ((case-fold-search t) + (qstring (cdr (assq 'query query))) + (server (cadr (gnus-server-to-method srv))) + (groupspec (mapconcat + (lambda (x) + (if (gnus-string-match-p "gmane" x) + (format "group:%s" (gnus-group-short-name x)) + (error "Can't search non-gmane groups: %s" x))) + groups " ")) + (authorspec + (if (assq 'author query) + (format "author:%s" (cdr (assq 'author query))) "")) + (search (format "%s %s %s" + qstring groupspec authorspec)) + (gnus-inhibit-demon t) + artlist) + (require 'mm-url) + (with-current-buffer (get-buffer-create nnir-tmp-buffer) + (erase-buffer) + (mm-url-insert + (concat + "http://search.gmane.org/nov.php" + "?" + (mm-url-encode-www-form-urlencoded + `(("query" . ,search) + ("HITSPERPAGE" . "999"))))) + (unless (featurep 'xemacs) (set-buffer-multibyte t)) + (mm-decode-coding-region (point-min) (point-max) 'utf-8) + (goto-char (point-min)) + (forward-line 1) + (while (not (eobp)) + (unless (or (eolp) (looking-at "\x0d")) + (let ((header (nnheader-parse-nov))) + (let ((xref (mail-header-xref header)) + (xscore (string-to-number (cdr (assoc 'X-Score + (mail-header-extra header)))))) + (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) + (push + (vector + (gnus-group-prefixed-name (match-string 1 xref) srv) + (string-to-number (match-string 2 xref)) xscore) + artlist))))) + (forward-line 1))) + (apply 'vector (nreverse (mm-delete-duplicates artlist))))) ;;; Util Code: -(defun nnir-read-parms (query) +(defun nnir-read-parms (query nnir-search-engine) "Reads additional search parameters according to `nnir-engines'." (let ((parmspec (caddr (assoc nnir-search-engine nnir-engines)))) - (cons (cons 'query query) - (mapcar 'nnir-read-parm parmspec)))) + (append query + (mapcar 'nnir-read-parm parmspec)))) (defun nnir-read-parm (parmspec) "Reads a single search parameter. @@ -1565,107 +1464,64 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (let ((sym (car parmspec)) (prompt (cdr parmspec))) (if (listp prompt) - (let* ((result (apply 'completing-read prompt)) + (let* ((result (apply 'gnus-completing-read prompt)) (mapping (or (assoc result nnir-imap-search-arguments) - (assoc nil nnir-imap-search-arguments)))) + (cons nil nnir-imap-search-other)))) (cons sym (format (cdr mapping) result))) (cons sym (read-string prompt))))) -(defun nnir-run-query (query) +(autoload 'gnus-group-topic-name "gnus-topic") + +(defun nnir-run-query (query nserver) "Invoke appropriate search engine function (see `nnir-engines'). -If some groups were process-marked, run the query for each of the groups -and concat the results." - (let ((q (car (read-from-string query)))) - (if gnus-group-marked - (apply 'vconcat - (mapcar (lambda (x) - (let ((server (nnir-group-server x)) - search-func) - (setq search-func (cadr - (assoc - (nnir-read-server-parm 'nnir-search-engine server) nnir-engines))) - (if search-func - (funcall search-func q server x) - nil))) - gnus-group-marked) - ) - (apply 'vconcat - (mapcar (lambda (x) - (if (and (equal (cadr x) 'ok) (not (equal (cadar x) "-ephemeral"))) - (let ((server (format "%s:%s" (caar x) (cadar x))) - search-func) - (setq search-func (cadr - (assoc - (nnir-read-server-parm 'nnir-search-engine server) nnir-engines))) - (if search-func - (funcall search-func q server nil) - nil)) - nil)) - gnus-opened-servers) - )) - )) + If some groups were process-marked, run the query for each of the groups + and concat the results." + (let ((q (car (read-from-string query))) + (groups (if (string= "all-ephemeral" nserver) + (with-current-buffer gnus-server-buffer + (list (list (gnus-server-server-name)))) + (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-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 (cadr x)) + nil))) + groups)))) (defun nnir-read-server-parm (key server) - "Returns the parameter value of for the given server, where server is of -form 'backend:name'." + "Returns the parameter value of key for the given server, where +server is of form 'backend:name'." (let ((method (gnus-server-to-method server))) (cond ((and method (assq key (cddr method))) - (nth 1 (assq key (cddr method)))) - ((and nnir-mail-backend - (gnus-server-equal method nnir-mail-backend)) - (symbol-value key)) - (t nil)))) -;; (if method -;; (if (assq key (cddr method)) -;; (nth 1 (assq key (cddr method))) -;; (symbol-value key)) -;; (symbol-value key)) -;; )) - -(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))) + (nth 1 (assq key (cddr method)))) + (t nil)))) (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) @@ -1679,9 +1535,73 @@ The Gnus backend/server information is added." with-dups) res)) +(defun nnir-get-active (srv) + (let ((method (gnus-server-to-method srv)) + groups) + (gnus-request-list method) + (with-current-buffer nntp-server-buffer + (let ((cur (current-buffer)) + name) + (goto-char (point-min)) + (unless (or (null nnir-ignored-newsgroups) + (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)) + (when (and (boundp 'gnus-registry-install) + (eq gnus-registry-install t)) + (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t) + (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t) + (remove-hook 'gnus-summary-article-expire-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) + (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t)))) + + ;; The end. (provide 'nnir) -;; arch-tag: 9b3fecf8-4397-4bbb-bf3c-6ac3cbbc6664 ;;; nnir.el ends here diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el deleted file mode 100644 index 57be1b45f1..0000000000 --- a/lisp/gnus/nnkiboze.el +++ /dev/null @@ -1,391 +0,0 @@ -;;; nnkiboze.el --- select virtual news access for Gnus - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; The other access methods (nntp, nnspool, etc) are general news -;; access methods. This module relies on Gnus and can't be used -;; separately. - -;;; Code: - -(require 'nntp) -(require 'nnheader) -(require 'gnus) -(require 'gnus-score) -(require 'nnoo) -(require 'mm-util) -(eval-when-compile (require 'cl)) - -(nnoo-declare nnkiboze) -(defvoo nnkiboze-directory (nnheader-concat gnus-directory "kiboze/") - "nnkiboze will put its files in this directory.") - -(defvoo nnkiboze-level 9 - "The maximum level to be searched for articles.") - -(defvoo nnkiboze-remove-read-articles t - "If non-nil, nnkiboze will remove read articles from the kiboze group.") - -(defvoo nnkiboze-ephemeral nil - "If non-nil, don't store any data anywhere.") - -(defvoo nnkiboze-scores nil - "Score rules for generating the nnkiboze group.") - -(defvoo nnkiboze-regexp nil - "Regexp for matching component groups.") - -(defvoo nnkiboze-file-coding-system mm-text-coding-system - "Coding system for nnkiboze files.") - - - -(defconst nnkiboze-version "nnkiboze 1.0") - -(defvoo nnkiboze-current-group nil) -(defvoo nnkiboze-status-string "") - -(defvoo nnkiboze-headers nil) - - - -;;; Interface functions. - -(nnoo-define-basics nnkiboze) - -(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old) - (nnkiboze-possibly-change-group group) - (unless gnus-nov-is-evil - (if (stringp (car articles)) - 'headers - (let ((nov (nnkiboze-nov-file-name))) - (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((nnheader-file-coding-system nnkiboze-file-coding-system)) - (nnheader-insert-file-contents nov)) - (nnheader-nov-delete-outside-range - (car articles) (car (last articles))) - 'nov)))))) - -(deffoo nnkiboze-request-article (article &optional newsgroup server buffer) - (nnkiboze-possibly-change-group newsgroup) - (if (not (numberp article)) - ;; This is a real kludge. It might not work at times, but it - ;; does no harm I think. The only alternative is to offer no - ;; article fetching by message-id at all. - (nntp-request-article article newsgroup gnus-nntp-server buffer) - (let* ((header (gnus-summary-article-header article)) - (xref (mail-header-xref header)) - num group) - (unless xref - (error "nnkiboze: No xref")) - (unless (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref) - (error "nnkiboze: Malformed xref")) - (setq num (string-to-number (match-string 2 xref)) - group (match-string 1 xref)) - (or (with-current-buffer buffer - (or (and gnus-use-cache (gnus-cache-request-article num group)) - (gnus-agent-request-article num group))) - (gnus-request-article num group buffer))))) - -(deffoo nnkiboze-request-scan (&optional group server) - (nnkiboze-possibly-change-group group) - (nnkiboze-generate-group (concat "nnkiboze:" group))) - -(deffoo nnkiboze-request-group (group &optional server dont-check) - "Make GROUP the current newsgroup." - (nnkiboze-possibly-change-group group) - (if dont-check - t - (let ((nov-file (nnkiboze-nov-file-name)) - beg end total) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (unless (file-exists-p nov-file) - (nnkiboze-request-scan group)) - (if (not (file-exists-p nov-file)) - (nnheader-report 'nnkiboze "Can't select group %s" group) - (let ((nnheader-file-coding-system nnkiboze-file-coding-system)) - (nnheader-insert-file-contents nov-file)) - (if (zerop (buffer-size)) - (nnheader-insert "211 0 0 0 %s\n" group) - (goto-char (point-min)) - (when (looking-at "[0-9]+") - (setq beg (read (current-buffer)))) - (goto-char (point-max)) - (when (re-search-backward "^[0-9]" nil t) - (setq end (read (current-buffer)))) - (setq total (count-lines (point-min) (point-max))) - (nnheader-insert "211 %d %d %d %s\n" total beg end group))))))) - -(deffoo nnkiboze-close-group (group &optional server) - (nnkiboze-possibly-change-group group) - ;; Remove NOV lines of articles that are marked as read. - (when (and (file-exists-p (nnkiboze-nov-file-name)) - nnkiboze-remove-read-articles) - (let ((coding-system-for-write nnkiboze-file-coding-system)) - (with-temp-file (nnkiboze-nov-file-name) - (let ((cur (current-buffer)) - (nnheader-file-coding-system nnkiboze-file-coding-system)) - (nnheader-insert-file-contents (nnkiboze-nov-file-name)) - (goto-char (point-min)) - (while (not (eobp)) - (if (not (gnus-article-read-p (read cur))) - (forward-line 1) - (gnus-delete-line)))))) - (setq nnkiboze-current-group nil))) - -(deffoo nnkiboze-open-server (server &optional defs) - (unless (assq 'nnkiboze-regexp defs) - (push `(nnkiboze-regexp ,server) - defs)) - (nnoo-change-server 'nnkiboze server defs)) - -(deffoo nnkiboze-request-delete-group (group &optional force server) - (nnkiboze-possibly-change-group group) - (when force - (let ((files (nconc - (nnkiboze-score-file group) - (list (nnkiboze-nov-file-name) - (nnkiboze-nov-file-name ".newsrc"))))) - (while files - (and (file-exists-p (car files)) - (file-writable-p (car files)) - (delete-file (car files))) - (setq files (cdr files))))) - (setq nnkiboze-current-group nil) - t) - -(nnoo-define-skeleton nnkiboze) - - -;;; Internal functions. - -(defun nnkiboze-possibly-change-group (group) - (setq nnkiboze-current-group group)) - -(defun nnkiboze-prefixed-name (group) - (gnus-group-prefixed-name group '(nnkiboze ""))) - -;;;###autoload -(defun nnkiboze-generate-groups () - "\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\". -Finds out what articles are to be part of the nnkiboze groups." - (interactive) - (let ((mail-sources nil) - (gnus-use-dribble-file nil) - (gnus-read-active-file t) - (gnus-expert-user t)) - (gnus)) - (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist)) - (newsrc (cdr gnus-newsrc-alist)) - gnus-newsrc-hashtb info) - (gnus-make-hashtable-from-newsrc-alist) - ;; We have copied all the newsrc alist info over to local copies - ;; so that we can mess all we want with these lists. - (while (setq info (pop newsrc)) - (when (string-match "nnkiboze" (gnus-info-group info)) - ;; For each kiboze group, we call this function to generate - ;; it. - (nnkiboze-generate-group (gnus-info-group info) t)))) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-list-groups))) - -(defun nnkiboze-score-file (group) - (list (expand-file-name - (concat (file-name-as-directory gnus-kill-files-directory) - (nnheader-translate-file-chars - (concat (nnkiboze-prefixed-name nnkiboze-current-group) - "." gnus-score-file-suffix)))))) - -(defun nnkiboze-generate-group (group &optional inhibit-list-groups) - (let* ((info (gnus-get-info group)) - (newsrc-file (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".newsrc")))) - (nov-file (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".nov")))) - method nnkiboze-newsrc gname newsrc active - ginfo lowest glevel orig-info nov-buffer - ;; Bind various things to nil to make group entry faster. - (gnus-expert-user t) - (gnus-large-newsgroup nil) - (gnus-score-find-score-files-function 'nnkiboze-score-file) - ;; Use only nnkiboze-score-file! - (gnus-score-use-all-scores nil) - (gnus-use-scoring t) - (gnus-verbose (min gnus-verbose 3)) - gnus-select-group-hook gnus-summary-prepare-hook - gnus-thread-sort-functions gnus-show-threads - gnus-visual gnus-suppress-duplicates num-unread) - (unless info - (error "No such group: %s" group)) - ;; Load the kiboze newsrc file for this group. - (when (file-exists-p newsrc-file) - (load newsrc-file)) - (let ((coding-system-for-write nnkiboze-file-coding-system)) - (gnus-make-directory (file-name-directory nov-file)) - (with-temp-file nov-file - (mm-disable-multibyte) - (when (file-exists-p nov-file) - (insert-file-contents nov-file)) - (setq nov-buffer (current-buffer)) - ;; Go through the active hashtb and add new all groups that match the - ;; kiboze regexp. - (mapatoms - (lambda (group) - (and (string-match nnkiboze-regexp - (setq gname (symbol-name group))) ; Match - (not (assoc gname nnkiboze-newsrc)) ; It isn't registered - (numberp (car (symbol-value group))) ; It is active - (or (> nnkiboze-level 7) - (and (setq glevel - (gnus-info-level (gnus-get-info gname))) - (>= nnkiboze-level glevel))) - (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes - (push (cons gname (1- (car (symbol-value group)))) - nnkiboze-newsrc))) - gnus-active-hashtb) - ;; `newsrc' is set to the list of groups that possibly are - ;; component groups to this kiboze group. This list has elements - ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest - ;; number that has been kibozed in GROUP in this kiboze group. - (setq newsrc nnkiboze-newsrc) - (while newsrc - (if (not (setq active (gnus-active (caar newsrc)))) - ;; This group isn't active after all, so we remove it from - ;; the list of component groups. - (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) - (setq lowest (cdar newsrc)) - ;; Ok, we have a valid component group, so we jump to it. - (switch-to-buffer gnus-group-buffer) - (gnus-group-jump-to-group (caar newsrc)) - (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) - (setq ginfo (gnus-get-info (gnus-group-group-name)) - orig-info (gnus-copy-sequence ginfo) - num-unread (gnus-group-unread (caar newsrc))) - (unwind-protect - (progn - ;; We set all list of article marks to nil. Since we operate - ;; on copies of the real lists, we can destroy anything we - ;; want here. - (when (nth 3 ginfo) - (setcar (nthcdr 3 ginfo) nil)) - ;; We set the list of read articles to be what we expect for - ;; this kiboze group -- either nil or `(1 . LOWEST)'. - (when ginfo - (setcar (nthcdr 2 ginfo) - (and (not (= lowest 1)) (cons 1 lowest)))) - (when (and (or (not ginfo) - (> (length (gnus-list-of-unread-articles - (car ginfo))) - 0)) - (progn - (ignore-errors - (gnus-group-select-group nil)) - (eq major-mode 'gnus-summary-mode))) - ;; We are now in the group where we want to be. - (setq method (gnus-find-method-for-group - gnus-newsgroup-name)) - (when (eq method gnus-select-method) - (setq method nil)) - ;; We go through the list of scored articles. - (while gnus-newsgroup-scored - (when (> (caar gnus-newsgroup-scored) lowest) - ;; If it has a good score, then we enter this article - ;; into the kiboze group. - (nnkiboze-enter-nov - nov-buffer - (gnus-summary-article-header - (caar gnus-newsgroup-scored)) - gnus-newsgroup-name)) - (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) - ;; That's it. We exit this group. - (when (eq major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))))) - ;; Restore the proper info. - (when ginfo - (setcdr ginfo (cdr orig-info))) - (setcar (gnus-group-entry (caar newsrc)) num-unread))) - (setcdr (car newsrc) (cdr active)) - (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) - (setq newsrc (cdr newsrc))))) - ;; We save the kiboze newsrc for this group. - (gnus-make-directory (file-name-directory newsrc-file)) - (with-temp-file newsrc-file - (mm-disable-multibyte) - (insert "(setq nnkiboze-newsrc '") - (gnus-prin1 nnkiboze-newsrc) - (insert ")\n")) - (unless inhibit-list-groups - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-list-groups))) - t)) - -(defun nnkiboze-enter-nov (buffer header group) - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (let ((prefix (gnus-group-real-prefix group)) - (oheader (copy-sequence header)) - article) - (if (zerop (forward-line -1)) - (progn - (setq article (1+ (read (current-buffer)))) - (forward-line 1)) - (setq article 1)) - (mail-header-set-number oheader article) - (with-temp-buffer - (insert (or (mail-header-xref oheader) "")) - (goto-char (point-min)) - (if (re-search-forward " [^ ]+:[0-9]+" nil t) - (goto-char (match-beginning 0)) - (or (eobp) (forward-char 1))) - ;; The first Xref has to be the group this article - ;; really came for - this is the article nnkiboze - ;; will request when it is asked for the article. - (insert " " group ":" - (int-to-string (mail-header-number header)) " ") - (while (re-search-forward " [^ ]+:[0-9]+" nil t) - (goto-char (1+ (match-beginning 0))) - (insert prefix)) - (mail-header-set-xref oheader (buffer-string))) - (nnheader-insert-nov oheader)))) - -(defun nnkiboze-nov-file-name (&optional suffix) - (concat (file-name-as-directory nnkiboze-directory) - (nnheader-translate-file-chars - (concat (nnkiboze-prefixed-name nnkiboze-current-group) - (or suffix ".nov"))))) - -(provide 'nnkiboze) - -;; arch-tag: 66068271-bdc9-4801-bcde-779702e73a05 -;;; nnkiboze.el ends here diff --git a/lisp/gnus/nnlistserv.el b/lisp/gnus/nnlistserv.el deleted file mode 100644 index b61260142b..0000000000 --- a/lisp/gnus/nnlistserv.el +++ /dev/null @@ -1,152 +0,0 @@ -;;; nnlistserv.el --- retrieving articles via web mailing list archives - -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'mm-url) -(require 'nnweb) - -(nnoo-declare nnlistserv - nnweb) - -(defvoo nnlistserv-directory (nnheader-concat gnus-directory "nnlistserv/") - "Where nnlistserv will save its files." - nnweb-directory) - -(defvoo nnlistserv-name 'kk - "What search engine type is being used." - nnweb-type) - -(defvoo nnlistserv-type-definition - '((kk - (article . nnlistserv-kk-wash-article) - (map . nnlistserv-kk-create-mapping) - (search . nnlistserv-kk-search) - (address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/") - (pages "fra160396" "fra160796" "fra061196" "fra160197" - "fra090997" "fra040797" "fra130397" "nye") - (index . "date.html") - (identifier . nnlistserv-kk-identity))) - "Type-definition alist." - nnweb-type-definition) - -(defvoo nnlistserv-search nil - "Search string to feed to DejaNews." - nnweb-search) - -(defvoo nnlistserv-ephemeral-p nil - "Whether this nnlistserv server is ephemeral." - nnweb-ephemeral-p) - -;;; Internal variables - -;;; Interface functions - -(nnoo-define-basics nnlistserv) - -(nnoo-import nnlistserv - (nnweb)) - -;;; Internal functions - -;;; -;;; KK functions. -;;; - -(defun nnlistserv-kk-create-mapping () - "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) - (let ((case-fold-search t) - (active (or (cadr (assoc nnweb-group nnweb-group-alist)) - (cons 1 0))) - (pages (nnweb-definition 'pages)) - map url page subject from ) - (while (setq page (pop pages)) - (erase-buffer) - (when (funcall (nnweb-definition 'search) page) - ;; Go through all the article hits on this page. - (goto-char (point-min)) - (mm-url-decode-entities) - (goto-char (point-min)) - (while (re-search-forward "^<li> *<a href=\"\\([^\"]+\\)\"><b>\\([^\\>]+\\)</b></a> *<[^>]+><i>\\([^>]+\\)<" nil t) - (setq url (match-string 1) - subject (match-string 2) - from (match-string 3)) - (setq url (concat (format (nnweb-definition 'address) page) url)) - (unless (nnweb-get-hashtb url) - (push - (list - (incf (cdr active)) - (make-full-mail-header - (cdr active) subject from "" - (concat "<" (nnweb-identifier url) "@kk>") - nil 0 0 url)) - map) - (nnweb-set-hashtb (cadar map) (car map)) - (nnheader-message 5 "%s %s %s" (cdr active) (point) pages))))) - ;; Return the articles in the right order. - (setq nnweb-articles - (sort (nconc nnweb-articles map) 'car-less-than-car))))) - -(defun nnlistserv-kk-wash-article () - (let ((case-fold-search t) - (headers '(sent name email subject id)) - sent name email subject id) - (mm-url-decode-entities) - (while headers - (goto-char (point-min)) - (re-search-forward (format "<!-- %s=\"\\([^\"]+\\)" (car headers)) nil t) - (set (pop headers) (match-string 1))) - (goto-char (point-min)) - (search-forward "<!-- body" nil t) - (delete-region (point-min) (progn (forward-line 1) (point))) - (goto-char (point-max)) - (search-backward "<!-- body" nil t) - (delete-region (point-max) (progn (beginning-of-line) (point))) - (mm-url-remove-markup) - (goto-char (point-min)) - (insert (format "From: %s <%s>\n" name email) - (format "Subject: %s\n" subject) - (format "Message-ID: %s\n" id) - (format "Date: %s\n\n" sent)))) - -(defun nnlistserv-kk-search (search) - (mm-url-insert - (concat (format (nnweb-definition 'address) search) - (nnweb-definition 'index))) - t) - -(defun nnlistserv-kk-identity (url) - "Return an unique identifier based on URL." - url) - -(provide 'nnlistserv) - -;; arch-tag: 7705176f-d332-4a5e-a520-d0d319445617 -;;; nnlistserv.el ends here diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 422d5ed526..63ed4962d4 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -104,7 +104,9 @@ mail belongs in that group. The last element should always have \"\" as the regexp. -This variable can also have a function as its value." +This variable can also have a function as its value, and it can +also have a fancy split method as its value. See +`nnmail-split-fancy' for an explanation of that syntax." :group 'nnmail-split :type '(choice (repeat :tag "Alist" (group (string :tag "Name") (choice regexp function))) @@ -265,7 +267,7 @@ It scans low-level sorted spools even when not required." :type 'function) (defcustom nnmail-crosspost-link-function - (if (string-match "windows-nt\\|emx" (symbol-name system-type)) + (if (string-match "windows-nt" (symbol-name system-type)) 'copy-file 'add-name-to-file) "*Function called to create a copy of a file. @@ -614,6 +616,7 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)." (defvar nnmail-split-tracing nil) (defvar nnmail-split-trace nil) +(defvar nnmail-inhibit-default-split-group nil) @@ -674,8 +677,7 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)." "Returns an assoc of group names and active ranges. nn*-request-list should have been called before calling this function." ;; Go through all groups from the active list. - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (nnmail-parse-active))) (defun nnmail-parse-active () @@ -963,7 +965,7 @@ If SOURCE is a directory spec, try to return the group name component." (goto-char end))) count)) -(defun nnmail-process-mmdf-mail-format (func artnum-func) +(defun nnmail-process-mmdf-mail-format (func artnum-func &optional junk-func) (let ((delim "^\^A\^A\^A\^A$") (case-fold-search t) (count 0) @@ -1011,7 +1013,7 @@ If SOURCE is a directory spec, try to return the group name component." (narrow-to-region start (point)) (goto-char (point-min)) (incf count) - (nnmail-check-duplication message-id func artnum-func) + (nnmail-check-duplication message-id func artnum-func junk-func) (setq end (point-max)))) (goto-char end) (forward-line 2))) @@ -1056,9 +1058,11 @@ If SOURCE is a directory spec, try to return the group name component." "Non-nil means group names are not encoded.") (defun nnmail-split-incoming (incoming func &optional exit-func - group artnum-func) + group artnum-func junk-func) "Go through the entire INCOMING file and pick out each individual mail. -FUNC will be called with the buffer narrowed to each mail." +FUNC will be called with the buffer narrowed to each mail. +INCOMING can also be a buffer object. In that case, the mail +will be copied over from that buffer." (let ( ;; If this is a group-specific split, we bind the split ;; methods to just this group. (nnmail-split-methods (if (and group @@ -1066,12 +1070,13 @@ FUNC will be called with the buffer narrowed to each mail." (list (list group "")) nnmail-split-methods)) (nnmail-group-names-not-encoded-p t)) - (save-excursion - ;; Insert the incoming file. - (set-buffer (get-buffer-create nnmail-article-buffer)) + ;; Insert the incoming file. + (with-current-buffer (get-buffer-create nnmail-article-buffer) (erase-buffer) - (let ((coding-system-for-read nnmail-incoming-coding-system)) - (mm-insert-file-contents incoming)) + (if (bufferp incoming) + (insert-buffer-substring incoming) + (let ((coding-system-for-read nnmail-incoming-coding-system)) + (mm-insert-file-contents incoming))) (prog1 (if (zerop (buffer-size)) 0 @@ -1084,7 +1089,8 @@ FUNC will be called with the buffer narrowed to each mail." (looking-at "BABYL OPTIONS:")) (nnmail-process-babyl-mail-format func artnum-func)) ((looking-at "\^A\^A\^A\^A") - (nnmail-process-mmdf-mail-format func artnum-func)) + (nnmail-process-mmdf-mail-format + func artnum-func junk-func)) ((looking-at "Return-Path:") (nnmail-process-maildir-mail-format func artnum-func)) (t @@ -1093,22 +1099,22 @@ FUNC will be called with the buffer narrowed to each mail." (funcall exit-func)) (kill-buffer (current-buffer)))))) -(defun nnmail-article-group (func &optional trace) +(defun nnmail-article-group (func &optional trace junk-func) "Look at the headers and return an alist of groups that match. FUNC will be called with the group name to determine the article number." (let ((methods (or nnmail-split-methods '(("bogus" "")))) (obuf (current-buffer)) group-art method grp) (if (and (sequencep methods) - (= (length methods) 1)) + (= (length methods) 1) + (not nnmail-inhibit-default-split-group)) ;; If there is only just one group to put everything in, we ;; just return a list with just this one method in. (setq group-art (list (cons (caar methods) (funcall func (caar methods))))) ;; We do actual comparison. - (save-excursion - ;; Copy the article into the work buffer. - (set-buffer nntp-server-buffer) + ;; Copy the article into the work buffer. + (with-current-buffer nntp-server-buffer (erase-buffer) (insert-buffer-substring obuf) ;; Narrow to headers. @@ -1141,27 +1147,41 @@ FUNC will be called with the group name to determine the article number." (run-hooks 'nnmail-split-hook) (when (setq nnmail-split-tracing trace) (setq nnmail-split-trace nil)) - (if (and (symbolp nnmail-split-methods) - (fboundp nnmail-split-methods)) - (let ((split - (condition-case error-info - ;; `nnmail-split-methods' is a function, so we - ;; just call this function here and use the - ;; result. - (or (funcall nnmail-split-methods) - '("bogus")) - (error - (nnheader-message - 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info) - (sit-for 1) - '("bogus"))))) + (if (or (and (symbolp nnmail-split-methods) + (fboundp nnmail-split-methods)) + (and (listp nnmail-split-methods) + ;; Not a regular split method, so it has to be a + ;; fancy one. + (not (let ((top-element (car-safe nnmail-split-methods))) + (and (= 2 (length top-element)) + (stringp (nth 0 top-element)) + (stringp (nth 1 top-element))))))) + (let* ((method-function + (if (and (symbolp nnmail-split-methods) + (fboundp nnmail-split-methods)) + nnmail-split-methods + 'nnmail-split-fancy)) + (split + (condition-case error-info + ;; `nnmail-split-methods' is a function, so we + ;; just call this function here and use the + ;; result. + (or (funcall method-function) + (and (not nnmail-inhibit-default-split-group) + '("bogus"))) + (error + (nnheader-message + 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info) + (sit-for 1) + '("bogus"))))) (setq split (mm-delete-duplicates split)) ;; The article may be "cross-posted" to `junk'. What ;; to do? Just remove the `junk' spec. Don't really ;; see anything else to do... - (let (elem) - (while (setq elem (car (memq 'junk split))) - (setq split (delq elem split)))) + (when (and (memq 'junk split) + junk-func) + (funcall junk-func 'junk)) + (setq split (delq 'junk split)) (when split (setq group-art (mapcar @@ -1194,12 +1214,14 @@ FUNC will be called with the group name to determine the article number." group-art)) ;; This is the final group, which is used as a ;; catch-all. - (unless group-art + (when (and (not group-art) + (not nnmail-inhibit-default-split-group)) (setq group-art (list (cons (car method) (funcall func (car method)))))))) ;; Fall back on "bogus" if all else fails. - (unless group-art + (when (and (not group-art) + (not nnmail-inhibit-default-split-group)) (setq group-art (list (cons "bogus" (funcall func "bogus")))))) ;; Produce a trace if non-empty. (when (and trace nnmail-split-trace) @@ -1325,7 +1347,7 @@ Eudora has a broken References line, but an OK In-Reply-To." ;;; Utility functions (declare-function gnus-activate-group "gnus-start" - (group &optional scan dont-check method)) + (group &optional scan dont-check method dont-sub-check)) (defun nnmail-do-request-post (accept-func &optional server) "Utility function to directly post a message to an nnmail-derived group. @@ -1572,10 +1594,9 @@ See the documentation for the variable `nnmail-split-fancy' for details." (and nnmail-cache-buffer (buffer-name nnmail-cache-buffer))) () ; The buffer is open. - (save-excursion - (set-buffer + (with-current-buffer (setq nnmail-cache-buffer - (get-buffer-create " *nnmail message-id cache*"))) + (get-buffer-create " *nnmail message-id cache*")) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) @@ -1587,8 +1608,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." nnmail-treat-duplicates (buffer-name nnmail-cache-buffer) (buffer-modified-p nnmail-cache-buffer)) - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer ;; Weed out the excess number of Message-IDs. (goto-char (point-max)) (when (search-backward "\n" nil t nnmail-message-id-cache-length) @@ -1605,10 +1625,6 @@ See the documentation for the variable `nnmail-split-fancy' for details." (setq nnmail-cache-buffer nil) (gnus-kill-buffer (current-buffer))))) -;; Compiler directives. -(defvar group) -(defvar group-art-list) -(defvar group-art) (defun nnmail-cache-insert (id grp &optional subject sender) (when (stringp id) ;; this will handle cases like `B r' where the group is nil @@ -1623,8 +1639,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." ;; pass the first (of possibly >1) group which matches. -Josh (unless (gnus-buffer-live-p nnmail-cache-buffer) (nnmail-cache-open)) - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer (goto-char (point-max)) (if (and grp (not (string= "" grp)) (gnus-methods-equal-p gnus-command-method @@ -1657,8 +1672,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." ;; cache. (defun nnmail-cache-fetch-group (id) (when (and nnmail-treat-duplicates nnmail-cache-buffer) - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer (goto-char (point-max)) (when (search-backward id nil t) (beginning-of-line) @@ -1702,8 +1716,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun nnmail-cache-id-exists-p (id) (when nnmail-treat-duplicates - (save-excursion - (set-buffer nnmail-cache-buffer) + (with-current-buffer nnmail-cache-buffer (goto-char (point-max)) (search-backward id nil t)))) @@ -1713,7 +1726,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (message-narrow-to-head) (message-fetch-field header)))) -(defun nnmail-check-duplication (message-id func artnum-func) +(defun nnmail-check-duplication (message-id func artnum-func + &optional junk-func) (run-hooks 'nnmail-prepare-incoming-message-hook) ;; If this is a duplicate message, then we do not save it. (let* ((duplication (nnmail-cache-id-exists-p message-id)) @@ -1738,7 +1752,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (cond ((not duplication) (funcall func (setq group-art - (nreverse (nnmail-article-group artnum-func)))) + (nreverse (nnmail-article-group + artnum-func nil junk-func)))) (nnmail-cache-insert message-id (caar group-art))) ((eq action 'delete) (setq group-art nil)) @@ -1823,8 +1838,6 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; The we go through all the existing mail source specification ;; and fetch the mail from each. (while (setq source (pop fetching-sources)) - (nnheader-message 4 "%s: Reading incoming mail from %s..." - method (car source)) (when (setq new (mail-source-fetch source @@ -1842,8 +1855,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) - (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" - method (car source)) + (when mail-source-plugged + (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" + method (car source))) (nnmail-save-active (nnmail-get-value "%s-group-alist" method) (nnmail-get-value "%s-active-file" method)) @@ -1858,9 +1872,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (run-hooks 'nnmail-post-get-new-mail-hook)))) (defun nnmail-expired-article-p (group time force &optional inhibit) - "Say whether an article that is TIME old in GROUP should be expired." + "Say whether an article that is TIME old in GROUP should be expired. +If TIME is nil, then return the cutoff time for oldness instead." (if force - t + (if (null time) + (current-time) + t) (let ((days (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function group)) nnmail-expiry-wait))) @@ -1871,14 +1888,18 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." nil) ((eq days 'immediate) ;; We expire all articles on sight. - t) + (if (null time) + (current-time) + t)) ((equal time '(0 0)) ;; This is an ange-ftp group, and we don't have any dates. nil) ((numberp days) (setq days (days-to-time days)) ;; Compare the time with the current time. - (ignore-errors (time-less-p days (time-since time)))))))) + (if (null time) + (time-subtract (current-time) days) + (ignore-errors (time-less-p days (time-since time))))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) @@ -1894,7 +1915,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when (or (gnus-request-group target) (gnus-request-create-group target)) (let ((group-art (gnus-request-accept-article target nil nil t))) - (when (consp group-art) + (when (and (consp group-art) + (cdr group-art)) (gnus-group-mark-article-read target (cdr group-art)))))))) (defun nnmail-fancy-expiry-target (group) @@ -2052,5 +2074,4 @@ Doesn't change point." (provide 'nnmail) -;; arch-tag: fe8f671a-50db-428a-bb5d-f00462f72ed7 ;;; nnmail.el ends here diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 628b4c5d2a..8e2cd4bdde 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -59,7 +59,7 @@ ) ] -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -208,20 +208,16 @@ by nnmaildir-request-article.") (eval param)) (defmacro nnmaildir--with-nntp-buffer (&rest body) - `(save-excursion - (set-buffer nntp-server-buffer) + `(with-current-buffer nntp-server-buffer ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir work*")) + `(with-current-buffer (get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir nov*")) + `(with-current-buffer (get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir move*")) + `(with-current-buffer (get-buffer-create " *nnmaildir move*") ,@body)) (defmacro nnmaildir--subdir (dir subdir) @@ -920,7 +916,7 @@ by nnmaildir-request-article.") "\n"))))) 'group) -(defun nnmaildir-request-update-info (gname info &optional server) +(defun nnmaildir-request-marks (gname info &optional server) (let ((group (nnmaildir--prepare server gname)) pgname flist always-marks never-marks old-marks dotfile num dir markdirs marks mark ranges markdir article read end new-marks ls @@ -987,7 +983,7 @@ by nnmaildir-request-article.") (setf (nnmaildir--grp-mmth group) new-mmth) info))) -(defun nnmaildir-request-group (gname &optional server fast) +(defun nnmaildir-request-group (gname &optional server fast info) (let ((group (nnmaildir--prepare server gname)) deactivate-mark) (catch 'return @@ -1249,8 +1245,7 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) - (save-excursion - (set-buffer (or to-buffer nntp-server-buffer)) + (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (nnheader-insert-file-contents nnmaildir-article-file-name)) (cons gname num-msgid)))) @@ -1289,8 +1284,7 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " tmpfile)) (throw 'return nil)) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil 'excl)) (unix-sync) ;; no fsync :( @@ -1565,7 +1559,7 @@ by nnmaildir-request-article.") (t (signal (car err) (cdr err)))))) todo-marks)) set-action (lambda (article) - (funcall add-action) + (funcall add-action article) (mapcar (lambda (mark) (unless (memq mark todo-marks) (funcall del-mark mark))) @@ -1596,7 +1590,7 @@ by nnmaildir-request-article.") (nnmaildir--nlist-iterate nlist ranges (cond ((eq 'del (cadr action)) del-action) ((eq 'add (cadr action)) add-action) - (t set-action)))) + ((eq 'set (cadr action)) set-action)))) nil))) (defun nnmaildir-close-group (gname &optional server) @@ -1667,5 +1661,4 @@ by nnmaildir-request-article.") ;; fill-column: 77 ;; End: -;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849 ;;; nnmaildir.el ends here diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index ffe221b8d0..54d5f94177 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -188,17 +188,17 @@ (defun nnmairix-summary-mode-hook () "Nnmairix summary mode keymap." (define-key gnus-summary-mode-map - (kbd "$ t") 'nnmairix-search-thread-this-article) + (kbd "G G t") 'nnmairix-search-thread-this-article) (define-key gnus-summary-mode-map - (kbd "$ f") 'nnmairix-search-from-this-article) + (kbd "G G f") 'nnmairix-search-from-this-article) (define-key gnus-summary-mode-map - (kbd "$ m") 'nnmairix-widget-search-from-this-article) + (kbd "G G m") 'nnmairix-widget-search-from-this-article) (define-key gnus-summary-mode-map - (kbd "$ g") 'nnmairix-create-search-group-from-message) + (kbd "G G g") 'nnmairix-create-search-group-from-message) (define-key gnus-summary-mode-map - (kbd "$ o") 'nnmairix-goto-original-article) + (kbd "G G o") 'nnmairix-goto-original-article) (define-key gnus-summary-mode-map - (kbd "$ u") 'nnmairix-remove-tick-mark-original-article)) + (kbd "G G u") 'nnmairix-remove-tick-mark-original-article)) (add-hook 'gnus-group-mode-hook 'nnmairix-group-mode-hook) (add-hook 'gnus-summary-mode-hook 'nnmairix-summary-mode-hook) @@ -424,7 +424,7 @@ Other back ends might or might not work.") (setq nnmairix-current-server server) (nnoo-change-server 'nnmairix server definitions)) -(deffoo nnmairix-request-group (group &optional server fast) +(deffoo nnmairix-request-group (group &optional server fast info) ;; Call mairix and request group on back end server (when server (nnmairix-open-server server)) (let* ((qualgroup (if server @@ -445,8 +445,7 @@ Other back ends might or might not work.") nil) ((not query) ;; No query -> return empty group - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (insert (concat "211 0 1 0 " group)) t)) @@ -501,9 +500,9 @@ Other back ends might or might not work.") (nnmairix-request-group-with-article-number-correction folder qualgroup))) ((and (= rval 1) - (save-excursion (set-buffer nnmairix-mairix-output-buffer) - (goto-char (point-min)) - (looking-at "^Matched 0 messages"))) + (with-current-buffer nnmairix-mairix-output-buffer + (goto-char (point-min)) + (looking-at "^Matched 0 messages"))) ;; No messages found -> return empty group (nnheader-message 5 "Mairix: No matches found.") (set-buffer nntp-server-buffer) @@ -556,16 +555,15 @@ Other back ends might or might not work.") (mapcar (lambda (arg) (- arg numcorr)) articles))) - (setq rval + (setq rval (if (eq nnmairix-backend 'nnimap) (let ((gnus-nov-is-evil t)) (nnmairix-call-backend "retrieve-headers" articles folder nnmairix-backend-server fetch-old)) (nnmairix-call-backend "retrieve-headers" articles folder nnmairix-backend-server fetch-old))) - (when (eq rval 'nov) - (nnmairix-replace-group-and-numbers articles folder group numcorr) - rval))) + (nnmairix-replace-group-and-numbers articles folder group numcorr rval) + rval)) (deffoo nnmairix-request-article (article &optional group server to-buffer) (when server (nnmairix-open-server server)) @@ -584,8 +582,7 @@ Other back ends might or might not work.") (when server (nnmairix-open-server server)) (if (nnmairix-call-backend "request-list" nnmairix-backend-server) (let (cpoint cur qualgroup folder) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (setq cpoint (point)) (while (re-search-forward nnmairix-group-regexp (point-max) t) @@ -699,8 +696,7 @@ Other back ends might or might not work.") (when (or (eq nnmairix-propagate-marks-upon-close t) (and (eq nnmairix-propagate-marks-upon-close 'ask) (y-or-n-p "Propagate marks to original articles? "))) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (nnmairix-propagate-marks) ;; update mairix group (gnus-group-jump-to-group qualgroup) @@ -708,7 +704,7 @@ Other back ends might or might not work.") (autoload 'nnimap-request-update-info-internal "nnimap") -(deffoo nnmairix-request-update-info (group info &optional server) +(deffoo nnmairix-request-marks (group info &optional server) ;; propagate info from underlying IMAP folder to nnmairix group ;; This is currently experimental and must be explicitly activated ;; with nnmairix-propagate-marks-to-nnmairix-group @@ -852,8 +848,8 @@ called interactively, user will be asked for parameters." All necessary information will be queried from the user." (interactive) (let* ((name (read-string "Name of the mairix server: ")) - (server (completing-read "Back end server (TAB for completion): " - (nnmairix-get-valid-servers) nil 1)) + (server (gnus-completing-read "Back end server" + (nnmairix-get-valid-servers) t)) (mairix (read-string "Command to call mairix: " "mairix")) (defaultgroup (read-string "Default search group: ")) (backend (symbol-name (car (gnus-server-to-method server)))) @@ -998,8 +994,7 @@ with m:msgid of the current article and enabled threads." (if server (if (gnus-buffer-live-p gnus-article-buffer) (progn - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-summary-toggle-header 1) (setq mid (message-fetch-field "Message-ID"))) (while (string-match "[<>]" mid) @@ -1021,8 +1016,7 @@ f:current_from." (if server (if (gnus-buffer-live-p gnus-article-buffer) (progn - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-summary-toggle-header 1) (setq from (cadr (gnus-extract-address-components (gnus-fetch-field "From")))) @@ -1046,8 +1040,7 @@ before deleting a group on the back end. SERVER specifies nnmairix server." (when (nnmairix-call-backend "request-list" nnmairix-backend-server) (let (cur qualgroup folder) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (while (re-search-forward nnmairix-group-regexp (point-max) t) (setq cur (match-string 0) @@ -1152,8 +1145,7 @@ nnmairix server. Only marks from current session will be set." (push (list (car ogroup) (list (list number) (nth 1 mid-marks) (nth 2 mid-marks))) number-cache))))) ;; now we set the marks - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (nnheader-message 5 "nnmairix: Propagating marks...") (dolist (cur number-cache) (setq method (gnus-find-method-for-group (car cur))) @@ -1173,7 +1165,7 @@ nnmairix server. Only marks from current session will be set." If SKIPDEFAULT is t, the default search group will not be updated. If UPDATEDB is t, database for SERVERNAME will be updated first." - (interactive (list (completing-read "Update groups on server: " + (interactive (list (gnus-completing-read "Update groups on server" (nnmairix-get-nnmairix-servers)))) (save-excursion (when (string-match ".*:\\(.*\\)" servername) @@ -1272,9 +1264,8 @@ Marks propagation has to be enabled for this to work." "Call mairix binary with COMMAND, using FOLDER and SEARCHQUERY. If THREADS is non-nil, enable full threads." (let ((args (cons (car command) '(nil t nil)))) - (save-excursion - (set-buffer - (get-buffer-create nnmairix-mairix-output-buffer)) + (with-current-buffer + (get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1291,9 +1282,8 @@ If THREADS is non-nil, enable full threads." (defun nnmairix-call-mairix-binary-raw (command query) "Call mairix binary with COMMAND and QUERY in raw mode." (let ((args (cons (car command) '(nil t nil)))) - (save-excursion - (set-buffer - (get-buffer-create nnmairix-mairix-output-buffer)) + (with-current-buffer + (get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1312,7 +1302,7 @@ Otherwise, ask user for server." (while (equal '("") (setq nnmairix-last-server - (list (completing-read "Server: " openedserver nil 1 + (list (gnus-completing-read "Server" openedserver t (or nnmairix-last-server "nnmairix:")))))) nnmairix-last-server) @@ -1367,7 +1357,7 @@ If ALL is t, return also the unopened/failed ones." (not (member (car server) gnus-ephemeral-servers)) (not (member (gnus-method-to-server (car server)) occ))) (push - (list mserver) + mserver openedserver))) openedserver)) @@ -1422,44 +1412,55 @@ nnmairix with nnml backends." (setq cur lastplusone)) (setq lastplusone (1+ cur))))) -(defun nnmairix-replace-group-and-numbers (articles backendgroup mairixgroup numc) +(defun nnmairix-replace-group-and-numbers (articles backendgroup mairixgroup numc type) "Replace folder names in Xref header and correct article numbers. Do this for all ARTICLES on BACKENDGROUP. Replace using -MAIRIXGROUP. NUMC contains values for article number correction." - (let ((buf (get-buffer-create " *nnmairix buffer*")) - (corr (not (zerop numc))) - (name (buffer-name nntp-server-buffer)) - header cur xref) - (save-excursion - (set-buffer buf) - (erase-buffer) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (nnheader-message 7 "nnmairix: Rewriting headers...") - (mapc - (lambda (article) - (when (or (looking-at (number-to-string article)) - (nnheader-find-nov-line article)) - (setq cur (nnheader-parse-nov)) - (when corr - (setq article (+ (mail-header-number cur) numc)) - (mail-header-set-number cur article)) - (setq xref (mail-header-xref cur)) - (when (and (stringp xref) - (string-match (format "[ \t]%s:[0-9]+" backendgroup) xref)) - (setq xref (replace-match (format " %s:%d" mairixgroup article) t nil xref)) - (mail-header-set-xref cur xref)) - (set-buffer buf) - (nnheader-insert-nov cur) - (set-buffer nntp-server-buffer) - (when (not (eobp)) - (forward-line 1)))) - articles) - (nnheader-message 7 "nnmairix: Rewriting headers... done") - (kill-buffer nntp-server-buffer) - (set-buffer buf) - (rename-buffer name) - (setq nntp-server-buffer buf)))) +MAIRIXGROUP. NUMC contains values for article number correction. +TYPE is either 'nov or 'headers." + (nnheader-message 7 "nnmairix: Rewriting headers...") + (cond + ((eq type 'nov) + (let ((buf (get-buffer-create " *nnmairix buffer*")) + (corr (not (zerop numc))) + (name (buffer-name nntp-server-buffer)) + header cur xref) + (with-current-buffer buf + (erase-buffer) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (mapc + (lambda (article) + (when (or (looking-at (number-to-string article)) + (nnheader-find-nov-line article)) + (setq cur (nnheader-parse-nov)) + (when corr + (setq article (+ (mail-header-number cur) numc)) + (mail-header-set-number cur article)) + (setq xref (mail-header-xref cur)) + (when (and (stringp xref) + (string-match (format "[ \t]%s:[0-9]+" backendgroup) xref)) + (setq xref (replace-match (format " %s:%d" mairixgroup article) t nil xref)) + (mail-header-set-xref cur xref)) + (set-buffer buf) + (nnheader-insert-nov cur) + (set-buffer nntp-server-buffer) + (when (not (eobp)) + (forward-line 1)))) + articles) + (kill-buffer nntp-server-buffer) + (set-buffer buf) + (rename-buffer name) + (setq nntp-server-buffer buf)))) + ((and (eq type 'headers) + (not (zerop numc))) + (with-current-buffer nntp-server-buffer + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^[23][0-9]+ \\([0-9]+\\)" nil t) + (replace-match (number-to-string + (+ (string-to-number (match-string 1)) numc)) + t t nil 1)))))) + (nnheader-message 7 "nnmairix: Rewriting headers... done")) (defun nnmairix-backend-to-server (server) "Return nnmairix server most probably responsible for back end SERVER. @@ -1491,10 +1492,10 @@ group." (when (not found) (setq mairixserver (gnus-server-to-method - (completing-read - (format "Cannot determine which nnmairix server indexes %s. Please specify: " + (gnus-completing-read + (format "Cannot determine which nnmairix server indexes %s. Please specify" (gnus-method-to-server server)) - (nnmairix-get-nnmairix-servers) nil nil "nnmairix:"))) + (nnmairix-get-nnmairix-servers) nil "nnmairix:"))) ;; Save result in parameter of default search group so that ;; we don't have to ask again (setq defaultgroup (gnus-group-prefixed-name @@ -1571,14 +1572,11 @@ See %s for details" proc nnmairix-mairix-output-buffer))) (defun nnmairix-replace-illegal-chars (header) "Replace illegal characters in HEADER for mairix query." (when header - (if (> emacs-major-version 20) - (while (string-match "[^-.@/,& [:alnum:]]" header) - (setq header (replace-match "" t t header))) - (while (string-match "[[]{}:<>]" header) - (setq header (replace-match "" t t header)))) + (while (string-match "[^-.@/,& [:alnum:]]" header) + (setq header (replace-match "" t t header))) (while (string-match "[-& ]" header) (setq header (replace-match "," t t header))) - header)) + header)) (defun nnmairix-group-toggle-parameter (group parameter description &optional par) "Toggle on GROUP a certain PARAMETER. @@ -1621,8 +1619,7 @@ search in raw mode." (let ((server (nth 1 gnus-current-select-method)) mid rval group allgroups) ;; get message id - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-summary-toggle-header 1) (setq mid (message-fetch-field "Message-ID")) ;; first check the registry (if available) @@ -1643,9 +1640,9 @@ search in raw mode." (gnus-registry-add-group mid cur))))) (if (> (length allgroups) 1) (setq group - (completing-read - "Message exists in more than one group. Choose: " - allgroups nil t)) + (gnus-completing-read + "Message exists in more than one group. Choose" + allgroups t)) (setq group (car allgroups)))) (if group ;; show article in summary buffer @@ -1678,8 +1675,7 @@ SERVER." (if (zerop (nnmairix-call-mairix-binary-raw (split-string nnmairix-mairix-command) (list (concat "m:" mid)))) - (save-excursion - (set-buffer nnmairix-mairix-output-buffer) + (with-current-buffer nnmairix-mairix-output-buffer (goto-char (point-min)) (while (re-search-forward "^/.*$" nil t) (push (nnmairix-get-group-from-file-path (match-string 0)) @@ -1749,9 +1745,9 @@ SERVER." (gnus-group-prefixed-name group (car cur)) allgroups)))) (if (> (length allgroups) 1) - (setq group (completing-read - "Group %s exists on more than one IMAP server. Choose: " - allgroups nil t)) + (setq group (gnus-completing-read + "Group %s exists on more than one IMAP server. Choose" + allgroups t)) (setq group (car allgroups)))) group)) @@ -2044,5 +2040,4 @@ VALUES may contain values for editable fields from current article." (provide 'nnmairix) -;; arch-tag: bb187498-b229-4a55-8c07-6d3f80713e94 ;;; nnmairix.el ends here diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index f37fa3618d..26f2963efb 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -79,8 +79,7 @@ (nnoo-define-basics nnmbox) (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let ((number (length sequence)) (count 0) @@ -149,8 +148,7 @@ (deffoo nnmbox-request-article (article &optional newsgroup server buffer) (nnmbox-possibly-change-newsgroup newsgroup server) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (when (nnmbox-find-article article) (let (start stop) (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) @@ -174,7 +172,7 @@ (cons nnmbox-current-group article) (nnmbox-article-group-number nil))))))) -(deffoo nnmbox-request-group (group &optional server dont-check) +(deffoo nnmbox-request-group (group &optional server dont-check info) (nnmbox-possibly-change-newsgroup nil server) (let ((active (cadr (assoc group nnmbox-group-alist)))) (cond @@ -208,8 +206,7 @@ (nnmail-get-new-mail 'nnmbox (lambda () - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (nnmbox-save-buffer))) (file-name-directory nnmbox-mbox-file) group @@ -253,8 +250,7 @@ rest) (nnmail-activate 'nnmbox) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (while (and articles is-old) (when (nnmbox-find-article (car articles)) (if (setq is-old @@ -292,8 +288,7 @@ result) (and (nnmbox-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) @@ -364,8 +359,7 @@ (deffoo nnmbox-request-replace-article (article group buffer) (nnmbox-possibly-change-newsgroup group) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (if (not (nnmbox-find-article article)) nil (nnmbox-delete-mail t t) @@ -391,8 +385,7 @@ ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) @@ -412,8 +405,7 @@ (deffoo nnmbox-request-rename-group (group new-name &optional server) (nnmbox-possibly-change-newsgroup group server) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) @@ -633,8 +625,7 @@ (nnmbox-create-mbox) (if (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) () (save-excursion @@ -649,6 +640,7 @@ nnmbox-mbox-file t t)))) (mm-enable-multibyte) (buffer-disable-undo) + (gnus-add-buffer) ;; Go through the group alist and compare against the mbox file. (while alist @@ -718,5 +710,4 @@ (provide 'nnmbox) -;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659 ;;; nnmbox.el ends here diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 0f0116ad06..c613e88c11 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -149,7 +149,7 @@ as unread by Gnus.") (save-excursion (nnmail-find-file file)) (string-to-number (file-name-nondirectory file))))) -(deffoo nnmh-request-group (group &optional server dont-check) +(deffoo nnmh-request-group (group &optional server dont-check info) (nnheader-init-server-buffer) (nnmh-possibly-change-directory group server) (let ((pathname (nnmail-group-pathname group nnmh-directory)) @@ -207,40 +207,48 @@ as unread by Gnus.") (defun nnmh-request-list-1 (dir) (setq dir (expand-file-name dir)) ;; Recurse down all directories. - (let ((dirs (and (file-readable-p dir) - (nnheader-directory-files dir t nil t))) - rdir) + (let ((files (nnheader-directory-files dir t nil t)) + (max 0) + min rdir num subdirectoriesp file) ;; Recurse down directories. - (while (setq rdir (pop dirs)) - (when (and (file-directory-p rdir) - (file-readable-p rdir) - (not (equal (file-truename rdir) - (file-truename dir)))) - (nnmh-request-list-1 rdir)))) - ;; For each directory, generate an active file line. - (unless (string= (expand-file-name nnmh-toplev) dir) - (let ((files (mapcar 'string-to-number - (directory-files dir nil "^[0-9]+$" t)))) - (when files - (with-current-buffer nntp-server-buffer - (goto-char (point-max)) - (insert - (format - "%s %.0f %.0f y\n" - (progn - (string-match - (regexp-quote - (file-truename (file-name-as-directory - (expand-file-name nnmh-toplev)))) - dir) - (mm-string-to-multibyte ;Why? Isn't it multibyte already? - (mm-encode-coding-string - (nnheader-replace-chars-in-string - (substring dir (match-end 0)) - ?/ ?.) - nnmail-pathname-coding-system))) - (apply 'max files) - (apply 'min files))))))) + (setq subdirectoriesp (> (nth 1 (file-attributes dir)) 2)) + (dolist (rdir files) + (if (or (not subdirectoriesp) + (file-regular-p rdir)) + (progn + (setq file (file-name-nondirectory rdir)) + (when (string-match "^[0-9]+$" file) + (setq num (string-to-number file)) + (setq max (max max num)) + (when (or (null min) + (< num min)) + (setq min num)))) + ;; This is a directory. + (when (and (file-readable-p rdir) + (not (equal (file-truename rdir) + (file-truename dir)))) + (nnmh-request-list-1 rdir)))) + ;; For each directory, generate an active file line. + (unless (string= (expand-file-name nnmh-toplev) dir) + (with-current-buffer nntp-server-buffer + (goto-char (point-max)) + (insert + (format + "%s %.0f %.0f y\n" + (progn + (string-match + (regexp-quote + (file-truename (file-name-as-directory + (expand-file-name nnmh-toplev)))) + dir) + (mm-string-to-multibyte ;Why? Isn't it multibyte already? + (mm-encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system))) + (or max 0) + (or min 1)))))) t) (deffoo nnmh-request-newgroups (date &optional server) @@ -250,9 +258,6 @@ as unread by Gnus.") &optional server force) (nnmh-possibly-change-directory newsgroup server) (let ((is-old t) - (nnmail-expiry-target - (or (gnus-group-find-parameter newsgroup 'expiry-target t) - nnmail-expiry-target)) article rest mod-time) (nnheader-init-server-buffer) @@ -287,7 +292,7 @@ as unread by Gnus.") (deffoo nnmh-close-group (group &optional server) t) -(deffoo nnmh-request-move-article (article group server accept-form +(deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmh move*")) result) @@ -312,7 +317,7 @@ as unread by Gnus.") (nnmh-possibly-change-directory group server) (nnmail-check-syntax) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -574,5 +579,4 @@ as unread by Gnus.") (provide 'nnmh) -;; arch-tag: 36c12a98-3bad-44b3-9953-628078ef0e04 ;;; nnmh.el ends here diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 7144e64138..ba64ae8b09 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -1,7 +1,8 @@ ;;; nnml.el --- mail spool access for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software +;; Foundation, Inc. ;; Authors: Didier Verna <[email protected]> (adding compaction) ;; Simon Josefsson <[email protected]> (adding MARKS) @@ -160,8 +161,7 @@ non-nil.") (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) (when (nnml-possibly-change-directory group server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((file nil) (number (length sequence)) @@ -236,7 +236,11 @@ non-nil.") (nnheader-article-to-file-alist (setq gpath (nnml-group-pathname (car group-num) nil server)))))) - (setq path (concat gpath (int-to-string (cdr group-num))))) + (nnml-update-file-alist) + (setq path (concat gpath (if nnml-use-compressed-files + (cdr (assq (cdr group-num) + nnml-article-file-alist)) + (number-to-string (cdr group-num)))))) (setq path (nnml-article-to-file id))) (cond ((not path) @@ -255,7 +259,7 @@ non-nil.") (cons (if group-num (car group-num) group) (string-to-number (file-name-nondirectory path))))))) -(deffoo nnml-request-group (group &optional server dont-check) +(deffoo nnml-request-group (group &optional server dont-check info) (let ((file-name-coding-system nnmail-pathname-coding-system) (decoded (nnml-decoded-group-name group server))) (cond @@ -283,7 +287,7 @@ non-nil.") (deffoo nnml-request-scan (&optional group server) (setq nnml-article-file-alist nil) (nnml-possibly-change-directory group server) - (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) + (nnmail-get-new-mail 'nnml 'nnml-save-incremental-nov nnml-directory group)) (deffoo nnml-close-group (group &optional server) (setq nnml-article-file-alist nil) @@ -405,8 +409,7 @@ non-nil.") (let (nnml-current-directory nnml-current-group nnml-article-file-alist) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) @@ -438,7 +441,7 @@ non-nil.") (setq result (car (nnml-save-mail (list (cons group (nnml-active-number group server))) - server))) + server t))) (progn (nnmail-save-active nnml-group-alist nnml-active-file) (and last (nnml-save-nov)))) @@ -449,7 +452,7 @@ non-nil.") (nnml-active-number group ,server))))) (yes-or-no-p "Moved to `junk' group; delete article? ")) (setq result 'junk) - (setq result (car (nnml-save-mail result server)))) + (setq result (car (nnml-save-mail result server t)))) (when last (nnmail-save-active nnml-group-alist nnml-active-file) (when nnmail-cache-accepted-message-ids @@ -462,8 +465,7 @@ non-nil.") (deffoo nnml-request-replace-article (article group buffer) (nnml-possibly-change-directory group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (nnml-possibly-create-directory group) (let ((chars (nnmail-insert-lines)) (art (concat (int-to-string article) "\t")) @@ -478,8 +480,7 @@ non-nil.") t) (setq headers (nnml-parse-head chars article)) ;; Replace the NOV line in the NOV file. - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (goto-char (point-min)) (if (or (looking-at art) (search-forward (concat "\n" art) nil t)) @@ -614,8 +615,7 @@ non-nil.") ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id server) - (save-excursion - (set-buffer (get-buffer-create " *nnml id*")) + (with-current-buffer (get-buffer-create " *nnml id*") (let ((alist nnml-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -657,8 +657,7 @@ non-nil.") nil (let ((nov (expand-file-name nnml-nov-file-name nnml-current-directory))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -691,7 +690,7 @@ non-nil.") (make-directory (directory-file-name dir) t) (nnheader-message 5 "Creating mail directory %s" dir)))) -(defun nnml-save-mail (group-art &optional server) +(defun nnml-save-mail (group-art &optional server full-nov) "Save a mail into the groups GROUP-ART in the nnml server SERVER. GROUP-ART is a list that each element is a cons of a group name and an article number. This function is called narrowed to an article." @@ -742,19 +741,21 @@ article number. This function is called narrowed to an article." ;; header. (setq headers (nnml-parse-head chars)) ;; Output the nov line to all nov databases that should have it. - (if nnmail-group-names-not-encoded-p + (let ((func (if full-nov + 'nnml-add-nov + 'nnml-add-incremental-nov))) + (if nnmail-group-names-not-encoded-p + (dolist (ga group-art) + (funcall func (pop dec) (cdr ga) headers)) (dolist (ga group-art) - (nnml-add-nov (pop dec) (cdr ga) headers)) - (dolist (ga group-art) - (nnml-add-nov (car ga) (cdr ga) headers)))) + (funcall func (car ga) (cdr ga) headers))))) group-art) (defun nnml-active-number (group &optional server) "Compute the next article number in GROUP on SERVER." - (let ((active (cadr (assoc (if nnmail-group-names-not-encoded-p - (nnml-encoded-group-name group server) - group) - nnml-group-alist)))) + (let* ((encoded (if nnmail-group-names-not-encoded-p + (nnml-encoded-group-name group server))) + (active (cadr (assoc (or encoded group) nnml-group-alist)))) ;; The group wasn't known to nnml, so we just create an active ;; entry for it. (unless active @@ -772,17 +773,44 @@ article number. This function is called narrowed to an article." (cons (caar nnml-article-file-alist) (caar (last nnml-article-file-alist))) (cons 1 0))) - (push (list group active) nnml-group-alist)) + (push (list (or encoded group) active) nnml-group-alist)) (setcdr active (1+ (cdr active))) (while (file-exists-p (nnml-group-pathname group (int-to-string (cdr active)) server)) (setcdr active (1+ (cdr active)))) (cdr active))) +(defvar nnml-incremental-nov-buffer-alist nil) + +(defun nnml-save-incremental-nov () + (save-excursion + (while nnml-incremental-nov-buffer-alist + (when (buffer-name (cdar nnml-incremental-nov-buffer-alist)) + (set-buffer (cdar nnml-incremental-nov-buffer-alist)) + (when (buffer-modified-p) + (nnmail-write-region (point-min) (point-max) + nnml-nov-buffer-file-name t 'nomesg)) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (setq nnml-incremental-nov-buffer-alist + (cdr nnml-incremental-nov-buffer-alist))))) + +(defun nnml-open-incremental-nov (group) + (or (cdr (assoc group nnml-incremental-nov-buffer-alist)) + (let ((buffer (nnml-get-nov-buffer group t))) + (push (cons group buffer) nnml-incremental-nov-buffer-alist) + buffer))) + +(defun nnml-add-incremental-nov (group article headers) + "Add a nov line for the GROUP nov headers, incrementally." + (with-current-buffer (nnml-open-incremental-nov group) + (goto-char (point-max)) + (mail-header-set-number headers article) + (nnheader-insert-nov headers))) + (defun nnml-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) @@ -805,21 +833,27 @@ article number. This function is called narrowed to an article." (mail-header-set-number headers number) headers)))) -(defun nnml-get-nov-buffer (group) +(defun nnml-get-nov-buffer (group &optional incrementalp) (let* ((decoded (nnml-decoded-group-name group)) - (buffer (get-buffer-create (format " *nnml overview %s*" decoded))) + (buffer (get-buffer-create (format " *nnml %soverview %s*" + (if incrementalp + "incremental " + "") + decoded))) (file-name-coding-system nnmail-pathname-coding-system)) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) (nnmail-group-pathname decoded nnml-directory nnml-nov-file-name)) (erase-buffer) - (when (file-exists-p nnml-nov-buffer-file-name) + (when (and (not incrementalp) + (file-exists-p nnml-nov-buffer-file-name)) (nnheader-insert-file-contents nnml-nov-buffer-file-name))) buffer)) (defun nnml-open-nov (group) - (or (cdr (assoc group nnml-nov-buffer-alist)) + (or (let ((buffer (cdr (assoc group nnml-nov-buffer-alist)))) + (and (buffer-name buffer) + buffer)) (let ((buffer (nnml-get-nov-buffer group))) (push (cons group buffer) nnml-nov-buffer-alist) buffer))) @@ -851,6 +885,7 @@ article number. This function is called narrowed to an article." ;; Save the active file. (nnmail-save-active nnml-group-alist nnml-active-file)) +(defvar nnml-files) (defun nnml-generate-nov-databases-directory (dir &optional seen no-active) "Regenerate the NOV database in DIR. @@ -870,9 +905,9 @@ Unless no-active is non-nil, update the active file too." (file-directory-p dir)) (nnml-generate-nov-databases-directory dir seen))) ;; Do this directory. - (let ((files (sort (nnheader-article-to-file-alist dir) + (let ((nnml-files (sort (nnheader-article-to-file-alist dir) 'car-less-than-car))) - (if (not files) + (if (not nnml-files) (let* ((group (nnheader-file-to-group (directory-file-name dir) nnml-directory)) (info (cadr (assoc group nnml-group-alist)))) @@ -880,11 +915,10 @@ Unless no-active is non-nil, update the active file too." (setcar info (1+ (cdr info))))) (funcall nnml-generate-active-function dir) ;; Generate the nov file. - (nnml-generate-nov-file dir files) + (nnml-generate-nov-file dir nnml-files) (unless no-active (nnmail-save-active nnml-group-alist nnml-active-file))))))) -(defvar files) (defun nnml-generate-active-info (dir) ;; Update the active info for this group. (let ((group (directory-file-name dir)) @@ -895,9 +929,9 @@ Unless no-active is non-nil, update the active file too." last (or (caadr entry) 0) nnml-group-alist (delq entry nnml-group-alist)) (push (list group - (cons (or (caar files) (1+ last)) + (cons (or (caar nnml-files) (1+ last)) (max last - (or (caar (last files)) + (or (caar (last nnml-files)) 0)))) nnml-group-alist))) @@ -906,42 +940,38 @@ Unless no-active is non-nil, update the active file too." (nov (concat dir nnml-nov-file-name)) (nov-buffer (get-buffer-create " *nov*")) chars file headers) - (save-excursion + (with-current-buffer nov-buffer ;; Init the nov buffer. - (set-buffer nov-buffer) (buffer-disable-undo) (erase-buffer) (set-buffer nntp-server-buffer) ;; Delete the old NOV file. (when (file-exists-p nov) (funcall nnmail-delete-file-function nov)) - (while files - (unless (file-directory-p (setq file (concat dir (cdar files)))) - (erase-buffer) - (nnheader-insert-file-contents file) - (narrow-to-region - (goto-char (point-min)) - (progn - (re-search-forward "\n\r?\n" nil t) - (setq chars (- (point-max) (point))) - (max (point-min) (1- (point))))) - (unless (zerop (buffer-size)) - (goto-char (point-min)) - (setq headers (nnml-parse-head chars (caar files))) - (save-excursion - (set-buffer nov-buffer) - (goto-char (point-max)) - (nnheader-insert-nov headers))) - (widen)) - (setq files (cdr files))) - (save-excursion - (set-buffer nov-buffer) + (dolist (file files) + (let ((path (concat dir (cdr file)))) + (unless (file-directory-p path) + (erase-buffer) + (nnheader-insert-file-contents path) + (narrow-to-region + (goto-char (point-min)) + (progn + (re-search-forward "\n\r?\n" nil t) + (setq chars (- (point-max) (point))) + (max (point-min) (1- (point))))) + (unless (zerop (buffer-size)) + (goto-char (point-min)) + (setq headers (nnml-parse-head chars (car file))) + (with-current-buffer nov-buffer + (goto-char (point-max)) + (nnheader-insert-nov headers))) + (widen)))) + (with-current-buffer nov-buffer (nnmail-write-region (point-min) (point-max) nov nil 'nomesg) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point))) (when (bobp) @@ -972,11 +1002,9 @@ Use the nov database for that directory if available." ;; build list from .overview if available ;; We would use nnml-open-nov, except that nnml-nov-buffer-alist is ;; defvoo'd, and we might get called when it hasn't been swapped in. - (save-excursion + (with-current-buffer (nnml-get-nov-buffer nnml-current-group) (let ((list nil) - art - (buffer (nnml-get-nov-buffer nnml-current-group))) - (set-buffer buffer) + art) (goto-char (point-min)) (while (not (eobp)) (setq art (read (current-buffer))) @@ -995,11 +1023,9 @@ Use the nov database for the current group if available." nnml-current-directory)))) (nnheader-article-to-file-alist nnml-current-directory) ;; build list from .overview if available - (save-excursion + (with-current-buffer (nnml-get-nov-buffer nnml-current-group) (let ((alist nil) - (buffer (nnml-get-nov-buffer nnml-current-group)) art) - (set-buffer buffer) (goto-char (point-min)) (while (not (eobp)) (setq art (read (current-buffer))) @@ -1012,23 +1038,11 @@ Use the nov database for the current group if available." (nnml-possibly-change-directory group server) (unless nnml-marks-is-evil (nnml-open-marks group server) - (dolist (action actions) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) nil - "Unknown request-set-mark action: %s" what) - (dolist (mark marks) - (setq nnml-marks (gnus-update-alist-soft - mark - (funcall (if (eq what 'add) 'gnus-range-add - 'gnus-remove-from-range) - (cdr (assoc mark nnml-marks)) range) - nnml-marks))))) + (setq nnml-marks (nnheader-update-marks-actions nnml-marks actions)) (nnml-save-marks group server)) nil) -(deffoo nnml-request-update-info (group info &optional server) +(deffoo nnml-request-marks (group info &optional server) (nnml-possibly-change-directory group server) (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group server)) (nnheader-message 8 "Updating marks for %s..." group) @@ -1224,8 +1238,7 @@ Use the nov database for the current group if available." (gnus-info-set-marks info newmarks)) ;; 3/ Update the NOV entry for this article: (unless nnml-nov-is-evil - (save-excursion - (set-buffer (nnml-open-nov group)) + (with-current-buffer (nnml-open-nov group) (when (nnheader-find-nov-line old-number) ;; Replace the article number: (looking-at old-number-string) @@ -1307,5 +1320,4 @@ Use the nov database for the current group if available." (provide 'nnml) -;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004 ;;; nnml.el ends here diff --git a/lisp/gnus/nnnil.el b/lisp/gnus/nnnil.el index f20d63e70a..e40126d6e0 100644 --- a/lisp/gnus/nnnil.el +++ b/lisp/gnus/nnnil.el @@ -56,10 +56,9 @@ (setq nnnil-status-string "No such group") nil) -(defun nnnil-request-group (group &optional server fast) +(defun nnnil-request-group (group &optional server fast info) (let (deactivate-mark) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (insert "411 no such news group\n"))) (setq nnnil-status-string "No such group") @@ -79,4 +78,4 @@ (provide 'nnnil) -;; arch-tag: a982a1a3-bc5e-4fb1-a233-d7657a3e3257 +;;; nnnil.el ends here diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index 637bc1790a..99c6356e22 100644 --- a/lisp/gnus/nnoo.el +++ b/lisp/gnus/nnoo.el @@ -322,5 +322,4 @@ All functions will return nil and report an error." (provide 'nnoo) -;; arch-tag: 0196b5ed-6f34-4778-a455-73a971f837e7 ;;; nnoo.el ends here diff --git a/lisp/gnus/nnregistry.el b/lisp/gnus/nnregistry.el new file mode 100644 index 0000000000..03ff5e716a --- /dev/null +++ b/lisp/gnus/nnregistry.el @@ -0,0 +1,66 @@ +;;; nnregistry.el --- access to articles via Gnus' message-id registry +;;; -*- coding: utf-8 -*- + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Authors: Ludovic Courtès <[email protected]> +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides the `nnregistry' Gnus back-end. It can be used +;; in `gnus-refer-article-method' to quickly search for a message by +;; id, regardless of the back-end that stores it. See the Gnus manual +;; for usage examples and more information. + +;;; Code: + +(require 'nnoo) +(require 'gnus-registry) +(require 'gnus-int) + +(nnoo-declare nnregistry) + +(deffoo nnregistry-server-opened (server) + (eq gnus-registry-install t)) + +(deffoo nnregistry-close-server (server) + t) + +(deffoo nnregistry-status-message (server) + nil) + +(deffoo nnregistry-open-server (server &optional defs) + (eq gnus-registry-install t)) + +(defvar nnregistry-within-nnregistry nil) + +(deffoo nnregistry-request-article (id &optional group server buffer) + (and (not nnregistry-within-nnregistry) + (let* ((nnregistry-within-nnregistry t) + (group (gnus-registry-fetch-group id)) + (gnus-override-method nil)) + (message "nnregistry: requesting article `%s' in group `%s'" + id group) + (and group + (gnus-check-group group) + (gnus-request-article id group buffer))))) + +(provide 'nnregistry) + +;;; nnregistry.el ends here diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 568d2ee80f..bfe31b71df 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -25,7 +25,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -77,7 +77,8 @@ this variable to the list of fields to be ignored.") (defvar nnrss-group-alist '() "List of RSS addresses.") -(defvar nnrss-use-local nil) +(defvar nnrss-use-local nil + "If non-nil nnrss will read the feeds from local files in nnrss-directory.") (defvar nnrss-description-field 'X-Gnus-Description "Field name used for DESCRIPTION. @@ -113,11 +114,6 @@ The cdr of each element is used to decode data if it is available when the car is what the data specify as the encoding. Or, the car is used for decoding when the cdr that the data specify is not available.") -(defvar nnrss-wash-html-in-text-plain-parts nil - "*Non-nil means render text in text/plain parts as HTML. -The function specified by the `mm-text-html-renderer' variable will be -used to render text. If it is nil, text will simply be folded.") - (nnoo-define-basics nnrss) ;;; Interface functions @@ -134,8 +130,7 @@ used to render text. If it is nil, text will simply be folded.") (setq group (nnrss-decode-group-name group)) (nnrss-possibly-change-group group server) (let (e) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (article articles) (if (setq e (assq article nnrss-group-data)) @@ -179,7 +174,7 @@ used to render text. If it is nil, text will simply be folded.") "\n"))))) 'nov) -(deffoo nnrss-request-group (group &optional server dont-check) +(deffoo nnrss-request-group (group &optional server dont-check info) (setq group (nnrss-decode-group-name group)) (nnheader-message 6 "nnrss: Requesting %s..." group) (nnrss-possibly-change-group group server) @@ -197,9 +192,6 @@ used to render text. If it is nil, text will simply be folded.") (deffoo nnrss-close-group (group &optional server) t) -(defvar mm-text-html-renderer) -(defvar mm-text-html-washer-alist) - (deffoo nnrss-request-article (article &optional group server buffer) (setq group (nnrss-decode-group-name group)) (when (stringp article) @@ -240,46 +232,25 @@ used to render text. If it is nil, text will simply be folded.") (when text (insert text) (goto-char body) - (if (and nnrss-wash-html-in-text-plain-parts - (progn - (require 'mm-view) - (setq fn (or (cdr (assq mm-text-html-renderer - mm-text-html-washer-alist)) - mm-text-html-renderer)))) - (progn - (narrow-to-region body (point-max)) - (if (functionp fn) - (funcall fn) - (apply (car fn) (cdr fn))) - (widen) - (goto-char body) - (re-search-forward "[^\t\n ]" nil t) - (beginning-of-line) - (delete-region body (point)) - (goto-char (point-max)) - (skip-chars-backward "\t\n ") - (end-of-line) - (delete-region (point) (point-max)) - (insert "\n")) - (while (re-search-forward "\n+" nil t) - (replace-match " ")) - (goto-char body) - ;; See `nnrss-check-group', which inserts "<br /><br />". - (when (search-forward "<br /><br />" nil t) - (if (eobp) - (replace-match "\n") - (replace-match "\n\n"))) - (unless (eobp) - (let ((fill-column (default-value 'fill-column)) - (window (get-buffer-window nntp-server-buffer))) - (when window - (setq fill-column - (max 1 (/ (* (window-width window) 7) 8)))) - (fill-region (point) (point-max)) - (goto-char (point-max)) - ;; XEmacs version of `fill-region' inserts newline. - (unless (bolp) - (insert "\n"))))) + (while (re-search-forward "\n+" nil t) + (replace-match " ")) + (goto-char body) + ;; See `nnrss-check-group', which inserts "<br /><br />". + (when (search-forward "<br /><br />" nil t) + (if (eobp) + (replace-match "\n") + (replace-match "\n\n"))) + (unless (eobp) + (let ((fill-column (default-value 'fill-column)) + (window (get-buffer-window nntp-server-buffer))) + (when window + (setq fill-column + (max 1 (/ (* (window-width window) 7) 8)))) + (fill-region (point) (point-max)) + (goto-char (point-max)) + ;; XEmacs version of `fill-region' inserts newline. + (unless (bolp) + (insert "\n")))) (when (or link enclosure) (insert "\n"))) (when link @@ -342,11 +313,6 @@ used to render text. If it is nil, text will simply be folded.") ;; we return the article number. (cons nnrss-group (car e)))))) -(deffoo nnrss-request-list (&optional server) - (nnrss-possibly-change-group nil server) - (nnrss-generate-active) - t) - (deffoo nnrss-open-server (server &optional defs connectionless) (nnrss-read-server-data server) (nnoo-change-server 'nnrss server defs) @@ -389,14 +355,24 @@ used to render text. If it is nil, text will simply be folded.") (deffoo nnrss-request-list-newsgroups (&optional server) (nnrss-possibly-change-group nil server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (elem nnrss-group-alist) (if (third elem) (insert (car elem) "\t" (third elem) "\n")))) t) +(deffoo nnrss-retrieve-groups (groups &optional server) + (dolist (group groups) + (nnrss-possibly-change-group group server) + (nnrss-check-group group server)) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (group groups) + (let ((elem (assoc group nnrss-server-data))) + (insert (format "%S %s 1 y\n" group (or (cadr elem) 0))))) + 'active)) + (nnoo-define-skeleton nnrss) ;;; Internal functions @@ -479,26 +455,12 @@ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s" (nnrss-read-group-data group server) (setq nnrss-group group))) -(defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories)) - -(defun nnrss-generate-active () - (when (y-or-n-p "Fetch extra categories? ") - (mapc 'funcall nnrss-extra-categories)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnrss-group-alist) - (insert (prin1-to-string (car elem)) " 0 1 y\n")) - (dolist (elem nnrss-server-data) - (unless (assoc (car elem) nnrss-group-alist) - (insert (prin1-to-string (car elem)) " 0 1 y\n"))))) - (autoload 'timezone-parse-date "timezone") (defun nnrss-normalize-date (date) "Return a date string of DATE in the RFC822 style. This function handles the ISO 8601 date format described in -<URL:http://www.w3.org/TR/NOTE-datetime>, and also the RFC822 style +URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC822 style which RSS 2.0 allows." (let (case-fold-search vector year month day time zone cts given) (cond ((null date)) ; do nothing for this case @@ -571,12 +533,7 @@ which RSS 2.0 allows." (let ((file (nnrss-make-filename "nnrss" server)) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) - ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII - ;; file names. So, we use `insert-file-contents' instead. - (mm-with-multibyte-buffer - (let ((coding-system-for-read nnrss-file-coding-system)) - (insert-file-contents file) - (eval-region (point-min) (point-max))))))) + (load file nil t t)))) (defun nnrss-save-server-data (server) (gnus-make-directory nnrss-directory) @@ -600,12 +557,7 @@ which RSS 2.0 allows." (let ((file (nnrss-make-filename group server)) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) - ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII - ;; file names. So, we use `insert-file-contents' instead. - (mm-with-multibyte-buffer - (let ((coding-system-for-read nnrss-file-coding-system)) - (insert-file-contents file) - (eval-region (point-min) (point-max)))) + (load file nil t t) (dolist (e nnrss-group-data) (puthash (nth 9 e) t nnrss-group-hashtb) (when (and (car e) (> nnrss-group-min (car e))) @@ -682,7 +634,7 @@ which RSS 2.0 allows." (rfc2047-encode-region (point-min) (point-max))) (goto-char (point-min)) (while (search-forward "\n" nil t) - (delete-backward-char 1)) + (delete-char -1)) (buffer-string))) ;;; Snarf functions @@ -722,9 +674,6 @@ which RSS 2.0 allows." (push (list group nnrss-group-max url) nnrss-server-data))) (setq changed t)) (setq xml (nnrss-fetch url))) - ;; See - ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html - ;; for more RSS namespaces. (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/") rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#") rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/") @@ -868,33 +817,6 @@ It is useful when `(setq nnrss-use-local t)'." (append nnheader-file-name-translation-alist '((?' . ?_))))) (nnheader-translate-file-chars name))) -(defvar nnrss-moreover-url - "http://w.moreover.com/categories/category_list_rss.html" - "The url of moreover.com categories.") - -(defun nnrss-snarf-moreover-categories () - "Snarf RSS links from moreover.com." - (interactive) - (let (category name url changed) - (with-temp-buffer - (nnrss-insert nnrss-moreover-url) - (goto-char (point-min)) - (while (re-search-forward - "<a name=\"\\([^\"]+\\)\">\\|<a href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil t) - (if (match-string 1) - (setq category (match-string 1)) - (setq url (match-string 2) - name (mm-url-decode-entities-string - (rfc2231-decode-encoded-string - (match-string 3)))) - (if category - (setq name (concat category "." name))) - (unless (assoc name nnrss-server-data) - (setq changed t) - (push (list name 0 url) nnrss-server-data))))) - (if changed - (nnrss-save-server-data "")))) - (defun nnrss-node-text (namespace local-name element) (let* ((node (assq (intern (concat namespace (symbol-name local-name))) element)) @@ -1012,7 +934,7 @@ whether they are `offsite' or `onsite'." (defun nnrss-discover-feed (url) "Given a page, find an RSS feed using Mark Pilgrim's -`ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)." +`ultra-liberal rss locator'." (let ((parsed-page (nnrss-fetch url))) @@ -1095,9 +1017,9 @@ whether they are `offsite' or `onsite'." (cdr (assoc "feedid" listinfo))))) feedinfo))) (cdr (assoc - (completing-read - "Multiple feeds found. Select one: " - selection nil t) urllist))))))))) + (gnus-completing-read + "Multiple feeds found. Select one" + selection t) urllist))))))))) (defun nnrss-rss-p (data) "Test if DATA is an RSS feed. @@ -1134,5 +1056,4 @@ prefix), return the prefix." (provide 'nnrss) -;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267 ;;; nnrss.el ends here diff --git a/lisp/gnus/nnslashdot.el b/lisp/gnus/nnslashdot.el deleted file mode 100644 index c4025a7849..0000000000 --- a/lisp/gnus/nnslashdot.el +++ /dev/null @@ -1,505 +0,0 @@ -;;; nnslashdot.el --- interfacing with Slashdot - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) - -(nnoo-declare nnslashdot) - -(defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/") - "Where nnslashdot will save its files.") - -(defvoo nnslashdot-active-url "http://slashdot.org/search.pl?section=&min=%d" - "Where nnslashdot will fetch the active file from.") - -(defvoo nnslashdot-comments-url "http://slashdot.org/comments.pl?sid=%s&threshold=%d&commentsort=%d&mode=flat&startat=%d" - "Where nnslashdot will fetch comments from.") - -(defvoo nnslashdot-article-url - "http://slashdot.org/article.pl?sid=%s&mode=nocomment" - "Where nnslashdot will fetch the article from.") - -(defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml" - "Where nnslashdot will fetch the stories from.") - -(defvoo nnslashdot-use-front-page nil - "Use the front page in addition to the backslash page.") - -(defvoo nnslashdot-threshold -1 - "The article threshold.") - -(defvoo nnslashdot-threaded t - "Whether the nnslashdot groups should be threaded or not.") - -(defvoo nnslashdot-group-number 0 - "The number of non-fresh groups to keep updated.") - -(defvoo nnslashdot-login-name "" - "The login name to use when posting.") - -(defvoo nnslashdot-password "" - "The password to use when posting.") - -;;; Internal variables - -(defvar nnslashdot-groups nil) -(defvar nnslashdot-buffer nil) -(defvar nnslashdot-headers nil) - -;;; Interface functions - -(nnoo-define-basics nnslashdot) - -(deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old) - (nnslashdot-possibly-change-server group server) - (condition-case why - (unless gnus-nov-is-evil - (nnslashdot-retrieve-headers-1 articles group)) - (search-failed (nnslashdot-lose why)))) - -(deffoo nnslashdot-retrieve-headers-1 (articles group) - (let* ((last (car (last articles))) - (start (if nnslashdot-threaded 1 (pop articles))) - (entry (assoc group nnslashdot-groups)) - (sid (nth 2 entry)) - (first-comments t) - headers article subject score from date lines parent point cid - s startats changed) - (save-excursion - (set-buffer nnslashdot-buffer) - (let ((case-fold-search t)) - (erase-buffer) - (when (= start 1) - (mm-url-insert (format nnslashdot-article-url sid) t) - (goto-char (point-min)) - (if (eobp) - (error "Couldn't open connection to slashdot")) - (re-search-forward "Posted by[ \t\r\n]+") - (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)") - (setq from (mm-url-decode-entities-string (match-string 2)))) - (search-forward "on ") - (setq date (nnslashdot-date-to-date - (buffer-substring (point) (1- (search-forward "<"))))) - (setq lines (/ (- (point) - (progn (forward-line 1) (point))) - 60)) - (push - (cons - 1 - (make-full-mail-header - 1 group from date - (concat "<" sid "%1@slashdot>") - "" 0 lines nil nil)) - headers) - (setq start (if nnslashdot-threaded 2 (pop articles)))) - (while (and start (<= start last)) - (setq point (goto-char (point-max))) - (mm-url-insert - (format nnslashdot-comments-url sid - nnslashdot-threshold 0 (- start 2)) - t) - (when (and nnslashdot-threaded first-comments) - (setq first-comments nil) - (goto-char (point-max)) - (while (re-search-backward "startat=\\([0-9]+\\)" nil t) - (setq s (string-to-number (match-string 1))) - (unless (memq s startats) - (push s startats))) - (setq startats (sort startats '<))) - (setq article (if (and article (< start article)) article start)) - (goto-char point) - (while (re-search-forward - "<a name=\"\\([0-9]+\\)\">\\([^<]+\\)\\(?:.*\n\\)\\{2,10\\}.*score:\\([^)]+\\))" - nil t) - (setq cid (match-string 1) - subject (match-string 2) - score (match-string 3)) - (unless (assq article (nth 4 entry)) - (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry))) - (setq changed t)) - (when (string-match "^Re: *" subject) - (setq subject (concat "Re: " (substring subject (match-end 0))))) - (setq subject (mm-url-decode-entities-string subject) - from "") - (when (re-search-forward "by[ \t\n]+<[^>]+>\\([^<(]+\\)" nil t) - (setq from - (concat - (mm-url-decode-entities-string (match-string 1)) - " <[email protected]>"))) - (search-forward "on ") - (setq date - (nnslashdot-date-to-date - (buffer-substring - (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) - (setq lines (/ (abs (- (search-forward "<div") - (search-forward "</div>"))) - 70)) - (if (not - (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t)) - (setq parent nil) - (setq parent (match-string 1)) - (when (string= parent "0") - (setq parent nil))) - (push - (cons - article - (make-full-mail-header - article - (concat subject " (" score ")") - from date - (concat "<" sid "%" cid "@slashdot>") - (if parent - (concat "<" sid "%" parent "@slashdot>") - "") - 0 lines nil nil)) - headers) - (while (and articles (<= (car articles) article)) - (pop articles)) - (setq article (1+ article))) - (if nnslashdot-threaded - (progn - (setq start (pop startats)) - (if start (setq start (+ start 2)))) - (setq start (pop articles)))))) - (if changed (nnslashdot-write-groups)) - (setq nnslashdot-headers (sort headers 'car-less-than-car)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (mm-with-unibyte-current-buffer - (dolist (header nnslashdot-headers) - (nnheader-insert-nov (cdr header))))) - 'nov)) - -(deffoo nnslashdot-request-group (group &optional server dont-check) - (nnslashdot-possibly-change-server nil server) - (let ((elem (assoc group nnslashdot-groups))) - (cond - ((not elem) - (nnheader-report 'nnslashdot "Group does not exist")) - (t - (nnheader-report 'nnslashdot "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) - (prin1-to-string group)))))) - -(deffoo nnslashdot-close-group (group &optional server) - (nnslashdot-possibly-change-server group server) - (when (gnus-buffer-live-p nnslashdot-buffer) - (save-excursion - (set-buffer nnslashdot-buffer) - (kill-buffer nnslashdot-buffer))) - t) - -(deffoo nnslashdot-request-article (article &optional group server buffer) - (nnslashdot-possibly-change-server group server) - (let (contents cid) - (condition-case why - (save-excursion - (set-buffer nnslashdot-buffer) - (let ((case-fold-search t)) - (goto-char (point-min)) - (when (and (stringp article) - (string-match "%\\([0-9]+\\)@" article)) - (setq cid (match-string 1 article)) - (let ((map (nth 4 (assoc group nnslashdot-groups)))) - (while map - (if (equal (cdar map) cid) - (setq article (caar map) - map nil) - (setq map (cdr map)))))) - (when (numberp article) - (if (= article 1) - (progn - (search-forward "Posted by") - (search-forward "<div class=\"intro\">") - (setq contents - (buffer-substring - (point) - (progn - (search-forward "commentwrap") - (match-beginning 0))))) - (setq cid (cdr (assq article - (nth 4 (assoc group nnslashdot-groups))))) - (search-forward (format "<a name=\"%s\">" cid)) - (setq contents - (buffer-substring - (search-forward "<div class=\"commentBody\">") - (progn - (search-forward "<div class=\"commentSub\"") - (match-beginning 0)))))))) - (search-failed (nnslashdot-lose why))) - - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (mm-with-unibyte-current-buffer - (insert contents) - (goto-char (point-min)) - (while (re-search-forward "\\(<br>\r?\\)+" nil t) - (replace-match "<p>" t t)) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (insert "Newsgroups: " (caddr (assoc group nnslashdot-groups)) - "\n") - (let ((header (cdr (assq article nnslashdot-headers)))) - (nnheader-insert-header header)) - (nnheader-report 'nnslashdot "Fetched article %s" article)) - (cons group article))))) - -(deffoo nnslashdot-close-server (&optional server) - (when (and (nnslashdot-server-opened server) - (gnus-buffer-live-p nnslashdot-buffer)) - (save-excursion - (set-buffer nnslashdot-buffer) - (kill-buffer nnslashdot-buffer))) - (nnoo-close-server 'nnslashdot server)) - -(deffoo nnslashdot-request-list (&optional server) - (nnslashdot-possibly-change-server nil server) - (let ((number 0) - (first nnslashdot-use-front-page) - sid elem description articles gname) - (condition-case why - ;; First we do the Ultramode to get info on all the latest groups. - (progn - (mm-with-unibyte-buffer - (mm-url-insert nnslashdot-backslash-url t) - (goto-char (point-min)) - (if (eobp) - (error "Couldn't open connection to slashdot")) - (while (search-forward "<story>" nil t) - (narrow-to-region (point) (search-forward "</story>")) - (goto-char (point-min)) - (re-search-forward "<title>\\([^<]+\\)</title>") - (setq description - (mm-url-decode-entities-string (match-string 1))) - (re-search-forward "<url>\\([^<]+\\)</url>") - (setq sid (match-string 1)) - (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid) - (setq sid (match-string 1 sid)) - (re-search-forward "<comments>\\([^<]+\\)</comments>") - (setq articles (string-to-number (match-string 1))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid (current-time) nil) - nnslashdot-groups)) - (goto-char (point-max)) - (widen))) - ;; Then do the older groups. - (while (or first - (> (- nnslashdot-group-number number) 0)) - (setq first nil) - (mm-with-unibyte-buffer - (let ((case-fold-search t)) - (mm-url-insert (format nnslashdot-active-url number) t) - (goto-char (point-min)) - (while (re-search-forward - "article.pl\\?sid=\\([^&]+\\).*>\\([^<]+\\)</a>" - nil t) - (setq sid (match-string 1) - description - (mm-url-decode-entities-string (match-string 2))) - (forward-line 1) - (when (re-search-forward "with \\([0-9]+\\) comment" nil t) - (setq articles (1+ (string-to-number (match-string 1))))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid (current-time) nil) - nnslashdot-groups))))) - (incf number 30))) - (search-failed (nnslashdot-lose why))) - (nnslashdot-write-groups) - (nnslashdot-generate-active) - t)) - -(deffoo nnslashdot-request-newgroups (date &optional server) - (nnslashdot-possibly-change-server nil server) - (nnslashdot-generate-active) - t) - -(deffoo nnslashdot-request-post (&optional server) - (nnslashdot-possibly-change-server nil server) - (let ((sid (message-fetch-field "newsgroups")) - (subject (message-fetch-field "subject")) - (references (car (last (split-string - (message-fetch-field "references"))))) - body quoted pid) - (string-match "%\\([0-9]+\\)@slashdot" references) - (setq pid (match-string 1 references)) - (message-goto-body) - (narrow-to-region (point) (progn (message-goto-signature) (point))) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "> ") - (progn - (delete-region (point) (+ (point) 2)) - (unless quoted - (insert "<blockquote>\n")) - (setq quoted t)) - (when quoted - (insert "</blockquote>\n") - (setq quoted nil))) - (forward-line 1)) - (goto-char (point-min)) - (while (re-search-forward "^ *\n" nil t) - (replace-match "<p>\n")) - (widen) - (when (message-goto-signature) - (forward-line -1) - (insert "<p>\n") - (while (not (eobp)) - (end-of-line) - (insert "<br>") - (forward-line 1))) - (message-goto-body) - (setq body (buffer-substring (point) (point-max))) - (erase-buffer) - (mm-url-fetch-form - "http://slashdot.org/comments.pl" - `(("sid" . ,sid) - ("pid" . ,pid) - ("rlogin" . "userlogin") - ("unickname" . ,nnslashdot-login-name) - ("upasswd" . ,nnslashdot-password) - ("postersubj" . ,subject) - ("op" . "Submit") - ("postercomment" . ,body) - ("posttype" . "html"))))) - -(deffoo nnslashdot-request-delete-group (group &optional force server) - (nnslashdot-possibly-change-server group server) - (setq nnslashdot-groups (delq (assoc group nnslashdot-groups) - nnslashdot-groups)) - (nnslashdot-write-groups)) - -(deffoo nnslashdot-request-close () - (setq nnslashdot-headers nil - nnslashdot-groups nil)) - -(deffoo nnslashdot-request-expire-articles - (articles group &optional server force) - (nnslashdot-possibly-change-server group server) - (let ((item (assoc group nnslashdot-groups))) - (when item - (if (fourth item) - (when (and (>= (length articles) (cadr item)) ;; All are expirable. - (nnmail-expired-article-p - group - (fourth item) - force)) - (setq nnslashdot-groups (delq item nnslashdot-groups)) - (nnslashdot-write-groups) - (setq articles nil)) ;; all expired. - (setcdr (cddr item) (list (current-time))) - (nnslashdot-write-groups)))) - articles) - -(nnoo-define-skeleton nnslashdot) - -;;; Internal functions - -(defun nnslashdot-possibly-change-server (&optional group server) - (nnslashdot-init server) - (when (and server - (not (nnslashdot-server-opened server))) - (nnslashdot-open-server server)) - (unless nnslashdot-groups - (nnslashdot-read-groups))) - -(defun nnslashdot-make-tuple (tuple n) - (prog1 - tuple - (while (> n 1) - (unless (cdr tuple) - (setcdr tuple (list nil))) - (setq tuple (cdr tuple) - n (1- n))))) - -(defun nnslashdot-read-groups () - (let ((file (expand-file-name "groups" nnslashdot-directory))) - (when (file-exists-p file) - (mm-with-unibyte-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnslashdot-groups (read (current-buffer)))) - (when (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5)) - (dolist (group nnslashdot-groups) - (nnslashdot-make-tuple group 5)))))) - -(defun nnslashdot-write-groups () - (with-temp-file (expand-file-name "groups" nnslashdot-directory) - (gnus-prin1 nnslashdot-groups))) - -(defun nnslashdot-init (server) - "Initialize buffers and such." - (unless (file-exists-p nnslashdot-directory) - (gnus-make-directory nnslashdot-directory)) - (unless (gnus-buffer-live-p nnslashdot-buffer) - (setq nnslashdot-buffer - (save-excursion - (nnheader-set-temp-buffer - (format " *nnslashdot %s*" server)))) - (push nnslashdot-buffer gnus-buffers))) - -(defun nnslashdot-date-to-date (sdate) - (condition-case err - (let ((elem (delete "" (split-string sdate)))) - (concat (substring (nth 0 elem) 0 3) " " - (substring (nth 1 elem) 0 3) " " - (substring (nth 2 elem) 0 2) " " - (substring (nth 3 elem) 1 6) " " - (format-time-string "%Y") " " - (nth 4 elem))) - (error ""))) - -(defun nnslashdot-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnslashdot-groups) - (when (numberp (cadr elem)) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n"))))) - -(defun nnslashdot-lose (why) - (error "Slashdot HTML has changed; please get a new version of nnslashdot")) - -(provide 'nnslashdot) - -;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3 -;;; nnslashdot.el ends here diff --git a/lisp/gnus/nnsoup.el b/lisp/gnus/nnsoup.el deleted file mode 100644 index 8bb6ca99c0..0000000000 --- a/lisp/gnus/nnsoup.el +++ /dev/null @@ -1,812 +0,0 @@ -;;; nnsoup.el --- SOUP access for Gnus - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Masanobu UMEDA <[email protected]> -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(require 'nnheader) -(require 'nnmail) -(require 'gnus-soup) -(require 'gnus-msg) -(require 'nnoo) -(eval-when-compile (require 'cl)) - -(nnoo-declare nnsoup) - -(defvoo nnsoup-directory (nnheader-concat gnus-home-directory "SOUP/") - "*SOUP packet directory.") - -(defvoo nnsoup-tmp-directory - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - ("/tmp/")) - "*Where nnsoup will store temporary files.") - -(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory) - "*Directory where outgoing packets will be composed.") - -(defvoo nnsoup-replies-format-type ?u ;; u is USENET news format. - "*Format of the replies packages.") - -(defvoo nnsoup-replies-index-type ?n - "*Index type of the replies packages.") - -(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory) - "Active file.") - -(defvoo nnsoup-packer (concat "tar cf - %s | gzip > " - (expand-file-name gnus-home-directory) - "Soupin%d.tgz") - "Format string command for packing a SOUP packet. -The SOUP files will be inserted where the %s is in the string. -This string MUST contain both %s and %d. The file number will be -inserted where %d appears.") - -(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -" - "*Format string command for unpacking a SOUP packet. -The SOUP packet file name will be inserted at the %s.") - -(defvoo nnsoup-packet-directory gnus-home-directory - "*Where nnsoup will look for incoming packets.") - -(defvoo nnsoup-packet-regexp "Soupout" - "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") - -(defvoo nnsoup-always-save t - "If non-nil commit the reply buffer on each message send. -This is necessary if using message mode outside Gnus with nnsoup as a -backend for the messages.") - - - -(defconst nnsoup-version "nnsoup 0.0" - "nnsoup version.") - -(defvoo nnsoup-status-string "") -(defvoo nnsoup-group-alist nil) -(defvoo nnsoup-current-prefix 0) -(defvoo nnsoup-replies-list nil) -(defvoo nnsoup-buffers nil) -(defvoo nnsoup-current-group nil) -(defvoo nnsoup-group-alist-touched nil) -(defvoo nnsoup-article-alist nil) - - -;;; Interface functions. - -(nnoo-define-basics nnsoup) - -(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old) - (nnsoup-possibly-change-group group) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist))) - (articles sequence) - (use-nov t) - useful-areas this-area-seq msg-buf) - (if (stringp (car sequence)) - ;; We don't support fetching by Message-ID. - 'headers - ;; We go through all the areas and find which files the - ;; articles in SEQUENCE come from. - (while (and areas sequence) - ;; Peel off areas that are below sequence. - (while (and areas (< (cdar (car areas)) (car sequence))) - (setq areas (cdr areas))) - (when areas - ;; This is a useful area. - (push (car areas) useful-areas) - (setq this-area-seq nil) - ;; We take note whether this MSG has a corresponding IDX - ;; for later use. - (when (or (= (gnus-soup-encoding-index - (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) - (not (file-exists-p - (nnsoup-file - (gnus-soup-area-prefix (nth 1 (car areas))))))) - (setq use-nov nil)) - ;; We assign the portion of `sequence' that is relevant to - ;; this MSG packet to this packet. - (while (and sequence (<= (car sequence) (cdar (car areas)))) - (push (car sequence) this-area-seq) - (setq sequence (cdr sequence))) - (setcar useful-areas (cons (nreverse this-area-seq) - (car useful-areas))))) - - ;; We now have a list of article numbers and corresponding - ;; areas. - (setq useful-areas (nreverse useful-areas)) - - ;; Two different approaches depending on whether all the MSG - ;; files have corresponding IDX files. If they all do, we - ;; simply return the relevant IDX files and let Gnus sort out - ;; what lines are relevant. If some of the IDX files are - ;; missing, we must return HEADs for all the articles. - (if use-nov - ;; We have IDX files for all areas. - (progn - (while useful-areas - (goto-char (point-max)) - (let ((b (point)) - (number (car (nth 1 (car useful-areas)))) - (index-buffer (nnsoup-index-buffer - (gnus-soup-area-prefix - (nth 2 (car useful-areas)))))) - (when index-buffer - (insert-buffer-substring index-buffer) - (goto-char b) - ;; We have to remove the index number entries and - ;; insert article numbers instead. - (while (looking-at "[0-9]+") - (replace-match (int-to-string number) t t) - (incf number) - (forward-line 1)))) - (setq useful-areas (cdr useful-areas))) - 'nov) - ;; We insert HEADs. - (while useful-areas - (setq articles (caar useful-areas) - useful-areas (cdr useful-areas)) - (while articles - (when (setq msg-buf - (nnsoup-narrow-to-article - (car articles) (cdar useful-areas) 'head)) - (goto-char (point-max)) - (insert (format "221 %d Article retrieved.\n" (car articles))) - (insert-buffer-substring msg-buf) - (goto-char (point-max)) - (insert ".\n")) - (setq articles (cdr articles)))) - - (nnheader-fold-continuation-lines) - 'headers))))) - -(deffoo nnsoup-open-server (server &optional defs) - (nnoo-change-server 'nnsoup server defs) - (when (not (file-exists-p nnsoup-directory)) - (condition-case () - (make-directory nnsoup-directory t) - (error t))) - (cond - ((not (file-exists-p nnsoup-directory)) - (nnsoup-close-server) - (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) - ((not (file-directory-p (file-truename nnsoup-directory))) - (nnsoup-close-server) - (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory)) - (t - (nnsoup-read-active-file) - (nnheader-report 'nnsoup "Opened server %s using directory %s" - server nnsoup-directory) - t))) - -(deffoo nnsoup-request-close () - (nnsoup-write-active-file) - (nnsoup-write-replies) - (gnus-soup-save-areas) - ;; Kill all nnsoup buffers. - (let (buffer) - (while nnsoup-buffers - (setq buffer (cdr (pop nnsoup-buffers))) - (and buffer - (buffer-name buffer) - (kill-buffer buffer)))) - (setq nnsoup-group-alist nil - nnsoup-group-alist-touched nil - nnsoup-current-group nil - nnsoup-replies-list nil) - (nnoo-close-server 'nnoo) - t) - -(deffoo nnsoup-request-article (id &optional newsgroup server buffer) - (nnsoup-possibly-change-group newsgroup) - (let (buf) - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (when (and (not (stringp id)) - (setq buf (nnsoup-narrow-to-article id))) - (insert-buffer-substring buf) - t)))) - -(deffoo nnsoup-request-group (group &optional server dont-check) - (nnsoup-possibly-change-group group) - (if dont-check - t - (let ((active (cadr (assoc group nnsoup-group-alist)))) - (if (not active) - (nnheader-report 'nnsoup "No such group: %s" group) - (nnheader-insert - "211 %d %d %d %s\n" - (max (1+ (- (cdr active) (car active))) 0) - (car active) (cdr active) group))))) - -(deffoo nnsoup-request-type (group &optional article) - (nnsoup-possibly-change-group group) - ;; Try to guess the type based on the first article in the group. - (when (not article) - (setq article - (cdar (car (cddr (assoc group nnsoup-group-alist)))))) - (if (not article) - 'unknown - (let ((kind (gnus-soup-encoding-kind - (gnus-soup-area-encoding - (nth 1 (nnsoup-article-to-area - article nnsoup-current-group)))))) - (cond ((= kind ?m) 'mail) - ((= kind ?n) 'news) - (t 'unknown))))) - -(deffoo nnsoup-close-group (group &optional server) - ;; Kill all nnsoup buffers. - (let ((buffers nnsoup-buffers) - elem) - (while buffers - (when (equal (car (setq elem (pop buffers))) group) - (setq nnsoup-buffers (delq elem nnsoup-buffers)) - (and (cdr elem) (buffer-name (cdr elem)) - (kill-buffer (cdr elem)))))) - t) - -(deffoo nnsoup-request-list (&optional server) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (unless nnsoup-group-alist - (nnsoup-read-active-file)) - (let ((alist nnsoup-group-alist) - (standard-output (current-buffer)) - entry) - (while (setq entry (pop alist)) - (insert (car entry) " ") - (princ (cdadr entry)) - (insert " ") - (princ (caadr entry)) - (insert " y\n")) - t))) - -(deffoo nnsoup-request-scan (group &optional server) - (nnsoup-unpack-packets)) - -(deffoo nnsoup-request-newgroups (date &optional server) - (nnsoup-request-list)) - -(deffoo nnsoup-request-list-newsgroups (&optional server) - nil) - -(deffoo nnsoup-request-post (&optional server) - (nnsoup-store-reply "news") - t) - -(deffoo nnsoup-request-mail (&optional server) - (nnsoup-store-reply "mail") - t) - -(deffoo nnsoup-request-expire-articles (articles group &optional server force) - (nnsoup-possibly-change-group group) - (let* ((total-infolist (assoc group nnsoup-group-alist)) - (active (cadr total-infolist)) - (infolist (cddr total-infolist)) - info range-list mod-time prefix) - (while infolist - (setq info (pop infolist) - range-list (gnus-uncompress-range (car info)) - prefix (gnus-soup-area-prefix (nth 1 info))) - (when;; All the articles in this file are marked for expiry. - (and (or (setq mod-time (nth 5 (file-attributes - (nnsoup-file prefix)))) - (setq mod-time (nth 5 (file-attributes - (nnsoup-file prefix t))))) - (gnus-sublist-p articles range-list) - ;; This file is old enough. - (nnmail-expired-article-p group mod-time force)) - ;; Ok, we delete this file. - (when (ignore-errors - (nnheader-message - 5 "Deleting %s in group %s..." (nnsoup-file prefix) - group) - (when (file-exists-p (nnsoup-file prefix)) - (delete-file (nnsoup-file prefix))) - (nnheader-message - 5 "Deleting %s in group %s..." (nnsoup-file prefix t) - group) - (when (file-exists-p (nnsoup-file prefix t)) - (delete-file (nnsoup-file prefix t))) - t) - (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) - (setq articles (gnus-sorted-difference articles range-list)))) - (when (not mod-time) - (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) - (if (cddr total-infolist) - (setcar active (caaadr (cdr total-infolist))) - (setcar active (1+ (cdr active)))) - (nnsoup-write-active-file t) - ;; Return the articles that weren't expired. - articles)) - - -;;; Internal functions - -(defun nnsoup-possibly-change-group (group &optional force) - (when (and group - (not (equal nnsoup-current-group group))) - (setq nnsoup-article-alist nil) - (setq nnsoup-current-group group)) - t) - -(defun nnsoup-read-active-file () - (setq nnsoup-group-alist nil) - (when (file-exists-p nnsoup-active-file) - (ignore-errors - (load nnsoup-active-file t t t)) - ;; Be backwards compatible. - (when (and nnsoup-group-alist - (not (atom (caadar nnsoup-group-alist)))) - (let ((alist nnsoup-group-alist) - entry e min max) - (while (setq e (cdr (setq entry (pop alist)))) - (setq min (caaar e)) - (setq max (cdar (car (last e)))) - (setcdr entry (cons (cons min max) (cdr entry))))) - (setq nnsoup-group-alist-touched t)) - nnsoup-group-alist)) - -(defun nnsoup-write-active-file (&optional force) - (when (and nnsoup-group-alist - (or force - nnsoup-group-alist-touched)) - (setq nnsoup-group-alist-touched nil) - (with-temp-file nnsoup-active-file - (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) - (insert "\n") - (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) - (insert "\n")))) - -(defun nnsoup-next-prefix () - "Return the next free prefix." - (let (prefix) - (while (or (file-exists-p - (nnsoup-file (setq prefix (int-to-string - nnsoup-current-prefix)))) - (file-exists-p (nnsoup-file prefix t))) - (incf nnsoup-current-prefix)) - (incf nnsoup-current-prefix) - prefix)) - -(defun nnsoup-file-name (dir file) - "Return the full name of FILE (in any case) in DIR." - (let* ((case-fold-search t) - (files (directory-files dir t)) - (regexp (concat (regexp-quote file) "$"))) - (car (delq nil - (mapcar - (lambda (file) - (if (string-match regexp file) - file - nil)) - files))))) - -(defun nnsoup-read-areas () - (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas"))) - (when areas-file - (save-excursion - (set-buffer nntp-server-buffer) - (let ((areas (gnus-soup-parse-areas areas-file)) - entry number area lnum cur-prefix file) - ;; Go through all areas in the new AREAS file. - (while (setq area (pop areas)) - ;; Change the name to the permanent name and move the files. - (setq cur-prefix (nnsoup-next-prefix)) - (nnheader-message 5 "Incorporating file %s..." cur-prefix) - (when (file-exists-p - (setq file - (expand-file-name - (concat (gnus-soup-area-prefix area) ".IDX") - nnsoup-tmp-directory))) - (rename-file file (nnsoup-file cur-prefix))) - (when (file-exists-p - (setq file (expand-file-name - (concat (gnus-soup-area-prefix area) ".MSG") - nnsoup-tmp-directory))) - (rename-file file (nnsoup-file cur-prefix t)) - (gnus-soup-set-area-prefix area cur-prefix) - ;; Find the number of new articles in this area. - (setq number (nnsoup-number-of-articles area)) - (if (not (setq entry (assoc (gnus-soup-area-name area) - nnsoup-group-alist))) - ;; If this is a new area (group), we just add this info to - ;; the group alist. - (push (list (gnus-soup-area-name area) - (cons 1 number) - (list (cons 1 number) area)) - nnsoup-group-alist) - ;; There are already articles in this group, so we add this - ;; info to the end of the entry. - (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry))) - (+ lnum number)) - area))) - (setcdr (cadr entry) (+ lnum number)))))) - (nnsoup-write-active-file t) - (delete-file areas-file))))) - -(defun nnsoup-number-of-articles (area) - (save-excursion - (cond - ;; If the number is in the area info, we just return it. - ((gnus-soup-area-number area) - (gnus-soup-area-number area)) - ;; If there is an index file, we just count the lines. - ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) - (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) - (count-lines (point-min) (point-max))) - ;; We do it the hard way - re-searching through the message - ;; buffer. - (t - (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) - (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist) - (nnsoup-dissect-buffer area)) - (length (cdr (assoc (gnus-soup-area-prefix area) - nnsoup-article-alist))))))) - -(defun nnsoup-dissect-buffer (area) - (let ((mbox-delim (concat "^" message-unix-mail-delimiter)) - (format (gnus-soup-encoding-format (gnus-soup-area-encoding area))) - (i 0) - alist len) - (goto-char (point-min)) - (cond - ;; rnews batch format - ((or (= format ?u) - (= format ?n)) ;; Gnus back compatibility. - (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$") - (forward-line 1) - (push (list - (incf i) (point) - (progn - (forward-char (string-to-number (match-string 1))) - (point))) - alist))) - ;; Unix mbox format - ((= format ?m) - (while (looking-at mbox-delim) - (forward-line 1) - (push (list - (incf i) (point) - (progn - (if (re-search-forward mbox-delim nil t) - (beginning-of-line) - (goto-char (point-max))) - (point))) - alist))) - ;; MMDF format - ((= format ?M) - (while (looking-at "\^A\^A\^A\^A\n") - (forward-line 1) - (push (list - (incf i) (point) - (progn - (if (search-forward "\n\^A\^A\^A\^A\n" nil t) - (beginning-of-line) - (goto-char (point-max))) - (point))) - alist))) - ;; Binary format - ((or (= format ?B) (= format ?b)) - (while (not (eobp)) - (setq len (+ (* (char-after (point)) (expt 2.0 24)) - (* (char-after (+ (point) 1)) (expt 2 16)) - (* (char-after (+ (point) 2)) (expt 2 8)) - (char-after (+ (point) 3)))) - (push (list - (incf i) (+ (point) 4) - (progn - (forward-char (floor (+ len 4))) - (point))) - alist))) - (t - (error "Unknown format: %c" format))) - (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist))) - -(defun nnsoup-index-buffer (prefix &optional message) - (let* ((file (concat prefix (if message ".MSG" ".IDX"))) - (buffer-name (concat " *nnsoup " file "*"))) - (or (get-buffer buffer-name) ; File already loaded. - (when (file-exists-p (expand-file-name file nnsoup-directory)) - (save-excursion ; Load the file. - (set-buffer (get-buffer-create buffer-name)) - (buffer-disable-undo) - (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) - (nnheader-insert-file-contents - (expand-file-name file nnsoup-directory)) - (current-buffer)))))) - -(defun nnsoup-file (prefix &optional message) - (expand-file-name - (concat prefix (if message ".MSG" ".IDX")) - nnsoup-directory)) - -(defun nnsoup-message-buffer (prefix) - (nnsoup-index-buffer prefix 'msg)) - -(defun nnsoup-unpack-packets () - "Unpack all packets in `nnsoup-packet-directory'." - (let ((packets (directory-files - nnsoup-packet-directory t nnsoup-packet-regexp))) - (dolist (packet packets) - (nnheader-message 5 "nnsoup: unpacking %s..." packet) - (if (not (gnus-soup-unpack-packet - nnsoup-tmp-directory nnsoup-unpacker packet)) - (nnheader-message 5 "Couldn't unpack %s" packet) - (delete-file packet) - (nnsoup-read-areas) - (nnheader-message 5 "Unpacking...done"))))) - -(defun nnsoup-narrow-to-article (article &optional area head) - (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) - (prefix (and area (gnus-soup-area-prefix (nth 1 area)))) - (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg))) - beg end) - (when area - (save-excursion - (cond - ;; There is no MSG file. - ((null msg-buf) - nil) - ;; We use the index file to find out where the article - ;; begins and ends. - ((and (= (gnus-soup-encoding-index - (gnus-soup-area-encoding (nth 1 area))) - ?c) - (file-exists-p (nnsoup-file prefix))) - (set-buffer (nnsoup-index-buffer prefix)) - (widen) - (goto-char (point-min)) - (forward-line (- article (caar area))) - (setq beg (read (current-buffer))) - (forward-line 1) - (if (looking-at "[0-9]+") - (progn - (setq end (read (current-buffer))) - (set-buffer msg-buf) - (widen) - (let ((format (gnus-soup-encoding-format - (gnus-soup-area-encoding (nth 1 area))))) - (goto-char end) - (when (or (= format ?u) (= format ?n) (= format ?m)) - (setq end (progn (forward-line -1) (point)))))) - (set-buffer msg-buf)) - (widen) - (narrow-to-region beg (or end (point-max)))) - (t - (set-buffer msg-buf) - (widen) - (unless (assoc (gnus-soup-area-prefix (nth 1 area)) - nnsoup-article-alist) - (nnsoup-dissect-buffer (nth 1 area))) - (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix - (nth 1 area)) - nnsoup-article-alist))))) - (when entry - (narrow-to-region (cadr entry) (caddr entry)))))) - (goto-char (point-min)) - (if (not head) - () - (narrow-to-region - (point-min) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max)))) - msg-buf)))) - -;;;###autoload -(defun nnsoup-pack-replies () - "Make an outbound package of SOUP replies." - (interactive) - (unless (file-exists-p nnsoup-replies-directory) - (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory)) - ;; Write all data buffers. - (gnus-soup-save-areas) - ;; Write the active file. - (nnsoup-write-active-file) - ;; Write the REPLIES file. - (nnsoup-write-replies) - ;; Check whether there is anything here. - (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$")) - (error "No files to pack")) - ;; Pack all these files into a SOUP packet. - (gnus-soup-pack nnsoup-replies-directory nnsoup-packer)) - -(defun nnsoup-write-replies () - "Write the REPLIES file." - (when nnsoup-replies-list - (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list) - (setq nnsoup-replies-list nil))) - -(defun nnsoup-article-to-area (article group) - "Return the area that ARTICLE in GROUP is located in." - (let ((areas (cddr (assoc group nnsoup-group-alist)))) - (while (and areas (< (cdar (car areas)) article)) - (setq areas (cdr areas))) - (and areas (car areas)))) - -(defvar nnsoup-old-functions - (list message-send-mail-real-function message-send-news-function)) - -;;;###autoload -(defun nnsoup-set-variables () - "Use the SOUP methods for posting news and mailing mail." - (interactive) - (setq message-send-news-function 'nnsoup-request-post) - (setq message-send-mail-real-function 'nnsoup-request-mail)) - -;;;###autoload -(defun nnsoup-revert-variables () - "Revert posting and mailing methods to the standard Emacs methods." - (interactive) - (setq message-send-mail-real-function (car nnsoup-old-functions)) - (setq message-send-news-function (cadr nnsoup-old-functions))) - -(defun nnsoup-store-reply (kind) - ;; Mostly stolen from `message.el'. - (require 'mail-utils) - (let ((tembuf (generate-new-buffer " message temp")) - (case-fold-search nil) - delimline - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - (save-restriction - (message-narrow-to-headers) - (if (equal kind "mail") - (message-generate-headers message-required-mail-headers) - (message-generate-headers message-required-news-headers))) - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring mailbuf) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) - ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (let ((case-fold-search t)) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) - (goto-char (1+ delimline)) - (let ((msg-buf - (gnus-soup-store - nnsoup-replies-directory - (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type - nnsoup-replies-index-type)) - (num 0)) - (when (and msg-buf (bufferp msg-buf)) - (save-excursion - (set-buffer msg-buf) - (goto-char (point-min)) - (while (re-search-forward "^#! *rnews" nil t) - (incf num)) - (when nnsoup-always-save - (save-buffer))) - (nnheader-message 5 "Stored %d messages" num))) - (nnsoup-write-replies) - (kill-buffer tembuf)))))) - -(defun nnsoup-kind-to-prefix (kind) - (unless nnsoup-replies-list - (setq nnsoup-replies-list - (gnus-soup-parse-replies - (expand-file-name "REPLIES" nnsoup-replies-directory)))) - (let ((replies nnsoup-replies-list)) - (while (and replies - (not (string= kind (gnus-soup-reply-kind (car replies))))) - (setq replies (cdr replies))) - (if replies - (gnus-soup-reply-prefix (car replies)) - (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory) - kind - (format "%c%c%c" - nnsoup-replies-format-type - nnsoup-replies-index-type - (if (string= kind "news") - ?n ?m))) - nnsoup-replies-list) - (gnus-soup-reply-prefix (car nnsoup-replies-list))))) - -(defun nnsoup-make-active () - "(Re-)create the SOUP active file." - (interactive) - (let ((files (sort (directory-files nnsoup-directory t "IDX$") - (lambda (f1 f2) - (< (progn (string-match "/\\([0-9]+\\)\\." f1) - (string-to-number (match-string 1 f1))) - (progn (string-match "/\\([0-9]+\\)\\." f2) - (string-to-number (match-string 1 f2))))))) - active group lines ident elem min) - (set-buffer (get-buffer-create " *nnsoup work*")) - (dolist (file files) - (nnheader-message 5 "Doing %s..." file) - (erase-buffer) - (nnheader-insert-file-contents file) - (goto-char (point-min)) - (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t)) - (setq group "unknown") - (setq group (match-string 2))) - (setq lines (count-lines (point-min) (point-max))) - (setq ident (progn (string-match - "/\\([0-9]+\\)\\." file) - (match-string 1 file))) - (if (not (setq elem (assoc group active))) - (push (list group (cons 1 lines) - (list (cons 1 lines) - (vector ident group "ucm" "" lines))) - active) - (nconc elem - (list - (list (cons (1+ (setq min (cdadr elem))) - (+ min lines)) - (vector ident group "ucm" "" lines)))) - (setcdr (cadr elem) (+ min lines)))) - (nnheader-message 5 "") - (setq nnsoup-group-alist active) - (nnsoup-write-active-file t))) - -(defun nnsoup-delete-unreferenced-message-files () - "Delete any *.MSG and *.IDX files that aren't known by nnsoup." - (interactive) - (let* ((known (apply 'nconc (mapcar - (lambda (ga) - (mapcar - (lambda (area) - (gnus-soup-area-prefix (cadr area))) - (cddr ga))) - nnsoup-group-alist))) - (regexp "\\.MSG$\\|\\.IDX$") - (files (directory-files nnsoup-directory nil regexp)) - non-files) - ;; Find all files that aren't known by nnsoup. - (dolist (file files) - (string-match regexp file) - (unless (member (substring file 0 (match-beginning 0)) known) - (push file non-files))) - ;; Sort and delete the files. - (setq non-files (sort non-files 'string<)) - (map-y-or-n-p "Delete file %s? " - (lambda (file) (delete-file - (expand-file-name file nnsoup-directory))) - non-files))) - -(provide 'nnsoup) - -;; arch-tag: b0451389-5703-4450-9425-f66f6b38c828 -;;; nnsoup.el ends here diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index a92c336c79..ecc28723ce 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -109,8 +109,7 @@ there.") (deffoo nnspool-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (when (nnspool-possibly-change-directory group) (let* ((number (length articles)) @@ -209,8 +208,7 @@ there.") (nnspool-possibly-change-directory group) (let ((res (nnspool-request-article id))) (when res - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (point-min) (point))) @@ -221,15 +219,14 @@ there.") (nnspool-possibly-change-directory group) (let ((res (nnspool-request-article id))) (when res - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (1- (point)) (point-max))) (nnheader-fold-continuation-lines))) res)) -(deffoo nnspool-request-group (group &optional server dont-check) +(deffoo nnspool-request-group (group &optional server dont-check info) "Select news GROUP." (let ((pathname (nnspool-article-pathname group)) dir) @@ -343,8 +340,7 @@ there.") ;;; Internal functions. (defun nnspool-inews-sentinel (proc status) - (save-excursion - (set-buffer (process-buffer proc)) + (with-current-buffer (process-buffer proc) (goto-char (point-min)) (if (or (zerop (buffer-size)) (search-forward "spooled" nil t)) @@ -367,8 +363,7 @@ there.") last) (if (not (file-exists-p nov)) () - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (if nnspool-sift-nov-with-sed (nnspool-sift-nov-with-sed articles nov) @@ -404,15 +399,16 @@ there.") "Read the head of ARTICLE, convert to NOV headers, and insert." (save-excursion (let ((cur (current-buffer)) - buf) + buf) (setq buf (nnheader-set-temp-buffer " *nnspool head*")) (when (nnheader-insert-head - (nnspool-article-pathname nnspool-current-group article)) - (nnheader-insert-article-line article) - (let ((headers (nnheader-parse-head))) - (set-buffer cur) - (goto-char (point-max)) - (nnheader-insert-nov headers))) + (nnspool-article-pathname nnspool-current-group article)) + (nnheader-insert-article-line article) + (goto-char (point-min)) + (let ((headers (nnheader-parse-head))) + (set-buffer cur) + (goto-char (point-max)) + (nnheader-insert-nov headers))) (kill-buffer buf)))) (defun nnspool-sift-nov-with-sed (articles file) @@ -458,5 +454,4 @@ there.") (provide 'nnspool) -;; arch-tag: bdac8d27-2934-4eee-bad0-49e6b90c0d05 ;;; nnspool.el ends here diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index e09b1af3ab..685c32504d 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -26,10 +26,15 @@ ;;; Code: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'nnheader) (require 'nnoo) (require 'gnus-util) (require 'gnus) +(require 'proto-stream) (require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) @@ -82,6 +87,8 @@ host. Direct connections: - `nntp-open-network-stream' (the default), +- `network-only' (the same as the above, but don't do automatic + STARTTLS upgrades). - `nntp-open-ssl-stream', - `nntp-open-tls-stream', - `nntp-open-netcat-stream'. @@ -263,6 +270,11 @@ NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.") "*Hook run just before posting an article. It is supposed to be used to insert Cancel-Lock headers.") +(defvoo nntp-server-list-active-group 'try + "If nil, then always use GROUP instead of LIST ACTIVE. +This is usually slower, but on misconfigured servers that don't +update their active files often, this can help.") + ;;; Internal variables. (defvar nntp-record-commands nil @@ -292,28 +304,13 @@ to insert Cancel-Lock headers.") (defvoo nntp-inhibit-output nil) (defvoo nntp-server-xover 'try) -(defvoo nntp-server-list-active-group 'try) - -(defvar nntp-async-needs-kluge - (string-match "^GNU Emacs 20\\.3\\." (emacs-version)) - "*When non-nil, nntp will poll asynchronous connections -once a second. By default, this is turned on only for Emacs -20.3, which has a bug that breaks nntp's normal method of -noticing asynchronous data.") (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 +"A custom error condition used to report 'Authentication Rejected' errors. +Condition handlers that match just this condition ensure that the nntp backend doesn't catch this error.") (put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected)) (put 'nntp-authinfo-rejected 'error-message "Authorization Rejected") @@ -403,7 +400,8 @@ be restored and the command retried." (cond ((looking-at "480") (nntp-handle-authinfo process)) ((looking-at "482") - (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message)) + (nnheader-report 'nntp "%s" + (get 'nntp-authinfo-rejected 'error-message)) (signal 'nntp-authinfo-rejected nil)) ((looking-at "^.*\n") (delete-region (point) (progn (forward-line 1) (point))))) @@ -990,7 +988,7 @@ command whose response triggered the error." "\r?\n\\.\r?\n" "BODY" (if (numberp article) (int-to-string article) article)))) -(deffoo nntp-request-group (group &optional server dont-check) +(deffoo nntp-request-group (group &optional server dont-check info) (nntp-with-open-group nil server (when (nntp-send-command "^[245].*\n" "GROUP" group) @@ -1017,7 +1015,8 @@ command whose response triggered the error." (unless (assq 'nntp-address defs) (setq defs (append defs (list (list 'nntp-address server))))) (nnoo-change-server 'nntp server defs) - (unless connectionless + (if connectionless + t (or (nntp-find-connection nntp-server-buffer) (nntp-open-connection nntp-server-buffer))))) @@ -1112,27 +1111,17 @@ command whose response triggered the error." t) (deffoo nntp-request-set-mark (group actions &optional server) - (unless nntp-marks-is-evil + (when (and (not nntp-marks-is-evil) + nntp-marks-file-name) (nntp-possibly-create-directory group server) (nntp-open-marks group server) - (dolist (action actions) - (let ((range (nth 0 action)) - (what (nth 1 action)) - (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) nil - "Unknown request-set-mark action: %s" what) - (dolist (mark marks) - (setq nntp-marks (gnus-update-alist-soft - mark - (funcall (if (eq what 'add) 'gnus-range-add - 'gnus-remove-from-range) - (cdr (assoc mark nntp-marks)) range) - nntp-marks))))) + (setq nntp-marks (nnheader-update-marks-actions nntp-marks actions)) (nntp-save-marks group server)) nil) -(deffoo nntp-request-update-info (group info &optional server) - (unless nntp-marks-is-evil +(deffoo nntp-request-marks (group info &optional server) + (when (and (not nntp-marks-is-evil) + nntp-marks-file-name) (nntp-possibly-create-directory group server) (when (nntp-marks-changed-p group server) (nnheader-message 8 "Updating marks for %s..." group) @@ -1168,6 +1157,11 @@ It will make innd servers spawn an nnrpd process to allow actual article reading." (nntp-send-command "^.*\n" "MODE READER")) +(declare-function netrc-parse "netrc" (&optional file)) +(declare-function netrc-machine "netrc" + (list machine &optional port defaultport)) +(declare-function netrc-get "netrc" (alist type)) + (defun nntp-send-authinfo (&optional send-if-force) "Send the AUTHINFO to the nntp server. It will look in the \"~/.authinfo\" file for matching entries. If @@ -1176,10 +1170,11 @@ and a password. If SEND-IF-FORCE, only send authinfo to the server if the .authinfo file has the FORCE token." + (require 'netrc) (let* ((list (netrc-parse nntp-authinfo-file)) (alist (netrc-machine list nntp-address "nntp")) (force (or (netrc-get alist "force") nntp-authinfo-force)) - (auth-info + (auth-info (auth-source-user-or-password '("login" "password") nntp-address "nntp")) (auth-user (nth 0 auth-info)) (auth-passwd (nth 1 auth-info)) @@ -1270,11 +1265,29 @@ password contained in '~/.nntp-authinfo'." `(lambda () (nntp-kill-buffer ,pbuffer))))) (process - (condition-case () + (condition-case err (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write)) - (funcall nntp-open-connection-function pbuffer)) - (error nil) + (coding-system-for-write nntp-coding-system-for-write) + (map '((nntp-open-network-stream network) + (network-only network-only) + (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) @@ -1302,40 +1315,6 @@ password contained in '~/.nntp-authinfo'." (nntp-kill-buffer (process-buffer process)) nil)))) -(defun nntp-open-network-stream (buffer) - (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) - -(autoload 'format-spec "format-spec") -(autoload 'format-spec-make "format-spec") -(autoload 'open-tls-stream "tls") - -(defun nntp-open-ssl-stream (buffer) - (let* ((process-connection-type nil) - (proc (start-process "nntpd" buffer - shell-file-name - shell-command-switch - (format-spec nntp-ssl-program - (format-spec-make - ?s nntp-address - ?p nntp-port-number))))) - (gnus-set-process-query-on-exit-flag proc nil) - (with-current-buffer buffer - (let ((nntp-connection-alist (list proc buffer nil))) - (nntp-wait-for-string "^\r*20[01]")) - (beginning-of-line) - (delete-region (point-min) (point)) - proc))) - -(defun nntp-open-tls-stream (buffer) - (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number))) - (gnus-set-process-query-on-exit-flag proc nil) - (with-current-buffer buffer - (let ((nntp-connection-alist (list proc buffer nil))) - (nntp-wait-for-string "^\r*20[01]")) - (beginning-of-line) - (delete-region (point-min) (point)) - proc))) - (defun nntp-read-server-type () "Find out what the name of the server we have connected to is." ;; Wait for the status string to arrive. @@ -1358,17 +1337,7 @@ password contained in '~/.nntp-authinfo'." nntp-process-decode decode nntp-process-callback callback nntp-process-start-point (point-max)) - (setq after-change-functions '(nntp-after-change-function)) - (if nntp-async-needs-kluge - (nntp-async-kluge process)))) - -(defun nntp-async-kluge (process) - ;; emacs 20.3 bug: process output with encoding 'binary - ;; doesn't trigger after-change-functions. - (unless nntp-async-timer - (setq nntp-async-timer - (run-at-time 1 1 'nntp-async-timer-handler))) - (add-to-list 'nntp-async-process-list process)) + (setq after-change-functions '(nntp-after-change-function)))) (defun nntp-async-timer-handler () (mapcar @@ -1446,7 +1415,7 @@ password contained in '~/.nntp-authinfo'." (let ((message (buffer-string))) (while (string-match "[\r\n]+" message) (setq message (replace-match " " t t message))) - (nnheader-report 'nntp message) + (nnheader-report 'nntp "%s" message) message)) (defun nntp-accept-process-output (process) @@ -1773,7 +1742,7 @@ password contained in '~/.nntp-authinfo'." (while (and (setq proc (get-buffer-process buf)) (memq (process-status proc) '(open run)) (not (re-search-forward regexp nil t))) - (accept-process-output proc) + (accept-process-output proc 0.1) (set-buffer buf) (goto-char (point-min))))) @@ -2018,7 +1987,7 @@ Please refer to the following variables to customize the connection: (and nntp-pre-command (push nntp-pre-command command)) (let ((process-connection-type nil)) ;See `nntp-open-via-rlogin-and-netcat'. (apply 'start-process "nntpd" buffer command)))) - + (defun nntp-open-via-telnet-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. @@ -2185,5 +2154,4 @@ Please refer to the following variables to customize the connection: (provide 'nntp) -;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271 ;;; nntp.el ends here diff --git a/lisp/gnus/nnultimate.el b/lisp/gnus/nnultimate.el deleted file mode 100644 index f446697462..0000000000 --- a/lisp/gnus/nnultimate.el +++ /dev/null @@ -1,480 +0,0 @@ -;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board system - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Note: You need to have `url' and `w3' installed for this -;; backend to work. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) -(require 'nnweb) -(require 'parse-time) -(autoload 'w3-parse-buffer "w3-parse") - -(nnoo-declare nnultimate) - -(defvoo nnultimate-directory (nnheader-concat gnus-directory "ultimate/") - "Where nnultimate will save its files.") - -(defvoo nnultimate-address "" - "The address of the Ultimate bulletin board.") - -;;; Internal variables - -(defvar nnultimate-groups-alist nil) -(defvoo nnultimate-groups nil) -(defvoo nnultimate-headers nil) -(defvoo nnultimate-articles nil) -(defvar nnultimate-table-regexp - "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") - -;;; Interface functions - -(nnoo-define-basics nnultimate) - -(deffoo nnultimate-retrieve-headers (articles &optional group server fetch-old) - (nnultimate-possibly-change-server group server) - (unless gnus-nov-is-evil - (let* ((last (car (last articles))) - (did nil) - (start 1) - (entry (assoc group nnultimate-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (furl "forumdisplay.cgi?action=topics&number=%d&DaysPrune=1000") - (furls (list (concat nnultimate-address (format furl sid)))) - (nnultimate-table-regexp - "postings.*editpost\\|forumdisplay\\|getbio") - headers article subject score from date lines parent point - contents tinfo fetchers map elem a href garticles topic old-max - inc datel table current-page total-contents pages - farticles forum-contents parse furl-fetched mmap farticle) - (setq map mapping) - (while (and (setq article (car articles)) - map) - ;; Skip past the articles in the map until we reach the - ;; article we're looking for. - (while (and map - (or (> article (caar map)) - (< (cadar map) (caar map)))) - (pop map)) - (when (setq mmap (car map)) - (setq farticle -1) - (while (and article - (<= article (nth 1 mmap))) - ;; Do we already have a fetcher for this topic? - (if (setq elem (assq (nth 2 mmap) fetchers)) - ;; Yes, so we just add the spec to the end. - (nconc elem (list (cons article - (+ (nth 3 mmap) (incf farticle))))) - ;; No, so we add a new one. - (push (list (nth 2 mmap) - (cons article - (+ (nth 3 mmap) (incf farticle)))) - fetchers)) - (pop articles) - (setq article (car articles))))) - ;; Now we have the mapping from/to Gnus/nnultimate article numbers, - ;; so we start fetching the topics that we need to satisfy the - ;; request. - (if (not fetchers) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) - (setq nnultimate-articles nil) - (mm-with-unibyte-buffer - (dolist (elem fetchers) - (setq pages 1 - current-page 1 - total-contents nil) - (while (<= current-page pages) - (erase-buffer) - (setq subject (nth 2 (assq (car elem) topics))) - (setq href (nth 3 (assq (car elem) topics))) - (if (= current-page 1) - (mm-url-insert href) - (string-match "\\.html$" href) - (mm-url-insert (concat (substring href 0 (match-beginning 0)) - "-" (number-to-string current-page) - (match-string 0 href)))) - (goto-char (point-min)) - (setq contents - (ignore-errors (w3-parse-buffer (current-buffer)))) - (setq table (nnultimate-find-forum-table contents)) - (goto-char (point-min)) - (when (re-search-forward "topic is \\([0-9]+\\) pages" nil t) - (setq pages (string-to-number (match-string 1)))) - (setq contents (cdr (nth 2 (car (nth 2 table))))) - (setq total-contents (nconc total-contents contents)) - (incf current-page)) - (when t - (let ((i 0)) - (dolist (co total-contents) - (push (list (or (nnultimate-topic-article-to-article - group (car elem) (incf i)) - 1) - co subject) - nnultimate-articles)))) - (when nil - (dolist (art (cdr elem)) - (when (nth (1- (cdr art)) total-contents) - (push (list (car art) - (nth (1- (cdr art)) total-contents) - subject) - nnultimate-articles)))))) - (setq nnultimate-articles - (sort nnultimate-articles 'car-less-than-car)) - ;; Now we have all the articles, conveniently in an alist - ;; where the key is the Gnus article number. - (dolist (articlef nnultimate-articles) - (setq article (nth 0 articlef) - contents (nth 1 articlef) - subject (nth 2 articlef)) - (setq from (mapconcat 'identity - (nnweb-text (car (nth 2 contents))) - " ") - datel (nnweb-text (nth 2 (car (cdr (nth 2 contents)))))) - (while datel - (when (string-match "Posted" (car datel)) - (setq date (substring (car datel) (match-end 0)) - datel nil)) - (pop datel)) - (when date - (setq date (delete "" (split-string date "[-, \n\t\r ���]"))) - (setq date - (if (or (member "AM" date) - (member "PM" date)) - (format - "%s %s %s %s" - (nth 1 date) - (if (and (>= (length (nth 0 date)) 3) - (assoc (downcase - (substring (nth 0 date) 0 3)) - parse-time-months)) - (substring (nth 0 date) 0 3) - (car (rassq (string-to-number (nth 0 date)) - parse-time-months))) - (nth 2 date) (nth 3 date)) - (format "%s %s %s %s" - (car (rassq (string-to-number (nth 1 date)) - parse-time-months)) - (nth 0 date) (nth 2 date) (nth 3 date))))) - (push - (cons - article - (make-full-mail-header - article subject - from (or date "") - (concat "<" (number-to-string sid) "%" - (number-to-string article) - "@ultimate." server ">") - "" 0 - (/ (length (mapconcat - 'identity - (nnweb-text - (cdr (nth 2 (nth 1 (nth 2 contents))))) - "")) - 70) - nil nil)) - headers)) - (setq nnultimate-headers (sort headers 'car-less-than-car)) - (save-excursion - (set-buffer nntp-server-buffer) - (mm-with-unibyte-current-buffer - (erase-buffer) - (dolist (header nnultimate-headers) - (nnheader-insert-nov (cdr header)))))) - 'nov))) - -(defun nnultimate-topic-article-to-article (group topic article) - (catch 'found - (dolist (elem (nth 5 (assoc group nnultimate-groups))) - (when (and (= topic (nth 2 elem)) - (>= article (nth 3 elem)) - (< article (+ (- (nth 1 elem) (nth 0 elem)) 1 - (nth 3 elem)))) - (throw 'found - (+ (nth 0 elem) (- article (nth 3 elem)))))))) - -(deffoo nnultimate-request-group (group &optional server dont-check) - (nnultimate-possibly-change-server nil server) - (when (not nnultimate-groups) - (nnultimate-request-list)) - (unless dont-check - (nnultimate-create-mapping group)) - (let ((elem (assoc group nnultimate-groups))) - (cond - ((not elem) - (nnheader-report 'nnultimate "Group does not exist")) - (t - (nnheader-report 'nnultimate "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) - (prin1-to-string group)))))) - -(deffoo nnultimate-request-close () - (setq nnultimate-groups-alist nil - nnultimate-groups nil)) - -(deffoo nnultimate-request-article (article &optional group server buffer) - (nnultimate-possibly-change-server group server) - (let ((contents (cdr (assq article nnultimate-articles)))) - (setq contents (cddr (nth 2 (nth 1 (nth 2 (car contents)))))) - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (nnweb-insert-html (cons 'p (cons nil (list contents)))) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (let ((header (cdr (assq article nnultimate-headers)))) - (mm-with-unibyte-current-buffer - (nnheader-insert-header header))) - (nnheader-report 'nnultimate "Fetched article %s" article) - (cons group article))))) - -(deffoo nnultimate-request-list (&optional server) - (nnultimate-possibly-change-server nil server) - (mm-with-unibyte-buffer - (mm-url-insert - (if (string-match "/$" nnultimate-address) - (concat nnultimate-address "Ultimate.cgi") - nnultimate-address)) - (let ((contents (nth 2 (car (nth 2 - (nnultimate-find-forum-table - (w3-parse-buffer (current-buffer))))))) - sid elem description articles a href group forum - a1 a2) - (dolist (row contents) - (setq row (nth 2 row)) - (when (setq a (nnweb-parse-find 'a row)) - (setq group (car (last (nnweb-text a))) - href (cdr (assq 'href (nth 1 a)))) - (setq description (car (last (nnweb-text (nth 1 row))))) - (setq a1 (car (last (nnweb-text (nth 2 row))))) - (setq a2 (car (last (nnweb-text (nth 3 row))))) - (when (string-match "^[0-9]+$" a1) - (setq articles (string-to-number a1))) - (when (and a2 (string-match "^[0-9]+$" a2)) - (setq articles (max articles (string-to-number a2)))) - (when href - (string-match "number=\\([0-9]+\\)" href) - (setq forum (string-to-number (match-string 1 href))) - (if (setq elem (assoc group nnultimate-groups)) - (setcar (cdr elem) articles) - (push (list group articles forum description nil nil nil nil) - nnultimate-groups)))))) - (nnultimate-write-groups) - (nnultimate-generate-active) - t)) - -(deffoo nnultimate-request-newgroups (date &optional server) - (nnultimate-possibly-change-server nil server) - (nnultimate-generate-active) - t) - -(nnoo-define-skeleton nnultimate) - -;;; Internal functions - -(defun nnultimate-prune-days (group time) - "Compute the number of days to fetch info for." - (let ((old-time (nth 7 (assoc group nnultimate-groups)))) - (if (null old-time) - 1000 - (- (time-to-days time) (time-to-days old-time))))) - -(defun nnultimate-create-mapping (group) - (let* ((entry (assoc group nnultimate-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (current-time (current-time)) - (furl - (concat "forumdisplay.cgi?action=topics&number=%d&DaysPrune=" - (number-to-string - (nnultimate-prune-days group current-time)))) - (furls (list (concat nnultimate-address (format furl sid)))) - contents forum-contents furl-fetched a subject href - garticles topic tinfo old-max inc parse) - (mm-with-unibyte-buffer - (while furls - (erase-buffer) - (mm-url-insert (pop furls)) - (goto-char (point-min)) - (setq parse (w3-parse-buffer (current-buffer))) - (setq contents - (cdr (nth 2 (car (nth 2 (nnultimate-find-forum-table - parse)))))) - (setq forum-contents (nconc contents forum-contents)) - (unless furl-fetched - (setq furl-fetched t) - ;; On the first time through this loop, we find all the - ;; forum URLs. - (dolist (a (nnweb-parse-find-all 'a parse)) - (let ((href (cdr (assq 'href (nth 1 a))))) - (when (and href - (string-match "forumdisplay.*startpoint" href)) - (push href furls)))) - (setq furls (nreverse furls)))) - ;; The main idea here is to map Gnus article numbers to - ;; nnultimate article numbers. Say there are three topics in - ;; this forum, the first with 4 articles, the seconds with 2, - ;; and the third with 1. Then this will translate into 7 Gnus - ;; article numbers, where 1-4 comes from the first topic, 5-6 - ;; from the second and 7 from the third. Now, then next time - ;; the group is entered, there's 2 new articles in topic one - ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 - ;; in topic one and 10 will be the 2 in topic three. - (dolist (row (nreverse forum-contents)) - (setq row (nth 2 row)) - (when (setq a (nnweb-parse-find 'a row)) - (setq subject (car (last (nnweb-text a))) - href (cdr (assq 'href (nth 1 a)))) - (let ((artlist (nreverse (nnweb-text row))) - art) - (while (and (not art) - artlist) - (when (string-match "^[0-9]+$" (car artlist)) - (setq art (1+ (string-to-number (car artlist))))) - (pop artlist)) - (setq garticles art)) - (when garticles - (string-match "/\\([0-9]+\\).html" href) - (setq topic (string-to-number (match-string 1 href))) - (if (setq tinfo (assq topic topics)) - (progn - (setq old-max (cadr tinfo)) - (setcar (cdr tinfo) garticles)) - (setq old-max 0) - (push (list topic garticles subject href) topics) - (setcar (nthcdr 4 entry) topics)) - (when (not (= old-max garticles)) - (setq inc (- garticles old-max)) - (setq mapping (nconc mapping - (list - (list - old-total (1- (incf old-total inc)) - topic (1+ old-max))))) - (incf old-max inc) - (setcar (nthcdr 5 entry) mapping) - (setcar (nthcdr 6 entry) old-total)))))) - (setcar (nthcdr 7 entry) current-time) - (setcar (nthcdr 1 entry) (1- old-total)) - (nnultimate-write-groups) - mapping)) - -(defun nnultimate-possibly-change-server (&optional group server) - (nnultimate-init server) - (when (and server - (not (nnultimate-server-opened server))) - (nnultimate-open-server server)) - (unless nnultimate-groups-alist - (nnultimate-read-groups) - (setq nnultimate-groups (cdr (assoc nnultimate-address - nnultimate-groups-alist))))) - -(deffoo nnultimate-open-server (server &optional defs connectionless) - (nnheader-init-server-buffer) - (if (nnultimate-server-opened server) - t - (unless (assq 'nnultimate-address defs) - (setq defs (append defs (list (list 'nnultimate-address server))))) - (nnoo-change-server 'nnultimate server defs))) - -(defun nnultimate-read-groups () - (setq nnultimate-groups-alist nil) - (let ((file (expand-file-name "groups" nnultimate-directory))) - (when (file-exists-p file) - (mm-with-unibyte-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnultimate-groups-alist (read (current-buffer))))))) - -(defun nnultimate-write-groups () - (setq nnultimate-groups-alist - (delq (assoc nnultimate-address nnultimate-groups-alist) - nnultimate-groups-alist)) - (push (cons nnultimate-address nnultimate-groups) - nnultimate-groups-alist) - (with-temp-file (expand-file-name "groups" nnultimate-directory) - (prin1 nnultimate-groups-alist (current-buffer)))) - -(defun nnultimate-init (server) - "Initialize buffers and such." - (unless (file-exists-p nnultimate-directory) - (gnus-make-directory nnultimate-directory))) - -(defun nnultimate-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnultimate-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n")))) - -(defun nnultimate-find-forum-table (contents) - (catch 'found - (nnultimate-find-forum-table-1 contents))) - -(defun nnultimate-find-forum-table-1 (contents) - (dolist (element contents) - (unless (stringp element) - (when (and (eq (car element) 'table) - (nnultimate-forum-table-p element)) - (throw 'found element)) - (when (nth 2 element) - (nnultimate-find-forum-table-1 (nth 2 element)))))) - -(defun nnultimate-forum-table-p (parse) - (when (not (apply 'gnus-or - (mapcar - (lambda (p) - (nnweb-parse-find 'table p)) - (nth 2 parse)))) - (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) - case-fold-search) - (when (and href (string-match nnultimate-table-regexp href)) - t)))) - -(provide 'nnultimate) - -;; Local Variables: -;; coding: iso-8859-1 -;; End: - -;; arch-tag: ab6bfc45-8fe1-4647-9c78-41050eb152b8 -;;; nnultimate.el ends here diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 0b22314273..4cb22c4ed8 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -93,8 +93,7 @@ component group will show up when you enter the virtual group.") (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup server fetch-old) (when (nnvirtual-possibly-change-server server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (if (stringp (car articles)) 'headers @@ -170,8 +169,7 @@ component group will show up when you enter the virtual group.") ;; the nntp-server-buffer, which is where Gnus expects to find ;; them. (prog1 - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (insert-buffer-substring vbuf) ;; FIX FIX FIX, we should be able to sort faster than @@ -215,8 +213,7 @@ component group will show up when you enter the virtual group.") (t (setq nnvirtual-last-accessed-component-group cgroup) (if buffer - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer ;; We bind this here to avoid double decoding. (let ((gnus-article-decode-hook nil)) (gnus-request-article-this-buffer (cdr amap) cgroup))) @@ -250,7 +247,7 @@ component group will show up when you enter the virtual group.") t))) -(deffoo nnvirtual-request-group (group &optional server dont-check) +(deffoo nnvirtual-request-group (group &optional server dont-check info) (nnvirtual-possibly-change-server server) (setq nnvirtual-component-groups (delete (nnvirtual-current-group) nnvirtual-component-groups)) @@ -260,13 +257,11 @@ component group will show up when you enter the virtual group.") (nnheader-report 'nnvirtual "No component groups in %s" group)) (t (setq nnvirtual-current-group group) - (when (or (not dont-check) - nnvirtual-always-rescan) - (nnvirtual-create-mapping) - (when nnvirtual-always-rescan - (nnvirtual-request-update-info - (nnvirtual-current-group) - (gnus-get-info (nnvirtual-current-group))))) + (nnvirtual-create-mapping dont-check) + (when nnvirtual-always-rescan + (nnvirtual-request-update-info + (nnvirtual-current-group) + (gnus-get-info (nnvirtual-current-group)))) (nnheader-insert "211 %d 1 %d %s\n" nnvirtual-mapping-len nnvirtual-mapping-len group)))) @@ -300,10 +295,6 @@ component group will show up when you enter the virtual group.") t) -(deffoo nnvirtual-request-list (&optional server) - (nnheader-report 'nnvirtual "LIST is not implemented.")) - - (deffoo nnvirtual-request-newgroups (date &optional server) (nnheader-report 'nnvirtual "NEWGROUPS is not supported.")) @@ -341,8 +332,7 @@ component group will show up when you enter the virtual group.") (when (not (numberp (gnus-group-unread g))) (gnus-activate-group g))) nnvirtual-component-groups) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-group-catchup-current nil all))))) @@ -674,7 +664,7 @@ the result." carticles)) -(defun nnvirtual-create-mapping () +(defun nnvirtual-create-mapping (dont-check) "Build the tables necessary to map between component (group, article) to virtual article. Generate the set of read messages and marks for the virtual group based on the marks on the component groups." @@ -693,7 +683,9 @@ based on the marks on the component groups." ;; Into all-marks we put (g marks). ;; We also increment cnt and tot here, and compute M (max of sizes). (mapc (lambda (g) - (setq active (gnus-activate-group g) + (setq active (or (and dont-check + (gnus-active g)) + (gnus-activate-group g)) min (car active) max (cdr active)) (when (and active (>= max min) (not (zerop max))) @@ -809,5 +801,4 @@ based on the marks on the component groups." (provide 'nnvirtual) -;; arch-tag: ca8c8ad9-1bd8-4b0f-9722-90dc645a45f5 ;;; nnvirtual.el ends here diff --git a/lisp/gnus/nnwarchive.el b/lisp/gnus/nnwarchive.el deleted file mode 100644 index 1c6bc42b4e..0000000000 --- a/lisp/gnus/nnwarchive.el +++ /dev/null @@ -1,727 +0,0 @@ -;;; nnwarchive.el --- interfacing with web archives - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Shenghuo Zhu <[email protected]> -;; Keywords: news egroups mail-archive - -;; 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 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Note: You need to have `url' (w3 0.46) or greater version -;; installed for some functions of this backend to work. - -;; Todo: -;; 1. To support more web archives. -;; 2. Generalize webmail to other MHonArc archive. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'gnus-bcklg) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) - -(nnoo-declare nnwarchive) - -(defvar nnwarchive-type-definition - '((egroups - (address . "www.egroups.com") - (open-url - "http://www.egroups.com/login.cgi?&login_email=%s&login_password=%s" - nnwarchive-login nnwarchive-passwd) - (list-url - "http://www.egroups.com/mygroups") - (list-dissect . nnwarchive-egroups-list) - (list-groups . nnwarchive-egroups-list-groups) - (xover-url - "http://www.egroups.com/messages/%s/%d" group aux) - (xover-last-url - "http://www.egroups.com/messages/%s/" group) - (xover-page-size . 13) - (xover-dissect . nnwarchive-egroups-xover) - (article-url - "http://www.egroups.com/message/%s/%d?source=1" group article) - (article-dissect . nnwarchive-egroups-article) - (authentication . t) - (article-offset . 0) - (xover-files . nnwarchive-egroups-xover-files)) - (mail-archive - (address . "www.mail-archive.com") - (open-url) - (list-url - "http://www.mail-archive.com/lists.html") - (list-dissect . nnwarchive-mail-archive-list) - (list-groups . nnwarchive-mail-archive-list-groups) - (xover-url - "http://www.mail-archive.com/%s/mail%d.html" group aux) - (xover-last-url - "http://www.mail-archive.com/%s/maillist.html" group) - (xover-page-size) - (xover-dissect . nnwarchive-mail-archive-xover) - (article-url - "http://www.mail-archive.com/%s/msg%05d.html" group article1) - (article-dissect . nnwarchive-mail-archive-article) - (xover-files . nnwarchive-mail-archive-xover-files) - (authentication) - (article-offset . 1)))) - -(defvar nnwarchive-default-type 'egroups) - -(defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/") - "Where nnwarchive will save its files.") - -(defvoo nnwarchive-type nil - "The type of nnwarchive.") - -(defvoo nnwarchive-address "" - "The address of nnwarchive.") - -(defvoo nnwarchive-login nil - "Your login name for the group.") - -(defvoo nnwarchive-passwd nil - "Your password for the group.") - -(defvoo nnwarchive-groups nil) - -(defvoo nnwarchive-headers-cache nil) - -(defvoo nnwarchive-authentication nil) - -(defvoo nnwarchive-nov-is-evil nil) - -(defconst nnwarchive-version "nnwarchive 1.0") - -;;; Internal variables - -(defvoo nnwarchive-open-url nil) -(defvoo nnwarchive-open-dissect nil) - -(defvoo nnwarchive-list-url nil) -(defvoo nnwarchive-list-dissect nil) -(defvoo nnwarchive-list-groups nil) - -(defvoo nnwarchive-xover-files nil) -(defvoo nnwarchive-xover-url nil) -(defvoo nnwarchive-xover-last-url nil) -(defvoo nnwarchive-xover-dissect nil) -(defvoo nnwarchive-xover-page-size nil) - -(defvoo nnwarchive-article-url nil) -(defvoo nnwarchive-article-dissect nil) -(defvoo nnwarchive-xover-files nil) -(defvoo nnwarchive-article-offset 0) - -(defvoo nnwarchive-buffer nil) - -(defvoo nnwarchive-keep-backlog 300) -(defvar nnwarchive-backlog-articles nil) -(defvar nnwarchive-backlog-hashtb nil) - -(defvoo nnwarchive-headers nil) - - -;;; Interface functions - -(nnoo-define-basics nnwarchive) - -(defun nnwarchive-set-default (type) - (let ((defs (cdr (assq type nnwarchive-type-definition))) - def) - (dolist (def defs) - (set (intern (concat "nnwarchive-" (symbol-name (car def)))) - (cdr def))))) - -(defmacro nnwarchive-backlog (&rest form) - `(let ((gnus-keep-backlog nnwarchive-keep-backlog) - (gnus-backlog-buffer - (format " *nnwarchive backlog %s*" nnwarchive-address)) - (gnus-backlog-articles nnwarchive-backlog-articles) - (gnus-backlog-hashtb nnwarchive-backlog-hashtb)) - (unwind-protect - (progn ,@form) - (setq nnwarchive-backlog-articles gnus-backlog-articles - nnwarchive-backlog-hashtb gnus-backlog-hashtb)))) -(put 'nnwarchive-backlog 'lisp-indent-function 0) -(put 'nnwarchive-backlog 'edebug-form-spec '(form body)) - -(defun nnwarchive-backlog-enter-article (group number buffer) - (nnwarchive-backlog - (gnus-backlog-enter-article group number buffer))) - -(defun nnwarchive-get-article (article &optional group server buffer) - (if (numberp article) - (if (nnwarchive-backlog - (gnus-backlog-request-article group article - (or buffer nntp-server-buffer))) - (cons group article) - (let (contents) - (save-excursion - (set-buffer nnwarchive-buffer) - (goto-char (point-min)) - (let ((article1 (- article nnwarchive-article-offset))) - (nnwarchive-url nnwarchive-article-url)) - (setq contents (funcall nnwarchive-article-dissect group article))) - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (insert contents) - (nnwarchive-backlog-enter-article group article (current-buffer)) - (nnheader-report 'nnwarchive "Fetched article %s" article) - (cons group article))))) - nil)) - -(deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old) - (nnwarchive-possibly-change-server group server) - (if (or gnus-nov-is-evil nnwarchive-nov-is-evil) - (with-temp-buffer - (with-current-buffer nntp-server-buffer - (erase-buffer)) - (let ((buf (current-buffer)) b e) - (dolist (art articles) - (nnwarchive-get-article art group server buf) - (setq b (goto-char (point-min))) - (if (search-forward "\n\n" nil t) - (forward-char -1) - (goto-char (point-max))) - (setq e (point)) - (with-current-buffer nntp-server-buffer - (insert (format "221 %d Article retrieved.\n" art)) - (insert-buffer-substring buf b e) - (insert ".\n")))) - 'headers) - (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (funcall nnwarchive-xover-files group articles)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let (header) - (dolist (art articles) - (if (setq header (assq art nnwarchive-headers)) - (nnheader-insert-nov (cdr header)))))) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) nnwarchive-headers-cache))) - 'nov)) - -(deffoo nnwarchive-request-group (group &optional server dont-check) - (nnwarchive-possibly-change-server nil server) - (when (and (not dont-check) nnwarchive-list-groups) - (funcall nnwarchive-list-groups (list group)) - (nnwarchive-write-groups)) - (let ((elem (assoc group nnwarchive-groups))) - (cond - ((not elem) - (nnheader-report 'nnwarchive "Group does not exist")) - (t - (nnheader-report 'nnwarchive "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0) - (prin1-to-string group)) - t)))) - -(deffoo nnwarchive-request-article (article &optional group server buffer) - (nnwarchive-possibly-change-server group server) - (nnwarchive-get-article article group server buffer)) - -(deffoo nnwarchive-close-server (&optional server) - (when (and (nnwarchive-server-opened server) - (gnus-buffer-live-p nnwarchive-buffer)) - (save-excursion - (set-buffer nnwarchive-buffer) - (kill-buffer nnwarchive-buffer))) - (nnwarchive-backlog - (gnus-backlog-shutdown)) - (nnoo-close-server 'nnwarchive server)) - -(deffoo nnwarchive-request-list (&optional server) - (nnwarchive-possibly-change-server nil server) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (if nnwarchive-list-url - (nnwarchive-url nnwarchive-list-url)) - (if nnwarchive-list-dissect - (funcall nnwarchive-list-dissect)) - (nnwarchive-write-groups) - (nnwarchive-generate-active)) - t) - -(deffoo nnwarchive-open-server (server &optional defs connectionless) - (nnoo-change-server 'nnwarchive server defs) - (nnwarchive-init server) - (when nnwarchive-authentication - (setq nnwarchive-login - (or nnwarchive-login - (read-string - (format "Login at %s: " server) - user-mail-address))) - (setq nnwarchive-passwd - (or nnwarchive-passwd - (read-passwd - (format "Password for %s at %s: " - nnwarchive-login server))))) - (unless nnwarchive-groups - (nnwarchive-read-groups)) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (if nnwarchive-open-url - (nnwarchive-url nnwarchive-open-url)) - (if nnwarchive-open-dissect - (funcall nnwarchive-open-dissect))) - t) - -(nnoo-define-skeleton nnwarchive) - -;;; Internal functions - -(defun nnwarchive-possibly-change-server (&optional group server) - (nnwarchive-init server) - (when (and server - (not (nnwarchive-server-opened server))) - (nnwarchive-open-server server))) - -(defun nnwarchive-read-groups () - (let ((file (expand-file-name (concat "groups-" nnwarchive-address) - nnwarchive-directory))) - (when (file-exists-p file) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnwarchive-groups (read (current-buffer))))))) - -(defun nnwarchive-write-groups () - (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address) - nnwarchive-directory) - (prin1 nnwarchive-groups (current-buffer)))) - -(defun nnwarchive-init (server) - "Initialize buffers and such." - (let ((type (intern server)) (defs nnwarchive-type-definition) def) - (cond - ((equal server "") - (setq type nnwarchive-default-type)) - ((assq type nnwarchive-type-definition) t) - (t - (setq type nil) - (while (setq def (pop defs)) - (when (equal (cdr (assq 'address (cdr def))) server) - (setq defs nil) - (setq type (car def)))) - (unless type - (error "Undefined server %s" server)))) - (setq nnwarchive-type type)) - (unless (file-exists-p nnwarchive-directory) - (gnus-make-directory nnwarchive-directory)) - (unless (gnus-buffer-live-p nnwarchive-buffer) - (setq nnwarchive-buffer - (save-excursion - (nnheader-set-temp-buffer - (format " *nnwarchive %s %s*" nnwarchive-type server))))) - (nnwarchive-set-default nnwarchive-type)) - -(defun nnwarchive-eval (expr) - (cond - ((consp expr) - (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr)))) - ((symbolp expr) - (eval expr)) - (t - expr))) - -(defun nnwarchive-url (xurl) - (mm-with-unibyte-current-buffer - (let ((url-confirmation-func 'identity) ;; Some hacks. - (url-cookie-multiple-line nil)) - (cond - ((eq (car xurl) 'post) - (pop xurl) - (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) - (t - (mm-url-insert (apply 'format (nnwarchive-eval xurl)))))))) - -(defun nnwarchive-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnwarchive-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (or (cadr elem) 0)) " 1 y\n")))) - -(defun nnwarchive-paged (articles) - (let (art narts next) - (while (setq art (pop articles)) - (when (and (>= art (or next 0)) - (not (assq art nnwarchive-headers))) - (push art narts) - (setq next (+ art nnwarchive-xover-page-size)))) - narts)) - -;; egroups - -(defun nnwarchive-egroups-list-groups (groups) - (save-excursion - (let (articles) - (set-buffer nnwarchive-buffer) - (dolist (group groups) - (erase-buffer) - (nnwarchive-url nnwarchive-xover-last-url) - (goto-char (point-min)) - (when (re-search-forward "of \\([0-9]+\\)[ \t\n\r]*</title>" nil t) - (setq articles (string-to-number (match-string 1)))) - (let ((elem (assoc group nnwarchive-groups))) - (if elem - (setcar (cdr elem) articles) - (push (list group articles "") nnwarchive-groups))) - (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (nnwarchive-egroups-xover group) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))))) - -(defun nnwarchive-egroups-list () - (let ((case-fold-search t) - group description elem articles) - (goto-char (point-min)) - (while - (re-search-forward "href=\"/group/\\([^/\"\> ]+\\)" nil t) - (setq group (match-string 1) - description (match-string 2)) - (if (setq elem (assoc group nnwarchive-groups)) - (setcar (cdr elem) 0) - (push (list group articles description) nnwarchive-groups)))) - t) - -(defun nnwarchive-egroups-xover (group) - (let (article subject from date) - (goto-char (point-min)) - (while (re-search-forward - "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)[^>]+>\\([^<]+\\)<" - nil t) - (setq group (match-string 1) - article (string-to-number (match-string 2)) - subject (match-string 3)) - (forward-line 1) - (unless (assq article nnwarchive-headers) - (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>") - (setq from (match-string 1))) - (forward-line 1) - (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>") - (setq date (identity (match-string 1)))) - (push (cons - article - (make-full-mail-header - article - (mm-url-decode-entities-string subject) - (mm-url-decode-entities-string from) - date - (concat "<" group "%" - (number-to-string article) - "@egroup.com>") - "" - 0 0 "")) nnwarchive-headers)))) - nnwarchive-headers) - -(defun nnwarchive-egroups-article (group articles) - (goto-char (point-min)) - (if (search-forward "<pre>" nil t) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (if (search-backward "</pre>" nil t) - (delete-region (point) (point-max))) - (goto-char (point-min)) - (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t) - (replace-match "\\1")) - (mm-url-decode-entities) - (buffer-string)) - -(defun nnwarchive-egroups-xover-files (group articles) - (let (aux auxs) - (setq auxs (nnwarchive-paged (sort articles '<))) - (while (setq aux (pop auxs)) - (goto-char (point-max)) - (nnwarchive-url nnwarchive-xover-url)) - (if nnwarchive-xover-dissect - (nnwarchive-egroups-xover group)))) - -;; mail-archive - -(defun nnwarchive-mail-archive-list-groups (groups) - (save-excursion - (let (articles) - (set-buffer nnwarchive-buffer) - (dolist (group groups) - (erase-buffer) - (nnwarchive-url nnwarchive-xover-last-url) - (goto-char (point-min)) - (when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t) - (setq articles (1+ (string-to-number (match-string 1))))) - (let ((elem (assoc group nnwarchive-groups))) - (if elem - (setcar (cdr elem) articles) - (push (list group articles "") nnwarchive-groups))) - (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (nnwarchive-mail-archive-xover group) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) - nnwarchive-headers-cache))))))) - -(defun nnwarchive-mail-archive-list () - (let ((case-fold-search t) - group description elem articles) - (goto-char (point-min)) - (while (re-search-forward "<a href=\"\\([^/]+\\)/\">\\([^>]+\\)<" nil t) - (setq group (match-string 1) - description (match-string 2)) - (forward-line 1) - (setq articles 0) - (if (setq elem (assoc group nnwarchive-groups)) - (setcar (cdr elem) articles) - (push (list group articles description) nnwarchive-groups)))) - t) - -(defun nnwarchive-mail-archive-xover (group) - (let (article subject from date) - (goto-char (point-min)) - (while (re-search-forward - "<A[^>]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<" - nil t) - (setq article (1+ (string-to-number (match-string 1))) - subject (match-string 2)) - (forward-line 1) - (unless (assq article nnwarchive-headers) - (if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *<\\([^&]+\\)>") - (progn - (setq from (match-string 1) - date (identity (match-string 2)))) - (setq from "" date "")) - (push (cons - article - (make-full-mail-header - article - (mm-url-decode-entities-string subject) - (mm-url-decode-entities-string from) - date - (format "<%05d%%%s>\n" (1- article) group) - "" - 0 0 "")) nnwarchive-headers)))) - nnwarchive-headers) - -(defun nnwarchive-mail-archive-xover-files (group articles) - (unless nnwarchive-headers - (erase-buffer) - (nnwarchive-url nnwarchive-xover-last-url) - (goto-char (point-min)) - (nnwarchive-mail-archive-xover group)) - (let ((minart (apply 'min articles)) - (min (apply 'min (mapcar 'car nnwarchive-headers))) - (aux 2)) - (while (> min minart) - (erase-buffer) - (nnwarchive-url nnwarchive-xover-url) - (nnwarchive-mail-archive-xover group) - (setq min (apply 'min (mapcar 'car nnwarchive-headers)))))) - -(defvar nnwarchive-caesar-translation-table nil - "Modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/.") - -(defun nnwarchive-make-caesar-translation-table () - "Create modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/." - (let ((i -1) - (table (make-string 256 0)) - (a (mm-char-int ?a)) - (A (mm-char-int ?A))) - (while (< (incf i) 256) - (aset table i i)) - (concat - (substring table 0 (1- A)) - (substring table (+ A 13) (+ A 27)) - (substring table (1- A) (+ A 13)) - (substring table (+ A 27) a) - (substring table (+ a 13) (+ a 26)) - (substring table a (+ a 13)) - (substring table (+ a 26) 255)))) - -(defun nnwarchive-from-r13 (from-r13) - (when from-r13 - (with-temp-buffer - (insert from-r13) - (let ((message-caesar-translation-table - (or nnwarchive-caesar-translation-table - (setq nnwarchive-caesar-translation-table - (nnwarchive-make-caesar-translation-table))))) - (message-caesar-region (point-min) (point-max)) - (buffer-string))))) - -(defun nnwarchive-mail-archive-article (group article) - (let (p refs url mime e - from subject date id - done - (case-fold-search t)) - (save-restriction - (goto-char (point-min)) - (when (search-forward "X-Head-End" nil t) - (beginning-of-line) - (narrow-to-region (point-min) (point)) - (mm-url-decode-entities) - (goto-char (point-min)) - (while (search-forward "<!--X-" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (search-forward " -->" nil t) - (replace-match "")) - (setq from - (or (mail-fetch-field "from") - (nnwarchive-from-r13 - (mail-fetch-field "from-r13")))) - (setq date (mail-fetch-field "date")) - (setq id (mail-fetch-field "message-id")) - (setq subject (mail-fetch-field "subject")) - (goto-char (point-max)) - (widen)) - (when (search-forward "<ul>" nil t) - (forward-line) - (delete-region (point-min) (point)) - (search-forward "</ul>" nil t) - (end-of-line) - (narrow-to-region (point-min) (point)) - (mm-url-remove-markup) - (mm-url-decode-entities) - (goto-char (point-min)) - (delete-blank-lines) - (when from - (message-remove-header "from") - (goto-char (point-max)) - (insert "From: " from "\n")) - (when subject - (message-remove-header "subject") - (goto-char (point-max)) - (insert "Subject: " subject "\n")) - (when id - (goto-char (point-max)) - (insert "X-Message-ID: <" id ">\n")) - (when date - (message-remove-header "date") - (goto-char (point-max)) - (insert "Date: " date "\n")) - (goto-char (point-max)) - (widen) - (insert "\n")) - (setq p (point)) - (when (search-forward "X-Body-of-Message" nil t) - (forward-line) - (delete-region p (point)) - (search-forward "X-Body-of-Message-End" nil t) - (beginning-of-line) - (save-restriction - (narrow-to-region p (point)) - (goto-char (point-min)) - (if (> (skip-chars-forward "\040\n\r\t") 0) - (delete-region (point-min) (point))) - (while (not (eobp)) - (cond - ((looking-at "<PRE>\r?\n?") - (delete-region (match-beginning 0) (match-end 0)) - (setq p (point)) - (when (search-forward "</PRE>" nil t) - (delete-region (match-beginning 0) (match-end 0)) - (save-restriction - (narrow-to-region p (point)) - (mm-url-remove-markup) - (mm-url-decode-entities) - (goto-char (point-max))))) - ((looking-at "<P><A HREF=\"\\([^\"]+\\)") - (setq url (match-string 1)) - (delete-region (match-beginning 0) - (progn (forward-line) (point))) - ;; I hate to download the url encode it, then immediately - ;; decode it. - (insert "<#external" - " type=" - (or (and url - (string-match "\\.[^\\.]+$" url) - (mailcap-extension-to-mime - (match-string 0 url))) - "application/octet-stream") - (format " url=\"http://www.mail-archive.com/%s/%s\"" - group url) - ">\n" - "<#/external>") - (setq mime t)) - (t - (setq p (point)) - (insert "<#part type=\"text/html\" disposition=inline>") - (goto-char - (if (re-search-forward - "[\040\n\r\t]*<PRE>\\|[\040\n\r\t]*<P><A HREF=\"" - nil t) - (match-beginning 0) - (point-max))) - (insert "<#/part>") - (setq mime t))) - (setq p (point)) - (if (> (skip-chars-forward "\040\n\r\t") 0) - (delete-region p (point)))) - (goto-char (point-max)))) - (setq p (point)) - (when (search-forward "X-References-End" nil t) - (setq e (point)) - (beginning-of-line) - (search-backward "X-References" p t) - (while (re-search-forward "msg\\([0-9]+\\)\\.html" e t) - (push (concat "<" (match-string 1) "%" group ">") refs))) - (delete-region p (point-max)) - (goto-char (point-min)) - (insert (format "Message-ID: <%05d%%%s>\n" (1- article) group)) - (when refs - (insert "References:") - (while refs - (insert " " (pop refs))) - (insert "\n")) - (when mime - (unless (looking-at "$") - (search-forward "\n\n" nil t) - (forward-line -1)) - (narrow-to-region (point) (point-max)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max)))) - (widen))) - (buffer-string))) - -(provide 'nnwarchive) - -;; arch-tag: 1ab7a15c-777a-40e0-95c0-0c41b3963578 -;;; nnwarchive.el ends here diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 22b3416008..e9dcae8835 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -104,8 +104,7 @@ Valid types include `google', `dejanews', and `gmane'.") (deffoo nnweb-retrieve-headers (articles &optional group server fetch-old) (nnweb-possibly-change-server group server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article header) (mm-with-unibyte-current-buffer @@ -125,7 +124,7 @@ Valid types include `google', `dejanews', and `gmane'.") (nnweb-write-active) (nnweb-write-overview group))) -(deffoo nnweb-request-group (group &optional server dont-check) +(deffoo nnweb-request-group (group &optional server dont-check info) (nnweb-possibly-change-server group server) (unless (or nnweb-ephemeral-p dont-check @@ -147,16 +146,14 @@ Valid types include `google', `dejanews', and `gmane'.") (deffoo nnweb-close-group (group &optional server) (nnweb-possibly-change-server group server) (when (gnus-buffer-live-p nnweb-buffer) - (save-excursion - (set-buffer nnweb-buffer) + (with-current-buffer nnweb-buffer (set-buffer-modified-p nil) (kill-buffer nnweb-buffer))) t) (deffoo nnweb-request-article (article &optional group server buffer) (nnweb-possibly-change-server group server) - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) + (with-current-buffer (or buffer nntp-server-buffer) (let* ((header (cadr (assq article nnweb-articles))) (url (and header (mail-header-xref header)))) (when (or (and url @@ -185,21 +182,18 @@ Valid types include `google', `dejanews', and `gmane'.") (deffoo nnweb-close-server (&optional server) (when (and (nnweb-server-opened server) (gnus-buffer-live-p nnweb-buffer)) - (save-excursion - (set-buffer nnweb-buffer) + (with-current-buffer nnweb-buffer (set-buffer-modified-p nil) (kill-buffer nnweb-buffer))) (nnoo-close-server 'nnweb server)) (deffoo nnweb-request-list (&optional server) (nnweb-possibly-change-server nil server) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (nnmail-generate-active (list (assoc server nnweb-group-alist))) t)) -(deffoo nnweb-request-update-info (group info &optional server) - (nnweb-possibly-change-server group server)) +(deffoo nnweb-request-update-info (group info &optional server)) (deffoo nnweb-asynchronous-p () nil) @@ -213,7 +207,7 @@ Valid types include `google', `dejanews', and `gmane'.") (deffoo nnweb-request-delete-group (group &optional force server) (nnweb-possibly-change-server group server) - (gnus-pull group nnweb-group-alist t) + (gnus-alist-pull group nnweb-group-alist t) (nnweb-write-active) (gnus-delete-file (nnweb-overview-file group)) t) @@ -402,8 +396,7 @@ Valid types include `google', `dejanews', and `gmane'.") (defun nnweb-google-create-mapping () "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) + (with-current-buffer nnweb-buffer (erase-buffer) (nnheader-message 7 "Searching google...") (when (funcall (nnweb-definition 'search) nnweb-search) @@ -459,8 +452,7 @@ Valid types include `google', `dejanews', and `gmane'.") ;;; (defun nnweb-gmane-create-mapping () "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) + (with-current-buffer nnweb-buffer (let ((case-fold-search t) (active (or (cadr (assoc nnweb-group nnweb-group-alist)) (cons 1 0))) @@ -525,7 +517,7 @@ Valid types include `google', `dejanews', and `gmane'.") ;;("TOPDOC" . "1000") )))) (setq buffer-file-name nil) - (set-buffer-multibyte t) + (unless (featurep 'xemacs) (set-buffer-multibyte t)) (mm-decode-coding-region (point-min) (point-max) 'utf-8) t) @@ -612,5 +604,4 @@ Valid types include `google', `dejanews', and `gmane'.") (provide 'nnweb) -;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697 ;;; nnweb.el ends here diff --git a/lisp/gnus/nnwfm.el b/lisp/gnus/nnwfm.el deleted file mode 100644 index b144363c69..0000000000 --- a/lisp/gnus/nnwfm.el +++ /dev/null @@ -1,432 +0,0 @@ -;;; nnwfm.el --- interfacing with a web forum - -;; Copyright (C) 2000, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <[email protected]> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Note: You need to have `url' and `w3' installed for this -;; backend to work. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) -(require 'nnweb) -(autoload 'w3-parse-buffer "w3-parse") - -(nnoo-declare nnwfm) - -(defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/") - "Where nnwfm will save its files.") - -(defvoo nnwfm-address "" - "The address of the Ultimate bulletin board.") - -;;; Internal variables - -(defvar nnwfm-groups-alist nil) -(defvoo nnwfm-groups nil) -(defvoo nnwfm-headers nil) -(defvoo nnwfm-articles nil) -(defvar nnwfm-table-regexp - "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") - -;;; Interface functions - -(nnoo-define-basics nnwfm) - -(deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old) - (nnwfm-possibly-change-server group server) - (unless gnus-nov-is-evil - (let* ((last (car (last articles))) - (did nil) - (start 1) - (entry (assoc group nnwfm-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (nnwfm-table-regexp "Thread.asp") - headers article subject score from date lines parent point - contents tinfo fetchers map elem a href garticles topic old-max - inc datel table string current-page total-contents pages - farticles forum-contents parse furl-fetched mmap farticle - thread-id tables hstuff bstuff time) - (setq map mapping) - (while (and (setq article (car articles)) - map) - (while (and map - (or (> article (caar map)) - (< (cadar map) (caar map)))) - (pop map)) - (when (setq mmap (car map)) - (setq farticle -1) - (while (and article - (<= article (nth 1 mmap))) - ;; Do we already have a fetcher for this topic? - (if (setq elem (assq (nth 2 mmap) fetchers)) - ;; Yes, so we just add the spec to the end. - (nconc elem (list (cons article - (+ (nth 3 mmap) (incf farticle))))) - ;; No, so we add a new one. - (push (list (nth 2 mmap) - (cons article - (+ (nth 3 mmap) (incf farticle)))) - fetchers)) - (pop articles) - (setq article (car articles))))) - ;; Now we have the mapping from/to Gnus/nnwfm article numbers, - ;; so we start fetching the topics that we need to satisfy the - ;; request. - (if (not fetchers) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) - (setq nnwfm-articles nil) - (mm-with-unibyte-buffer - (dolist (elem fetchers) - (erase-buffer) - (setq subject (nth 2 (assq (car elem) topics)) - thread-id (nth 0 (assq (car elem) topics))) - (mm-url-insert - (concat nnwfm-address - (format "Item.asp?GroupID=%d&ThreadID=%d" sid - thread-id))) - (goto-char (point-min)) - (setq tables (caddar - (caddar - (cdr (caddar - (caddar - (ignore-errors - (w3-parse-buffer (current-buffer))))))))) - (setq tables (cdr (caddar (memq (assq 'div tables) tables)))) - (setq contents nil) - (dolist (table tables) - (when (eq (car table) 'table) - (setq table (caddar (caddar (caddr table))) - hstuff (delete ":link" (nnweb-text (car table))) - bstuff (car (caddar (cdr table))) - from (car hstuff)) - (when (nth 2 hstuff) - (setq time (nnwfm-date-to-time (nth 2 hstuff))) - (push (list from time bstuff) contents)))) - (setq contents (nreverse contents)) - (dolist (art (cdr elem)) - (push (list (car art) - (nth (1- (cdr art)) contents) - subject) - nnwfm-articles)))) - (setq nnwfm-articles - (sort nnwfm-articles 'car-less-than-car)) - ;; Now we have all the articles, conveniently in an alist - ;; where the key is the Gnus article number. - (dolist (articlef nnwfm-articles) - (setq article (nth 0 articlef) - contents (nth 1 articlef) - subject (nth 2 articlef)) - (setq from (nth 0 contents) - date (message-make-date (nth 1 contents))) - (push - (cons - article - (make-full-mail-header - article subject - from (or date "") - (concat "<" (number-to-string sid) "%" - (number-to-string article) - "@wfm>") - "" 0 - (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) "")) - 70) - nil nil)) - headers)) - (setq nnwfm-headers (sort headers 'car-less-than-car)) - (save-excursion - (set-buffer nntp-server-buffer) - (mm-with-unibyte-current-buffer - (erase-buffer) - (dolist (header nnwfm-headers) - (nnheader-insert-nov (cdr header)))))) - 'nov))) - -(deffoo nnwfm-request-group (group &optional server dont-check) - (nnwfm-possibly-change-server nil server) - (when (not nnwfm-groups) - (nnwfm-request-list)) - (unless dont-check - (nnwfm-create-mapping group)) - (let ((elem (assoc group nnwfm-groups))) - (cond - ((not elem) - (nnheader-report 'nnwfm "Group does not exist")) - (t - (nnheader-report 'nnwfm "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) - (prin1-to-string group)))))) - -(deffoo nnwfm-request-close () - (setq nnwfm-groups-alist nil - nnwfm-groups nil)) - -(deffoo nnwfm-request-article (article &optional group server buffer) - (nnwfm-possibly-change-server group server) - (let ((contents (cdr (assq article nnwfm-articles)))) - (when (setq contents (nth 2 (car contents))) - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (nnweb-insert-html contents) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (let ((header (cdr (assq article nnwfm-headers)))) - (mm-with-unibyte-current-buffer - (nnheader-insert-header header))) - (nnheader-report 'nnwfm "Fetched article %s" article) - (cons group article))))) - -(deffoo nnwfm-request-list (&optional server) - (nnwfm-possibly-change-server nil server) - (mm-with-unibyte-buffer - (mm-url-insert - (if (string-match "/$" nnwfm-address) - (concat nnwfm-address "Group.asp") - nnwfm-address)) - (let* ((nnwfm-table-regexp "Thread.asp") - (contents (w3-parse-buffer (current-buffer))) - sid elem description articles a href group forum - a1 a2) - (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table - contents)))))) - (setq row (nth 2 row)) - (when (setq a (nnweb-parse-find 'a row)) - (setq group (car (last (nnweb-text a))) - href (cdr (assq 'href (nth 1 a)))) - (setq description (car (last (nnweb-text (nth 1 row))))) - (setq articles - (string-to-number - (gnus-replace-in-string - (car (last (nnweb-text (nth 3 row)))) "," ""))) - (when (and href - (string-match "GroupId=\\([0-9]+\\)" href)) - (setq forum (string-to-number (match-string 1 href))) - (if (setq elem (assoc group nnwfm-groups)) - (setcar (cdr elem) articles) - (push (list group articles forum description nil nil nil nil) - nnwfm-groups)))))) - (nnwfm-write-groups) - (nnwfm-generate-active) - t)) - -(deffoo nnwfm-request-newgroups (date &optional server) - (nnwfm-possibly-change-server nil server) - (nnwfm-generate-active) - t) - -(nnoo-define-skeleton nnwfm) - -;;; Internal functions - -(defun nnwfm-new-threads-p (group time) - "See whether we want to fetch the threads for GROUP written before TIME." - (let ((old-time (nth 7 (assoc group nnwfm-groups)))) - (or (null old-time) - (time-less-p old-time time)))) - -(defun nnwfm-create-mapping (group) - (let* ((entry (assoc group nnwfm-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (current-time (current-time)) - (nnwfm-table-regexp "Thread.asp") - (furls (list (concat nnwfm-address - (format "Thread.asp?GroupId=%d" sid)))) - fetched-urls - contents forum-contents a subject href - garticles topic tinfo old-max inc parse elem date - url time) - (mm-with-unibyte-buffer - (while furls - (erase-buffer) - (push (car furls) fetched-urls) - (mm-url-insert (pop furls)) - (goto-char (point-min)) - (while (re-search-forward " wr(" nil t) - (forward-char -1) - (setq elem (message-tokenize-header - (gnus-replace-in-string - (buffer-substring - (1+ (point)) - (progn - (forward-sexp 1) - (1- (point)))) - "\\\\[\"\\\\]" ""))) - (push (list - (string-to-number (nth 1 elem)) - (gnus-replace-in-string (nth 2 elem) "\"" "") - (string-to-number (nth 5 elem))) - forum-contents)) - (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)" - nil t) - (setq url (match-string 1) - time (nnwfm-date-to-time (gnus-url-unhex-string - (match-string 2)))) - (when (and (nnwfm-new-threads-p group time) - (not (member - (setq url (concat - nnwfm-address - (mm-url-decode-entities-string url))) - fetched-urls))) - (push url furls)))) - ;; The main idea here is to map Gnus article numbers to - ;; nnwfm article numbers. Say there are three topics in - ;; this forum, the first with 4 articles, the seconds with 2, - ;; and the third with 1. Then this will translate into 7 Gnus - ;; article numbers, where 1-4 comes from the first topic, 5-6 - ;; from the second and 7 from the third. Now, then next time - ;; the group is entered, there's 2 new articles in topic one - ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 - ;; in topic one and 10 will be the 2 in topic three. - (dolist (elem (nreverse forum-contents)) - (setq subject (nth 1 elem) - topic (nth 0 elem) - garticles (nth 2 elem)) - (if (setq tinfo (assq topic topics)) - (progn - (setq old-max (cadr tinfo)) - (setcar (cdr tinfo) garticles)) - (setq old-max 0) - (push (list topic garticles subject) topics) - (setcar (nthcdr 4 entry) topics)) - (when (not (= old-max garticles)) - (setq inc (- garticles old-max)) - (setq mapping (nconc mapping - (list - (list - old-total (1- (incf old-total inc)) - topic (1+ old-max))))) - (incf old-max inc) - (setcar (nthcdr 5 entry) mapping) - (setcar (nthcdr 6 entry) old-total)))) - (setcar (nthcdr 7 entry) current-time) - (setcar (nthcdr 1 entry) (1- old-total)) - (nnwfm-write-groups) - mapping)) - -(defun nnwfm-possibly-change-server (&optional group server) - (nnwfm-init server) - (when (and server - (not (nnwfm-server-opened server))) - (nnwfm-open-server server)) - (unless nnwfm-groups-alist - (nnwfm-read-groups) - (setq nnwfm-groups (cdr (assoc nnwfm-address - nnwfm-groups-alist))))) - -(deffoo nnwfm-open-server (server &optional defs connectionless) - (nnheader-init-server-buffer) - (if (nnwfm-server-opened server) - t - (unless (assq 'nnwfm-address defs) - (setq defs (append defs (list (list 'nnwfm-address server))))) - (nnoo-change-server 'nnwfm server defs))) - -(defun nnwfm-read-groups () - (setq nnwfm-groups-alist nil) - (let ((file (expand-file-name "groups" nnwfm-directory))) - (when (file-exists-p file) - (mm-with-unibyte-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnwfm-groups-alist (read (current-buffer))))))) - -(defun nnwfm-write-groups () - (setq nnwfm-groups-alist - (delq (assoc nnwfm-address nnwfm-groups-alist) - nnwfm-groups-alist)) - (push (cons nnwfm-address nnwfm-groups) - nnwfm-groups-alist) - (with-temp-file (expand-file-name "groups" nnwfm-directory) - (prin1 nnwfm-groups-alist (current-buffer)))) - -(defun nnwfm-init (server) - "Initialize buffers and such." - (unless (file-exists-p nnwfm-directory) - (gnus-make-directory nnwfm-directory))) - -(defun nnwfm-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnwfm-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n")))) - -(defun nnwfm-find-forum-table (contents) - (catch 'found - (nnwfm-find-forum-table-1 contents))) - -(defun nnwfm-find-forum-table-1 (contents) - (dolist (element contents) - (unless (stringp element) - (when (and (eq (car element) 'table) - (nnwfm-forum-table-p element)) - (throw 'found element)) - (when (nth 2 element) - (nnwfm-find-forum-table-1 (nth 2 element)))))) - -(defun nnwfm-forum-table-p (parse) - (when (not (apply 'gnus-or - (mapcar - (lambda (p) - (nnweb-parse-find 'table p)) - (nth 2 parse)))) - (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) - case-fold-search) - (when (and href (string-match nnwfm-table-regexp href)) - t)))) - -(defun nnwfm-date-to-time (date) - (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]")))) - (encode-time 0 (nth 4 time) (nth 3 time) - (nth 0 time) (nth 1 time) - (if (< (nth 2 time) 70) - (+ 2000 (nth 2 time)) - (+ 1900 (nth 2 time)))))) - -(provide 'nnwfm) - -;; Local Variables: -;; coding: iso-8859-1 -;; End: - -;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536 -;;; nnwfm.el ends here diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el index 775dd0c929..90722f708e 100644 --- a/lisp/gnus/pop3.el +++ b/lisp/gnus/pop3.el @@ -33,6 +33,7 @@ ;;; Code: +(eval-when-compile (require 'cl)) (require 'mail-utils) (defvar parse-time-months) @@ -81,6 +82,15 @@ valid value is 'apop'." :version "22.1" ;; Oort Gnus :group 'pop3) +(defcustom pop3-stream-length 100 + "How many messages should be requested at one time. +The lower the number, the more latency-sensitive the fetching +will be. If your pop3 server doesn't support streaming at all, +set this to 1." + :type 'number + :version "24.1" + :group 'pop3) + (defcustom pop3-leave-mail-on-server nil "*Non-nil if the mail is to be left on the POP server after fetching. @@ -114,7 +124,7 @@ Used for APOP authentication.") (defalias 'pop3-accept-process-output 'nnheader-accept-process-output) ;; Borrowed from `nnheader.el': (defvar pop3-read-timeout - (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (if (string-match "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) 1.0 0.01) @@ -128,14 +138,92 @@ Shorter values mean quicker response, but are more CPU intensive.") (truncate pop3-read-timeout)) 1000)))))) -(defun pop3-movemail (&optional crashbox) - "Transfer contents of a maildrop to the specified CRASHBOX." - (or crashbox (setq crashbox (expand-file-name "~/.crashbox"))) +;;;###autoload +(defun pop3-movemail (file) + "Transfer contents of a maildrop to the specified FILE. +Use streaming commands." (let* ((process (pop3-open-server pop3-mailhost pop3-port)) - (crashbuf (get-buffer-create " *pop3-retr*")) - (n 1) - message-count - (pop3-password pop3-password)) + message-count message-total-size) + (pop3-logon process) + (with-current-buffer (process-buffer process) + (let ((size (pop3-stat process))) + (setq message-count (car size) + message-total-size (cadr size))) + (when (> message-count 0) + (pop3-send-streaming-command + process "RETR" message-count message-total-size) + (pop3-write-to-file file) + (unless pop3-leave-mail-on-server + (pop3-send-streaming-command + process "DELE" message-count nil)))) + (pop3-quit process) + t)) + +(defun pop3-send-streaming-command (process command count total-size) + (erase-buffer) + (let ((i 1)) + (while (>= count i) + (process-send-string process (format "%s %d\r\n" command i)) + ;; Only do 100 messages at a time to avoid pipe stalls. + (when (zerop (% i pop3-stream-length)) + (pop3-wait-for-messages process i total-size)) + (incf i))) + (pop3-wait-for-messages process count total-size)) + +(defun pop3-wait-for-messages (process count total-size) + (while (< (pop3-number-of-responses total-size) count) + (when total-size + (message "pop3 retrieved %dKB (%d%%)" + (truncate (/ (buffer-size) 1000)) + (truncate (* (/ (* (buffer-size) 1.0) + total-size) 100)))) + (pop3-accept-process-output process))) + +(defun pop3-write-to-file (file) + (let ((pop-buffer (current-buffer)) + (start (point-min)) + beg end + temp-buffer) + (with-temp-buffer + (setq temp-buffer (current-buffer)) + (with-current-buffer pop-buffer + (goto-char (point-min)) + (while (re-search-forward "^\\+OK" nil t) + (forward-line 1) + (setq beg (point)) + (when (re-search-forward "^\\.\r?\n" nil t) + (setq start (point)) + (forward-line -1) + (setq end (point))) + (with-current-buffer temp-buffer + (goto-char (point-max)) + (let ((hstart (point))) + (insert-buffer-substring pop-buffer beg end) + (pop3-clean-region hstart (point)) + (goto-char (point-max)) + (pop3-munge-message-separator hstart (point)) + (goto-char (point-max)))))) + (let ((coding-system-for-write 'binary)) + (goto-char (point-min)) + ;; Check whether something inserted a newline at the start and + ;; delete it. + (when (eolp) + (delete-char 1)) + (write-region (point-min) (point-max) file nil 'nomesg))))) + +(defun pop3-number-of-responses (endp) + (let ((responses 0)) + (save-excursion + (goto-char (point-min)) + (while (or (and (re-search-forward "^\\+OK" nil t) + (or (not endp) + (re-search-forward "^\\.\r?\n" nil t))) + (re-search-forward "^-ERR " nil t)) + (incf responses))) + responses)) + +(defun pop3-logon (process) + (let ((pop3-password pop3-password)) ;; for debugging only (if pop3-debug (switch-to-buffer (process-buffer process))) ;; query for password @@ -147,34 +235,7 @@ Shorter values mean quicker response, but are more CPU intensive.") ((equal 'pass pop3-authentication-scheme) (pop3-user process pop3-maildrop) (pop3-pass process)) - (t (error "Invalid POP3 authentication scheme"))) - (setq message-count (car (pop3-stat process))) - (unwind-protect - (while (<= n message-count) - (message "Retrieving message %d of %d from %s..." - n message-count pop3-mailhost) - (pop3-retr process n crashbuf) - (save-excursion - (set-buffer crashbuf) - (let ((coding-system-for-write 'binary)) - (write-region (point-min) (point-max) crashbox t 'nomesg)) - (set-buffer (process-buffer process)) - (while (> (buffer-size) 5000) - (goto-char (point-min)) - (forward-line 50) - (delete-region (point-min) (point)))) - (unless pop3-leave-mail-on-server - (pop3-dele process n)) - (setq n (+ 1 n)) - (pop3-accept-process-output process)) - (when (and pop3-leave-mail-on-server - (> n 1)) - (message "pop3.el doesn't support UIDL. Setting `pop3-leave-mail-on-server' -to %s might not give the result you'd expect." pop3-leave-mail-on-server) - (sit-for 1)) - (pop3-quit process)) - (kill-buffer crashbuf)) - t) + (t (error "Invalid POP3 authentication scheme"))))) (defun pop3-get-message-count () "Return the number of messages in the maildrop." @@ -214,15 +275,22 @@ this is nil, `ssl' is assumed for connexions to port (const :tag "SSL/TLS" ssl) (const starttls))) +(eval-and-compile + (if (fboundp 'set-process-query-on-exit-flag) + (defalias 'pop3-set-process-query-on-exit-flag + 'set-process-query-on-exit-flag) + (defalias 'pop3-set-process-query-on-exit-flag + 'process-kill-without-query))) + (defun pop3-open-server (mailhost port) "Open TCP connection to MAILHOST on PORT. Returns the process associated with the connection." (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary) process) - (save-excursion - (set-buffer (get-buffer-create (concat " trace of POP session to " - mailhost))) + (with-current-buffer + (get-buffer-create (concat " trace of POP session to " + mailhost)) (erase-buffer) (setq pop3-read-point (point-min)) (setq process @@ -275,16 +343,11 @@ Returns the process associated with the connection." (starttls-negotiate process) (pop3-quit process) (error "POP server doesn't support starttls")))) + (pop3-set-process-query-on-exit-flag process nil) process))) ;; Support functions -(defun pop3-process-filter (process output) - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (insert output))) - (defun pop3-send-command (process command) (set-buffer (process-buffer process)) (goto-char (point-max)) @@ -300,8 +363,7 @@ Returns the process associated with the connection." Return the response string if optional second argument is non-nil." (let ((case-fold-search nil) match-end) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (goto-char pop3-read-point) (while (and (memq (process-status process) '(open run)) (not (search-forward "\r\n" nil t))) @@ -401,10 +463,7 @@ If NOW, use that time instead." nil (goto-char (point-max)) (insert "\n")) - (narrow-to-region (point) (point-max)) - (let ((size (- (point-max) (point-min)))) - (goto-char (point-min)) - (widen) + (let ((size (- (point-max) (point)))) (forward-line -1) (insert (format "Content-Length: %s\n" size))) ))))) @@ -452,16 +511,33 @@ If NOW, use that time instead." )) (defun pop3-list (process &optional msg) - "Scan listing of available messages. -This function currently does nothing.") + "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs. +Otherwise, return the size of the message-id MSG" + (pop3-send-command process (if msg + (format "LIST %d" msg) + "LIST")) + (let ((response (pop3-read-response process t))) + (if msg + (string-to-number (nth 2 (split-string response " "))) + (let ((start pop3-read-point) end) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker)) + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (mapcar #'(lambda (s) (let ((split (split-string s " "))) + (cons (string-to-number (nth 0 split)) + (string-to-number (nth 1 split))))) + (split-string (buffer-substring start end) "\r\n" t))))))) (defun pop3-retr (process msg crashbuf) "Retrieve message-id MSG to buffer CRASHBUF." (pop3-send-command process (format "RETR %s" msg)) (pop3-read-response process) (let ((start pop3-read-point) end) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (while (not (re-search-forward "^\\.\r\n" nil t)) (pop3-accept-process-output process) (goto-char start)) @@ -477,8 +553,7 @@ This function currently does nothing.") (setq end (point-marker)) (pop3-clean-region start end) (pop3-munge-message-separator start end) - (save-excursion - (set-buffer crashbuf) + (with-current-buffer crashbuf (erase-buffer)) (copy-to-buffer crashbuf start end) (delete-region start end) @@ -515,8 +590,7 @@ and close the connection." (pop3-send-command process "QUIT") (pop3-read-response process t) (if process - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (goto-char (point-max)) (delete-process process)))) @@ -609,5 +683,4 @@ and close the connection." (provide 'pop3) -;; arch-tag: 2facc142-1d74-498e-82af-4659b64cac12 ;;; pop3.el ends here diff --git a/lisp/gnus/proto-stream.el b/lisp/gnus/proto-stream.el new file mode 100644 index 0000000000..546461a67b --- /dev/null +++ b/lisp/gnus/proto-stream.el @@ -0,0 +1,275 @@ +;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections + +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <[email protected]> +;; 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 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; 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', `network-only, `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. If you don't want STARTTLS upgrades, use +`network-only'. + +: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))) + (let ((open-result + (funcall (intern (format "proto-stream-open-%s" type) obarray) + name buffer host service parameters))) + (if (null open-result) + (list nil nil nil) + (destructuring-bind (stream greeting capabilities) open-result + (list (and stream + (memq (process-status stream) + '(open run)) + stream) + greeting capabilities)))))) + +(defun proto-stream-open-network-only (name buffer host service parameters) + (let ((start (with-current-buffer buffer (point))) + (stream (open-network-stream name buffer host service))) + (list stream + (proto-stream-get-response + stream start (proto-stream-eoc parameters)) + nil))) + +(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 (null stream) + nil + ;; 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 --git a/lisp/gnus/qp.el b/lisp/gnus/qp.el index b2338194eb..2775fbead2 100644 --- a/lisp/gnus/qp.el +++ b/lisp/gnus/qp.el @@ -164,5 +164,4 @@ encode lines starting with \"From\"." (provide 'qp) -;; arch-tag: db89e52a-e4a1-4b69-926f-f434f04216ba ;;; qp.el ends here diff --git a/lisp/gnus/rfc1843.el b/lisp/gnus/rfc1843.el index 11a163aac8..5d1999a2a8 100644 --- a/lisp/gnus/rfc1843.el +++ b/lisp/gnus/rfc1843.el @@ -32,7 +32,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -166,7 +166,6 @@ ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" (equal (car ctl) "text/plain")) (rfc1843-decode-region (point) (point-max)))))))) -(defvar rfc1843-old-gnus-decode-header-function nil) (defvar gnus-decode-header-methods) (defvar gnus-decode-encoded-word-methods) @@ -192,5 +191,4 @@ ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" (provide 'rfc1843) -;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687 ;;; rfc1843.el ends here diff --git a/lisp/gnus/rfc2045.el b/lisp/gnus/rfc2045.el index 126ba33e5c..8c8951f38c 100644 --- a/lisp/gnus/rfc2045.el +++ b/lisp/gnus/rfc2045.el @@ -39,5 +39,4 @@ (provide 'rfc2045) -;; arch-tag: 9ca54127-97bc-432c-b6e2-8c59cadba306 ;;; rfc2045.el ends here diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el index 67dd9bd47c..09a6d30831 100644 --- a/lisp/gnus/rfc2047.el +++ b/lisp/gnus/rfc2047.el @@ -31,7 +31,6 @@ (require 'cl)) (defvar message-posting-charset) -(require 'qp) (require 'mm-util) (require 'ietf-drums) ;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus. @@ -343,17 +342,13 @@ The buffer may be narrowed." (defconst rfc2047-syntax-table ;; (make-char-table 'syntax-table '(2)) only works in Emacs. (let ((table (make-syntax-table))) - ;; The following is done to work for setting all elements of the table - ;; in Emacs 21-23 and XEmacs; it appears to be the cleanest way. + ;; The following is done to work for setting all elements of the table; + ;; it appears to be the cleanest way. ;; Play safe and don't assume the form of the word syntax entry -- ;; copy it from ?a. - (if (fboundp 'set-char-table-range) ; Emacs - (funcall (intern "set-char-table-range") - table t (aref (standard-syntax-table) ?a)) - (if (fboundp 'put-char-table) - (if (fboundp 'get-char-table) ; warning avoidance - (put-char-table t (get-char-table ?a (standard-syntax-table)) - table)))) + (if (featurep 'xemacs) + (put-char-table t (get-char-table ?a (standard-syntax-table)) table) + (set-char-table-range table t (aref (standard-syntax-table) ?a))) (modify-syntax-entry ?\\ "\\" table) (modify-syntax-entry ?\" "\"" table) (modify-syntax-entry ?\( "(" table) @@ -428,7 +423,7 @@ Dynamically bind `rfc2047-encoding-type' to change that." ;; since encoded words can't occur in quotes. (progn (goto-char end) - (delete-backward-char 1) + (delete-char -1) (goto-char start) (delete-char 1) (when last-encoded @@ -656,6 +651,9 @@ should not change this value.") Point moves to the end of the region." (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii))) cs encoding tail crest eword) + ;; Use utf-8 as a last resort if determining charset of text fails. + (if (memq nil mime-charset) + (setq mime-charset (list 'utf-8))) (cond ((> (length mime-charset) 1) (error "Can't rfc2047-encode `%s'" (buffer-substring-no-properties b e))) @@ -827,6 +825,8 @@ Point moves to the end of the region." "Base64-encode the header contained in STRING." (base64-encode-string string t)) +(autoload 'quoted-printable-encode-region "qp") + (defun rfc2047-q-encode-string (string) "Quoted-printable-encode the header in STRING." (mm-with-unibyte-buffer @@ -847,18 +847,8 @@ Point moves to the end of the region." (defun rfc2047-encode-parameter (param value) "Return and PARAM=VALUE string encoded in the RFC2047-like style. -This is a replacement for the `rfc2231-encode-string' function. - -When attaching files as MIME parts, we should use the RFC2231 encoding -to specify the file names containing non-ASCII characters. However, -many mail softwares don't support it in practice and recipients won't -be able to extract files with correct names. Instead, the RFC2047-like -encoding is acceptable generally. This function provides the very -RFC2047-like encoding, resigning to such a regrettable trend. To use -it, put the following line in your ~/.gnus.el file: - -\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) -" +This is a substitution for the `rfc2231-encode-string' function, that +is the standard but many mailers don't support it." (let ((rfc2047-encoding-type 'mime) (rfc2047-encode-max-chars nil)) (rfc2045-encode-string param (rfc2047-encode-string value)))) @@ -896,7 +886,7 @@ them.") (goto-char beg) (while (search-forward "\\" nil 'move) (unless (memq (char-after) '(?\")) - (delete-backward-char 1)) + (delete-char -1)) (forward-char))) (forward-char)) (error @@ -929,6 +919,8 @@ only be used for decoding, not for encoding." 'raw-text cs))) +(autoload 'quoted-printable-decode-string "qp") + (defun rfc2047-decode-encoded-words (words) "Decode successive encoded-words in WORDS and return a decoded string. Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT @@ -1169,5 +1161,4 @@ strings are stripped." (provide 'rfc2047) -;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6 ;;; rfc2047.el ends here diff --git a/lisp/gnus/rfc2104.el b/lisp/gnus/rfc2104.el index 6afe5d939f..0fa562bc16 100644 --- a/lisp/gnus/rfc2104.el +++ b/lisp/gnus/rfc2104.el @@ -122,5 +122,4 @@ In XEmacs return just STRING." (provide 'rfc2104) -;; arch-tag: cf671d5c-a45f-4a09-815e-704e59e43950 ;;; rfc2104.el ends here diff --git a/lisp/gnus/rfc2231.el b/lisp/gnus/rfc2231.el index 65590bb695..f5408a01d6 100644 --- a/lisp/gnus/rfc2231.el +++ b/lisp/gnus/rfc2231.el @@ -185,11 +185,19 @@ must never cause a Lisp error." in (sort parameters (lambda (e1 e2) (< (or (caddr e1) 0) (or (caddr e2) 0)))) - do (if (or (not (setq elem (assq attribute cparams))) - (and (numberp part) - (zerop part))) - (push (list attribute value encoded) cparams) - (setcar (cdr elem) (concat (cadr elem) value)))) + do (cond + ;; First part. + ((or (not (setq elem (assq attribute cparams))) + (and (numberp part) + (zerop part))) + (push (list attribute value encoded) cparams)) + ;; Repetition of a part; do nothing. + ((and elem + (null number)) + ) + ;; Concatenate continuation parts. + (t + (setcar (cdr elem) (concat (cadr elem) value))))) ;; Finally decode encoded values. (cons type (mapcar (lambda (elem) @@ -296,5 +304,4 @@ the result of this function." (provide 'rfc2231) -;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63 ;;; rfc2231.el ends here diff --git a/lisp/gnus/rtree.el b/lisp/gnus/rtree.el new file mode 100644 index 0000000000..04079b1ba8 --- /dev/null +++ b/lisp/gnus/rtree.el @@ -0,0 +1,278 @@ +;;; rtree.el --- functions for manipulating range trees + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <[email protected]> + +;; 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 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 8deb5f4d64..e5b6031906 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -116,5 +116,4 @@ This mode is an extended emacs-lisp mode. (provide 'score-mode) -;; arch-tag: a74a416b-2505-4ad4-bc4e-a418c96b8845 ;;; score-mode.el ends here diff --git a/lisp/gnus/shr-color.el b/lisp/gnus/shr-color.el new file mode 100644 index 0000000000..afb56ae38a --- /dev/null +++ b/lisp/gnus/shr-color.el @@ -0,0 +1,361 @@ +;;; shr-color.el --- Simple HTML Renderer color management + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Julien Danjou <[email protected]> +;; Keywords: html + +;; 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 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package handles colors display for shr. + +;;; Code: + +(require 'color) +(eval-when-compile (require 'cl)) + +(defgroup shr-color nil + "Simple HTML Renderer colors" + :group 'shr) + +(defcustom shr-color-visible-luminance-min 40 + "Minimum luminance distance between two colors to be considered visible. +Must be between 0 and 100." + :group 'shr + :type 'float) + +(defcustom shr-color-visible-distance-min 5 + "Minimum color distance between two colors to be considered visible. +This value is used to compare result for `ciede2000'. Its an +absolute value without any unit." + :group 'shr + :type 'integer) + +(defconst shr-color-html-colors-alist + '(("AliceBlue" . "#F0F8FF") + ("AntiqueWhite" . "#FAEBD7") + ("Aqua" . "#00FFFF") + ("Aquamarine" . "#7FFFD4") + ("Azure" . "#F0FFFF") + ("Beige" . "#F5F5DC") + ("Bisque" . "#FFE4C4") + ("Black" . "#000000") + ("BlanchedAlmond" . "#FFEBCD") + ("Blue" . "#0000FF") + ("BlueViolet" . "#8A2BE2") + ("Brown" . "#A52A2A") + ("BurlyWood" . "#DEB887") + ("CadetBlue" . "#5F9EA0") + ("Chartreuse" . "#7FFF00") + ("Chocolate" . "#D2691E") + ("Coral" . "#FF7F50") + ("CornflowerBlue" . "#6495ED") + ("Cornsilk" . "#FFF8DC") + ("Crimson" . "#DC143C") + ("Cyan" . "#00FFFF") + ("DarkBlue" . "#00008B") + ("DarkCyan" . "#008B8B") + ("DarkGoldenRod" . "#B8860B") + ("DarkGray" . "#A9A9A9") + ("DarkGrey" . "#A9A9A9") + ("DarkGreen" . "#006400") + ("DarkKhaki" . "#BDB76B") + ("DarkMagenta" . "#8B008B") + ("DarkOliveGreen" . "#556B2F") + ("Darkorange" . "#FF8C00") + ("DarkOrchid" . "#9932CC") + ("DarkRed" . "#8B0000") + ("DarkSalmon" . "#E9967A") + ("DarkSeaGreen" . "#8FBC8F") + ("DarkSlateBlue" . "#483D8B") + ("DarkSlateGray" . "#2F4F4F") + ("DarkSlateGrey" . "#2F4F4F") + ("DarkTurquoise" . "#00CED1") + ("DarkViolet" . "#9400D3") + ("DeepPink" . "#FF1493") + ("DeepSkyBlue" . "#00BFFF") + ("DimGray" . "#696969") + ("DimGrey" . "#696969") + ("DodgerBlue" . "#1E90FF") + ("FireBrick" . "#B22222") + ("FloralWhite" . "#FFFAF0") + ("ForestGreen" . "#228B22") + ("Fuchsia" . "#FF00FF") + ("Gainsboro" . "#DCDCDC") + ("GhostWhite" . "#F8F8FF") + ("Gold" . "#FFD700") + ("GoldenRod" . "#DAA520") + ("Gray" . "#808080") + ("Grey" . "#808080") + ("Green" . "#008000") + ("GreenYellow" . "#ADFF2F") + ("HoneyDew" . "#F0FFF0") + ("HotPink" . "#FF69B4") + ("IndianRed" . "#CD5C5C") + ("Indigo" . "#4B0082") + ("Ivory" . "#FFFFF0") + ("Khaki" . "#F0E68C") + ("Lavender" . "#E6E6FA") + ("LavenderBlush" . "#FFF0F5") + ("LawnGreen" . "#7CFC00") + ("LemonChiffon" . "#FFFACD") + ("LightBlue" . "#ADD8E6") + ("LightCoral" . "#F08080") + ("LightCyan" . "#E0FFFF") + ("LightGoldenRodYellow" . "#FAFAD2") + ("LightGray" . "#D3D3D3") + ("LightGrey" . "#D3D3D3") + ("LightGreen" . "#90EE90") + ("LightPink" . "#FFB6C1") + ("LightSalmon" . "#FFA07A") + ("LightSeaGreen" . "#20B2AA") + ("LightSkyBlue" . "#87CEFA") + ("LightSlateGray" . "#778899") + ("LightSlateGrey" . "#778899") + ("LightSteelBlue" . "#B0C4DE") + ("LightYellow" . "#FFFFE0") + ("Lime" . "#00FF00") + ("LimeGreen" . "#32CD32") + ("Linen" . "#FAF0E6") + ("Magenta" . "#FF00FF") + ("Maroon" . "#800000") + ("MediumAquaMarine" . "#66CDAA") + ("MediumBlue" . "#0000CD") + ("MediumOrchid" . "#BA55D3") + ("MediumPurple" . "#9370D8") + ("MediumSeaGreen" . "#3CB371") + ("MediumSlateBlue" . "#7B68EE") + ("MediumSpringGreen" . "#00FA9A") + ("MediumTurquoise" . "#48D1CC") + ("MediumVioletRed" . "#C71585") + ("MidnightBlue" . "#191970") + ("MintCream" . "#F5FFFA") + ("MistyRose" . "#FFE4E1") + ("Moccasin" . "#FFE4B5") + ("NavajoWhite" . "#FFDEAD") + ("Navy" . "#000080") + ("OldLace" . "#FDF5E6") + ("Olive" . "#808000") + ("OliveDrab" . "#6B8E23") + ("Orange" . "#FFA500") + ("OrangeRed" . "#FF4500") + ("Orchid" . "#DA70D6") + ("PaleGoldenRod" . "#EEE8AA") + ("PaleGreen" . "#98FB98") + ("PaleTurquoise" . "#AFEEEE") + ("PaleVioletRed" . "#D87093") + ("PapayaWhip" . "#FFEFD5") + ("PeachPuff" . "#FFDAB9") + ("Peru" . "#CD853F") + ("Pink" . "#FFC0CB") + ("Plum" . "#DDA0DD") + ("PowderBlue" . "#B0E0E6") + ("Purple" . "#800080") + ("Red" . "#FF0000") + ("RosyBrown" . "#BC8F8F") + ("RoyalBlue" . "#4169E1") + ("SaddleBrown" . "#8B4513") + ("Salmon" . "#FA8072") + ("SandyBrown" . "#F4A460") + ("SeaGreen" . "#2E8B57") + ("SeaShell" . "#FFF5EE") + ("Sienna" . "#A0522D") + ("Silver" . "#C0C0C0") + ("SkyBlue" . "#87CEEB") + ("SlateBlue" . "#6A5ACD") + ("SlateGray" . "#708090") + ("SlateGrey" . "#708090") + ("Snow" . "#FFFAFA") + ("SpringGreen" . "#00FF7F") + ("SteelBlue" . "#4682B4") + ("Tan" . "#D2B48C") + ("Teal" . "#008080") + ("Thistle" . "#D8BFD8") + ("Tomato" . "#FF6347") + ("Turquoise" . "#40E0D0") + ("Violet" . "#EE82EE") + ("Wheat" . "#F5DEB3") + ("White" . "#FFFFFF") + ("WhiteSmoke" . "#F5F5F5") + ("Yellow" . "#FFFF00") + ("YellowGreen" . "#9ACD32")) + "Alist of HTML colors. +Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).") + +(defun shr-color-relative-to-absolute (number) + "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER. +This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." + (let ((string-length (- (length number) 1))) + ;; Is this a number with %? + (if (eq (elt number string-length) ?%) + (/ (* (string-to-number (substring number 0 string-length)) 255) 100) + (string-to-number number)))) + +(defun shr-color-hue-to-rgb (x y h) + "Convert X Y H to RGB value." + (when (< h 0) (incf h)) + (when (> h 1) (decf h)) + (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6))) + ((< h 0.5) y) + ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) + (t x))) + +(defun shr-color-hsl-to-rgb-fractions (h s l) + "Convert H S L to fractional RGB values." + (let (m1 m2) + (if (<= l 0.5) + (setq m2 (* l (+ s 1))) + (setq m2 (- (+ l s) (* l s)))) + (setq m1 (- (* l 2) m2)) + (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0))) + (shr-color-hue-to-rgb m1 m2 h) + (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0)))))) + +(defun shr-color->hexadecimal (color) + "Convert any color format to hexadecimal representation. +Like rgb() or hsl()." + (when color + (cond + ;; Hexadecimal color: #abc or #aabbcc + ((string-match + "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" + color) + (match-string 1 color)) + ;; rgb() or rgba() colors + ((or (string-match + "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" + color) + (string-match + "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" + color)) + (format "#%02X%02X%02X" + (shr-color-relative-to-absolute (match-string-no-properties 1 color)) + (shr-color-relative-to-absolute (match-string-no-properties 2 color)) + (shr-color-relative-to-absolute (match-string-no-properties 3 color)))) + ;; hsl() or hsla() colors + ((or (string-match + "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)" + color) + (string-match + "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" + color)) + (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) + (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) + (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) + (destructuring-bind (r g b) + (shr-color-hsl-to-rgb-fractions h s l) + (color-rgb->hex r g b)))) + ;; Color names + ((cdr (assoc-string color shr-color-html-colors-alist t))) + ;; Unrecognized color :( + (t + nil)))) + +(defun set-minimum-interval (val1 val2 min max interval &optional fixed) + "Set minimum interval between VAL1 and VAL2 to INTERVAL. +The values are bound by MIN and MAX. +If FIXED is t, then val1 will not be touched." + (let ((diff (abs (- val1 val2)))) + (unless (>= diff interval) + (if fixed + (let* ((missing (- interval diff)) + ;; If val2 > val1, try to increase val2 + ;; That's the "good direction" + (val2-good-direction + (if (> val2 val1) + (min max (+ val2 missing)) + (max min (- val2 missing)))) + (diff-val2-good-direction-val1 (abs (- val2-good-direction val1)))) + (if (>= diff-val2-good-direction-val1 interval) + (setq val2 val2-good-direction) + ;; Good-direction is not so good, compute bad-direction + (let* ((val2-bad-direction + (if (> val2 val1) + (max min (- val1 interval)) + (min max (+ val1 interval)))) + (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1)))) + (if (>= diff-val2-bad-direction-val1 interval) + (setq val2 val2-bad-direction) + ;; Still not good, pick the best and prefer good direction + (setq val2 + (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1) + val2-good-direction + val2-bad-direction)))))) + ;; No fixed, move val1 and val2 + (let ((missing (/ (- interval diff) 2.0))) + (if (< val1 val2) + (setq val1 (max min (- val1 missing)) + val2 (min max (+ val2 missing))) + (setq val2 (max min (- val2 missing)) + val1 (min max (+ val1 missing)))) + (setq diff (abs (- val1 val2))) ; Recompute diff + (unless (>= diff interval) + ;; Not ok, we hit a boundary + (let ((missing (- interval diff))) + (cond ((= val1 min) + (setq val2 (+ val2 missing))) + ((= val2 min) + (setq val1 (+ val1 missing))) + ((= val1 max) + (setq val2 (- val2 missing))) + ((= val2 max) + (setq val1 (- val1 missing))))))))) + (list val1 val2))) + +(defun shr-color-visible (bg fg &optional fixed-background) + "Check that BG and FG colors are visible if they are drawn on each other. +Return (bg fg) if they are. If they are too similar, two new +colors are returned instead. +If FIXED-BACKGROUND is set, and if the color are not visible, a +new background color will not be computed. Only the foreground +color will be adapted to be visible on BG." + ;; Convert fg and bg to CIE Lab + (let ((fg-norm (color-rgb->normalize fg)) + (bg-norm (color-rgb->normalize bg))) + (if (or (null fg-norm) + (null bg-norm)) + (list bg fg) + (let* ((fg-lab (apply 'color-srgb->lab fg-norm)) + (bg-lab (apply 'color-srgb->lab bg-norm)) + ;; Compute color distance using CIE DE 2000 + (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) + ;; Compute luminance distance (substract L component) + (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) + (if (and (>= fg-bg-distance shr-color-visible-distance-min) + (>= luminance-distance shr-color-visible-luminance-min)) + (list bg fg) + ;; Not visible, try to change luminance to make them visible + (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 + shr-color-visible-luminance-min + fixed-background))) + (unless fixed-background + (setcar bg-lab (car Ls))) + (setcar fg-lab (cadr Ls)) + (list + (if fixed-background + bg + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) + (apply 'color-lab->srgb bg-lab)))) + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) + (apply 'color-lab->srgb fg-lab)))))))))) + +(provide 'shr-color) + +;;; shr-color.el ends here diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el new file mode 100644 index 0000000000..6e681d6736 --- /dev/null +++ b/lisp/gnus/shr.el @@ -0,0 +1,1218 @@ +;;; shr.el --- Simple HTML Renderer + +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <[email protected]> +;; Keywords: html + +;; 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 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package takes a HTML parse tree (as provided by +;; libxml-parse-html-region) and renders it in the current buffer. It +;; does not do CSS, JavaScript or anything advanced: It's geared +;; towards rendering typical short snippets of HTML, like what you'd +;; find in HTML email and the like. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'browse-url) + +(defgroup shr nil + "Simple HTML Renderer" + :group 'mail) + +(defcustom shr-max-image-proportion 0.9 + "How big pictures displayed are in relation to the window they're in. +A value of 0.7 means that they are allowed to take up 70% of the +width and height of the window. If they are larger than this, +and Emacs supports it, then the images will be rescaled down to +fit these criteria." + :version "24.1" + :group 'shr + :type 'float) + +(defcustom shr-blocked-images nil + "Images that have URLs matching this regexp will be blocked." + :version "24.1" + :group 'shr + :type 'regexp) + +(defcustom shr-table-horizontal-line ?- + "Character used to draw horizontal table lines." + :group 'shr + :type 'character) + +(defcustom shr-table-vertical-line ?| + "Character used to draw vertical table lines." + :group 'shr + :type 'character) + +(defcustom shr-table-corner ?+ + "Character used to draw table corners." + :group 'shr + :type 'character) + +(defcustom shr-hr-line ?- + "Character used to draw hr lines." + :group 'shr + :type 'character) + +(defcustom shr-width fill-column + "Frame width to use for rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that the full width of the window should be +used." + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "Use the width of the window" nil)) + :group 'shr) + +(defvar shr-content-function nil + "If bound, this should be a function that will return the content. +This is used for cid: URLs, and the function is called with the +cid: URL as the argument.") + +;;; Internal variables. + +(defvar shr-folding-mode nil) +(defvar shr-state nil) +(defvar shr-start nil) +(defvar shr-indentation 0) +(defvar shr-inhibit-images nil) +(defvar shr-list-mode nil) +(defvar shr-content-cache nil) +(defvar shr-kinsoku-shorten nil) +(defvar shr-table-depth 0) +(defvar shr-stylesheet nil) + +(defvar shr-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'shr-show-alt-text) + (define-key map "i" 'shr-browse-image) + (define-key map "I" 'shr-insert-image) + (define-key map "u" 'shr-copy-url) + (define-key map "v" 'shr-browse-url) + (define-key map "o" 'shr-save-contents) + (define-key map "\r" 'shr-browse-url) + map)) + +;; Public functions and commands. + +;;;###autoload +(defun shr-insert-document (dom) + (setq shr-content-cache nil) + (let ((shr-state nil) + (shr-start nil) + (shr-width (or shr-width (window-width)))) + (shr-descend (shr-transform-dom dom)))) + +(defun shr-copy-url () + "Copy the URL under point to the kill ring. +If called twice, then try to fetch the URL and see whether it +redirects somewhere else." + (interactive) + (let ((url (get-text-property (point) 'shr-url))) + (cond + ((not url) + (message "No URL under point")) + ;; Resolve redirected URLs. + ((equal url (car kill-ring)) + (url-retrieve + url + (lambda (a) + (when (and (consp a) + (eq (car a) :redirect)) + (with-temp-buffer + (insert (cadr a)) + (goto-char (point-min)) + ;; Remove common tracking junk from the URL. + (when (re-search-forward ".utm_.*" nil t) + (replace-match "" t t)) + (message "Copied %s" (buffer-string)) + (copy-region-as-kill (point-min) (point-max))))))) + ;; Copy the URL to the kill ring. + (t + (with-temp-buffer + (insert url) + (copy-region-as-kill (point-min) (point-max)) + (message "Copied %s" url)))))) + +(defun shr-show-alt-text () + "Show the ALT text of the image under point." + (interactive) + (let ((text (get-text-property (point) 'shr-alt))) + (if (not text) + (message "No image under point") + (message "%s" text)))) + +(defun shr-browse-image () + "Browse the image under point." + (interactive) + (let ((url (get-text-property (point) 'image-url))) + (if (not url) + (message "No image under point") + (message "Browsing %s..." url) + (browse-url url)))) + +(defun shr-insert-image () + "Insert the image under point into the buffer." + (interactive) + (let ((url (get-text-property (point) 'image-url))) + (if (not url) + (message "No image under point") + (message "Inserting %s..." url) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) (1- (point)) (point-marker)) + t)))) + +;;; Utility functions. + +(defun shr-transform-dom (dom) + (let ((result (list (pop dom)))) + (dolist (arg (pop dom)) + (push (cons (intern (concat ":" (symbol-name (car arg))) obarray) + (cdr arg)) + result)) + (dolist (sub dom) + (if (stringp sub) + (push (cons 'text sub) result) + (push (shr-transform-dom sub) result))) + (nreverse result))) + +(defun shr-descend (dom) + (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)) + (style (cdr (assq :style (cdr dom)))) + (shr-stylesheet shr-stylesheet) + (start (point))) + (when style + (if (string-match "color" style) + (setq shr-stylesheet (nconc (shr-parse-style style) + shr-stylesheet)) + (setq style nil))) + (if (fboundp function) + (funcall function (cdr dom)) + (shr-generic (cdr dom))) + ;; If style is set, then this node has set the color. + (when style + (shr-colorize-region start (point) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))))) + +(defun shr-generic (cont) + (dolist (sub cont) + (cond + ((eq (car sub) 'text) + (shr-insert (cdr sub))) + ((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))) + (insert "\n") + (setq shr-state nil)) + (cond + ((eq shr-folding-mode 'none) + (insert text)) + (t + (when (and (string-match "\\`[ \t\n]" text) + (not (bolp)) + (not (eq (char-after (1- (point))) ? ))) + (insert " ")) + (dolist (elem (split-string text)) + (when (and (bolp) + (> shr-indentation 0)) + (shr-indent)) + ;; No space is needed behind a wide character categorized as + ;; kinsoku-bol, between characters both categorized as nospace, + ;; or at the beginning of a line. + (let (prev) + (when (and (> (current-column) shr-indentation) + (eq (preceding-char) ? ) + (or (= (line-beginning-position) (1- (point))) + (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))) + ;; The shr-start is a special variable that is used to pass + ;; upwards the first point in the buffer where the text really + ;; starts. + (unless shr-start + (setq shr-start (point))) + (insert elem) + (let (found) + (while (and (> (current-column) shr-width) + (progn + (setq found (shr-find-fill-point)) + (not (eolp)))) + (when (eq (preceding-char) ? ) + (delete-char -1)) + (insert "\n") + (unless found + (put-text-property (1- (point)) (point) 'shr-break t) + ;; No space is needed at the beginning of a line. + (when (eq (following-char) ? ) + (delete-char 1))) + (when (> shr-indentation 0) + (shr-indent)) + (end-of-line)) + (insert " "))) + (unless (string-match "[ \t\n]\\'" text) + (delete-char -1))))) + +(defun shr-find-fill-point () + (when (> (move-to-column shr-width) shr-width) + (backward-char 1)) + (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)) + (if (eq (preceding-char) ?') + (not (memq (char-after (- (point) 2)) + (list nil ?\n ? ))) + (and (shr-char-kinsoku-bol-p (preceding-char)) + (shr-char-breakable-p (following-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. + (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) + ;; 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 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) + (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)) + (insert "\n"))) + +(defun shr-ensure-paragraph () + (unless (bobp) + (if (<= (current-column) shr-indentation) + (unless (save-excursion + (forward-line -1) + (looking-at " *$")) + (insert "\n")) + (if (save-excursion + (beginning-of-line) + (looking-at " *$")) + (insert "\n") + (insert "\n\n"))))) + +(defun shr-indent () + (when (> shr-indentation 0) + (insert (make-string shr-indentation ? )))) + +(defun shr-fontize-cont (cont &rest types) + (let (shr-start) + (shr-generic cont) + (dolist (type types) + (shr-add-font (or shr-start (point)) (point) type)))) + +;; Add an overlay in the region, but avoid putting the font properties +;; on blank text at the start of the line, and the newline at the end, +;; to avoid ugliness. +(defun shr-add-font (start end type) + (save-excursion + (goto-char start) + (while (< (point) end) + (when (bolp) + (skip-chars-forward " ")) + (let ((overlay (make-overlay (point) (min (line-end-position) end)))) + (overlay-put overlay 'face type)) + (if (< (line-end-position) end) + (forward-line 1) + (goto-char end))))) + +(defun shr-browse-url () + "Browse the URL under point." + (interactive) + (let ((url (get-text-property (point) 'shr-url))) + (cond + ((not url) + (message "No link under point")) + ((string-match "^mailto:" url) + (browse-url-mailto url)) + (t + (browse-url url))))) + +(defun shr-save-contents (directory) + "Save the contents from URL in a file." + (interactive "DSave contents of URL to directory: ") + (let ((url (get-text-property (point) 'shr-url))) + (if (not url) + (message "No link under point") + (url-retrieve (shr-encode-url url) + 'shr-store-contents (list url directory))))) + +(defun shr-store-contents (status url directory) + (unless (plist-get status :error) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (write-region (point) (point-max) + (expand-file-name (file-name-nondirectory url) + directory))))) + +(defun shr-image-fetched (status buffer start end) + (when (and (buffer-name buffer) + (not (plist-get status :error))) + (url-store-in-cache (current-buffer)) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (let ((alt (buffer-substring start end)) + (inhibit-read-only t)) + (delete-region start end) + (goto-char start) + (shr-put-image data alt)))))) + (kill-buffer (current-buffer))) + +(defun shr-put-image (data alt) + (if (display-graphic-p) + (let ((image (ignore-errors + (shr-rescale-image data)))) + (when image + ;; When inserting big-ish pictures, put them at the + ;; beginning of the line. + (when (and (> (current-column) 0) + (> (car (image-size image t)) 400)) + (insert "\n")) + (insert-image image (or alt "*")))) + (insert alt))) + +(defun shr-rescale-image (data) + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + (create-image data nil t) + (let* ((image (create-image data nil t)) + (size (image-size image t)) + (width (car size)) + (height (cdr size)) + (edges (window-inside-pixel-edges + (get-buffer-window (current-buffer)))) + (window-width (truncate (* shr-max-image-proportion + (- (nth 2 edges) (nth 0 edges))))) + (window-height (truncate (* shr-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))) + scaled-image) + (when (> height window-height) + (setq image (or (create-image data 'imagemagick t + :height window-height) + image)) + (setq size (image-size image t))) + (when (> (car size) window-width) + (setq image (or + (create-image data 'imagemagick t + :width window-width) + image))) + (when (and (fboundp 'create-animated-image) + (eq (image-type data nil t) 'gif)) + (setq image (create-animated-image data 'gif t))) + image))) + +;; url-cache-extract autoloads url-cache. +(declare-function url-cache-create-filename "url-cache" (url)) +(autoload 'mm-disable-multibyte "mm-util") +(autoload 'browse-url-mailto "browse-url") + +(defun shr-get-image-data (url) + "Get image data for URL. +Return a string with image data." + (with-temp-buffer + (mm-disable-multibyte) + (when (ignore-errors + (url-cache-extract (url-cache-create-filename (shr-encode-url url))) + t) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (buffer-substring (point) (point-max)))))) + +(defun shr-image-displayer (content-function) + "Return a function to display an image. +CONTENT-FUNCTION is a function to retrieve an image for a cid url that +is an argument. The function to be returned takes three arguments URL, +START, and END. Note that START and END should be merkers." + `(lambda (url start end) + (when url + (if (string-match "\\`cid:" url) + ,(when content-function + `(let ((image (funcall ,content-function + (substring url (match-end 0))))) + (when image + (goto-char start) + (shr-put-image image + (buffer-substring-no-properties start end)) + (delete-region (point) end)))) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) start end) + t))))) + +(defun shr-heading (cont &rest types) + (shr-ensure-paragraph) + (apply #'shr-fontize-cont cont types) + (shr-ensure-paragraph)) + +(autoload 'widget-convert-button "wid-edit") + +(defun shr-urlify (start url &optional title) + (widget-convert-button + 'url-link start (point) + :help-echo (if title (format "%s (%s)" url title) url) + :keymap shr-map + url) + (put-text-property start (point) 'shr-url url)) + +(defun shr-encode-url (url) + "Encode URL." + (browse-url-url-encode-chars url "[)$ ]")) + +(autoload 'shr-color-visible "shr-color") +(autoload 'shr-color->hexadecimal "shr-color") + +(defun shr-color-check (fg bg) + "Check that FG is visible on BG. +Returns (fg bg) with corrected values. +Returns nil if the colors that would be used are the default +ones, in case fg and bg are nil." + (when (or fg bg) + (let ((fixed (cond ((null fg) 'fg) + ((null bg) 'bg)))) + ;; Convert colors to hexadecimal, or set them to default. + (let ((fg (or (shr-color->hexadecimal fg) + (frame-parameter nil 'foreground-color))) + (bg (or (shr-color->hexadecimal bg) + (frame-parameter nil 'background-color)))) + (cond ((eq fixed 'bg) + ;; Only return the new fg + (list nil (cadr (shr-color-visible bg fg t)))) + ((eq fixed 'fg) + ;; Invert args and results and return only the new bg + (list (cadr (shr-color-visible fg bg t)) nil)) + (t + (shr-color-visible bg fg))))))) + +(defun shr-colorize-region (start end fg &optional bg) + (when (or fg bg) + (let ((new-colors (shr-color-check fg bg))) + (when new-colors + (when fg + (shr-put-color start end :foreground (cadr new-colors))) + (when bg + (shr-put-color start end :background (car new-colors))))))) + +;; Put a color in the region, but avoid putting colors on on blank +;; text at the start of the line, and the newline at the end, to avoid +;; ugliness. Also, don't overwrite any existing color information, +;; since this can be called recursively, and we want the "inner" color +;; to win. +(defun shr-put-color (start end type color) + (save-excursion + (goto-char start) + (while (< (point) end) + (when (bolp) + (skip-chars-forward " ")) + (when (> (line-end-position) (point)) + (shr-put-color-1 (point) (min (line-end-position) end) type color)) + (if (< (line-end-position) end) + (forward-line 1) + (goto-char end))))) + +(defun shr-put-color-1 (start end type color) + (let* ((old-props (get-text-property start 'face)) + (do-put (not (memq type old-props))) + change) + (while (< start end) + (setq change (next-single-property-change start 'face nil end)) + (when do-put + (put-text-property start change 'face + (nconc (list type color) old-props))) + (setq old-props (get-text-property change 'face)) + (setq do-put (not (memq type old-props))) + (setq start change)) + (when (and do-put + (> end start)) + (put-text-property start end 'face + (nconc (list type color old-props)))))) + +;;; Tag-specific rendering rules. + +(defun shr-tag-body (cont) + (let* ((start (point)) + (fgcolor (cdr (assq :fgcolor cont))) + (bgcolor (cdr (assq :bgcolor cont))) + (shr-stylesheet (list (cons 'color fgcolor) + (cons 'background-color bgcolor)))) + (shr-generic cont) + (shr-colorize-region start (point) fgcolor bgcolor))) + +(defun shr-tag-style (cont) + ) + +(defun shr-tag-script (cont) + ) + +(defun shr-tag-label (cont) + (shr-generic cont) + (shr-ensure-paragraph)) + +(defun shr-tag-p (cont) + (shr-ensure-paragraph) + (shr-indent) + (shr-generic cont) + (shr-ensure-paragraph)) + +(defun shr-tag-div (cont) + (shr-ensure-newline) + (shr-indent) + (shr-generic cont) + (shr-ensure-newline)) + +(defun shr-tag-b (cont) + (shr-fontize-cont cont 'bold)) + +(defun shr-tag-i (cont) + (shr-fontize-cont cont 'italic)) + +(defun shr-tag-em (cont) + (shr-fontize-cont cont 'bold)) + +(defun shr-tag-strong (cont) + (shr-fontize-cont cont 'bold)) + +(defun shr-tag-u (cont) + (shr-fontize-cont cont 'underline)) + +(defun shr-tag-s (cont) + (shr-fontize-cont cont 'strike-through)) + +(defun shr-parse-style (style) + (when style + (save-match-data + (when (string-match "\n" style) + (setq style (replace-match " " t t style)))) + (let ((plist nil)) + (dolist (elem (split-string style ";")) + (when elem + (setq elem (split-string elem ":")) + (when (and (car elem) + (cadr elem)) + (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem))) + (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem)))) + (when (string-match " *!important\\'" value) + (setq value (substring value 0 (match-beginning 0)))) + (push (cons (intern name obarray) + value) + plist))))) + plist))) + +(defun shr-tag-a (cont) + (let ((url (cdr (assq :href cont))) + (title (cdr (assq :title cont))) + (start (point)) + shr-start) + (shr-generic cont) + (shr-urlify (or shr-start start) url title))) + +(defun shr-tag-object (cont) + (let ((start (point)) + url) + (dolist (elem cont) + (when (eq (car elem) 'embed) + (setq url (or url (cdr (assq :src (cdr elem)))))) + (when (and (eq (car elem) 'param) + (equal (cdr (assq :name (cdr elem))) "movie")) + (setq url (or url (cdr (assq :value (cdr elem))))))) + (when url + (shr-insert " [multimedia] ") + (shr-urlify start url)) + (shr-generic cont))) + +(defun shr-tag-video (cont) + (let ((image (cdr (assq :poster cont))) + (url (cdr (assq :src cont))) + (start (point))) + (shr-tag-img nil image) + (shr-urlify start url))) + +(defun shr-tag-img (cont &optional url) + (when (or url + (and cont + (cdr (assq :src cont)))) + (when (and (> (current-column) 0) + (not (eq shr-state 'image))) + (insert "\n")) + (let ((alt (cdr (assq :alt cont))) + (url (or url (cdr (assq :src cont))))) + (let ((start (point-marker))) + (when (zerop (length alt)) + (setq alt "*")) + (cond + ((or (member (cdr (assq :height cont)) '("0" "1")) + (member (cdr (assq :width cont)) '("0" "1"))) + ;; Ignore zero-sized or single-pixel images. + ) + ((and (not shr-inhibit-images) + (string-match "\\`cid:" url)) + (let ((url (substring url (match-end 0))) + image) + (if (or (not shr-content-function) + (not (setq image (funcall shr-content-function url)))) + (insert alt) + (shr-put-image image alt)))) + ((or shr-inhibit-images + (and shr-blocked-images + (string-match shr-blocked-images url))) + (setq shr-start (point)) + (let ((shr-state 'space)) + (if (> (string-width alt) 8) + (shr-insert (truncate-string-to-width alt 8)) + (shr-insert alt)))) + ((url-is-cached (shr-encode-url url)) + (shr-put-image (shr-get-image-data url) alt)) + (t + (insert alt) + (ignore-errors + (url-retrieve (shr-encode-url url) 'shr-image-fetched + (list (current-buffer) start (point-marker)) + t)))) + (put-text-property start (point) 'keymap shr-map) + (put-text-property start (point) 'shr-alt alt) + (put-text-property start (point) 'image-url url) + (put-text-property start (point) 'image-displayer + (shr-image-displayer shr-content-function)) + (put-text-property start (point) 'help-echo alt) + (setq shr-state 'image))))) + +(defun shr-tag-pre (cont) + (let ((shr-folding-mode 'none)) + (shr-ensure-newline) + (shr-indent) + (shr-generic cont) + (shr-ensure-newline))) + +(defun shr-tag-blockquote (cont) + (shr-ensure-paragraph) + (shr-indent) + (let ((shr-indentation (+ shr-indentation 4))) + (shr-generic cont)) + (shr-ensure-paragraph)) + +(defun shr-tag-ul (cont) + (shr-ensure-paragraph) + (let ((shr-list-mode 'ul)) + (shr-generic cont)) + (shr-ensure-paragraph)) + +(defun shr-tag-ol (cont) + (shr-ensure-paragraph) + (let ((shr-list-mode 1)) + (shr-generic cont)) + (shr-ensure-paragraph)) + +(defun shr-tag-li (cont) + (shr-ensure-paragraph) + (shr-indent) + (let* ((bullet + (if (numberp shr-list-mode) + (prog1 + (format "%d " shr-list-mode) + (setq shr-list-mode (1+ shr-list-mode))) + "* ")) + (shr-indentation (+ shr-indentation (length bullet)))) + (insert bullet) + (shr-generic cont))) + +(defun shr-tag-br (cont) + (unless (bobp) + (insert "\n") + (shr-indent)) + (shr-generic cont)) + +(defun shr-tag-h1 (cont) + (shr-heading cont 'bold 'underline)) + +(defun shr-tag-h2 (cont) + (shr-heading cont 'bold)) + +(defun shr-tag-h3 (cont) + (shr-heading cont 'italic)) + +(defun shr-tag-h4 (cont) + (shr-heading cont)) + +(defun shr-tag-h5 (cont) + (shr-heading cont)) + +(defun shr-tag-h6 (cont) + (shr-heading cont)) + +(defun shr-tag-hr (cont) + (shr-ensure-newline) + (insert (make-string shr-width shr-hr-line) "\n")) + +(defun shr-tag-title (cont) + (shr-heading cont 'bold 'underline)) + +(defun shr-tag-font (cont) + (let* ((start (point)) + (color (cdr (assq :color cont))) + (shr-stylesheet (nconc (list (cons 'color color)) + shr-stylesheet))) + (shr-generic cont) + (when color + (shr-colorize-region start (point) color + (cdr (assq 'background-color shr-stylesheet)))))) + +;;; Table rendering algorithm. + +;; Table rendering is the only complicated thing here. We do this by +;; first counting how many TDs there are in each TR, and registering +;; how wide they think they should be ("width=45%", etc). Then we +;; render each TD separately (this is done in temporary buffers, so +;; that we can use all the rendering machinery as if we were in the +;; main buffer). Now we know how much space each TD really takes, so +;; we then render everything again with the new widths, and finally +;; insert all these boxes into the main buffer. +(defun shr-tag-table-1 (cont) + (setq cont (or (cdr (assq 'tbody cont)) + cont)) + (let* ((shr-inhibit-images t) + (shr-table-depth (1+ shr-table-depth)) + (shr-kinsoku-shorten t) + ;; Find all suggested widths. + (columns (shr-column-specs cont)) + ;; Compute how many characters wide each TD should be. + (suggested-widths (shr-pro-rate-columns columns)) + ;; Do a "test rendering" to see how big each TD is (this can + ;; be smaller (if there's little text) or bigger (if there's + ;; unbreakable text). + (sketch (shr-make-table cont suggested-widths)) + (sketch-widths (shr-table-widths sketch suggested-widths))) + ;; This probably won't work very well. + (when (> (+ (loop for width across sketch-widths + summing (1+ width)) + shr-indentation 1) + (frame-width)) + (setq truncate-lines t)) + ;; Then render the table again with these new "hard" widths. + (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)) + ;; Finally, insert all the images after the table. The Emacs buffer + ;; model isn't strong enough to allow us to put the images actually + ;; into the tables. + (when (zerop shr-table-depth) + (dolist (elem (shr-find-elements cont 'img)) + (shr-tag-img (cdr elem))))) + +(defun shr-tag-table (cont) + (shr-ensure-paragraph) + (let* ((caption (cdr (assq 'caption cont))) + (header (cdr (assq 'thead cont))) + (body (or (cdr (assq 'tbody cont)) cont)) + (footer (cdr (assq 'tfoot cont))) + (bgcolor (cdr (assq :bgcolor cont))) + (start (point)) + (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) + shr-stylesheet)) + (nheader (if header (shr-max-columns header))) + (nbody (if body (shr-max-columns body))) + (nfooter (if footer (shr-max-columns footer)))) + (shr-tag-table-1 + (nconc + (if caption `((tr (td ,@caption)))) + (if header + (if footer + ;; hader + body + footer + (if (= nheader nbody) + (if (= nbody nfooter) + `((tr (td (table (tbody ,@header ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@header ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))) + (nconc `((tr (td (table (tbody ,@header))))) + (if (= nbody nfooter) + `((tr (td (table (tbody ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))))) + ;; header + body + (if (= nheader nbody) + `((tr (td (table (tbody ,@header ,@body))))) + (if (= nheader 1) + `(,@header (tr (td (table (tbody ,@body))))) + `((tr (td (table (tbody ,@header)))) + (tr (td (table (tbody ,@body)))))))) + (if footer + ;; body + footer + (if (= nbody nfooter) + `((tr (td (table (tbody ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))) + (if caption + `((tr (td (table (tbody ,@body))))) + body))))) + (when bgcolor + (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) + bgcolor)))) + +(defun shr-find-elements (cont type) + (let (result) + (dolist (elem cont) + (cond ((eq (car elem) type) + (push elem result)) + ((consp (cdr elem)) + (setq result (nconc (shr-find-elements (cdr elem) type) result))))) + (nreverse result))) + +(defun shr-insert-table (table widths) + (shr-insert-table-ruler widths) + (dolist (row table) + (let ((start (point)) + (height (let ((max 0)) + (dolist (column row) + (setq max (max max (cadr column)))) + max))) + (dotimes (i height) + (shr-indent) + (insert shr-table-vertical-line "\n")) + (dolist (column row) + (goto-char start) + (let ((lines (nth 2 column)) + (overlay-lines (nth 3 column)) + overlay overlay-line) + (dolist (line lines) + (setq overlay-line (pop overlay-lines)) + (end-of-line) + (insert line shr-table-vertical-line) + (dolist (overlay overlay-line) + (let ((o (make-overlay (- (point) (nth 0 overlay) 1) + (- (point) (nth 1 overlay) 1))) + (properties (nth 2 overlay))) + (while properties + (overlay-put o (pop properties) (pop properties))))) + (forward-line 1)) + ;; Add blank lines at padding at the bottom of the TD, + ;; possibly. + (dotimes (i (- height (length lines))) + (end-of-line) + (insert (make-string (string-width (car lines)) ? ) + shr-table-vertical-line) + (forward-line 1))))) + (shr-insert-table-ruler widths))) + +(defun shr-insert-table-ruler (widths) + (when (and (bolp) + (> shr-indentation 0)) + (shr-indent)) + (insert shr-table-corner) + (dotimes (i (length widths)) + (insert (make-string (aref widths i) shr-table-horizontal-line) + shr-table-corner)) + (insert "\n")) + +(defun shr-table-widths (table suggested-widths) + (let* ((length (length suggested-widths)) + (widths (make-vector length 0)) + (natural-widths (make-vector length 0))) + (dolist (row table) + (let ((i 0)) + (dolist (column row) + (aset widths i (max (aref widths i) + (car column))) + (aset natural-widths i (max (aref natural-widths i) + (cadr column))) + (setq i (1+ i))))) + (let ((extra (- (apply '+ (append suggested-widths nil)) + (apply '+ (append widths nil)))) + (expanded-columns 0)) + (when (> extra 0) + (dotimes (i length) + ;; If the natural width is wider than the rendered width, we + ;; want to allow the column to expand. + (when (> (aref natural-widths i) (aref widths i)) + (setq expanded-columns (1+ expanded-columns)))) + (dotimes (i length) + (when (> (aref natural-widths i) (aref widths i)) + (aset widths i (min + (1+ (aref natural-widths i)) + (+ (/ extra expanded-columns) + (aref widths i)))))))) + widths)) + +(defun shr-make-table (cont widths &optional fill) + (let ((trs nil)) + (dolist (row cont) + (when (eq (car row) 'tr) + (let ((tds nil) + (columns (cdr row)) + (i 0) + column) + (while (< i (length widths)) + (setq column (pop columns)) + (when (or (memq (car column) '(td th)) + (null column)) + (push (shr-render-td (cdr column) (aref widths i) fill) + tds) + (setq i (1+ i)))) + (push (nreverse tds) trs)))) + (nreverse trs))) + +(defun shr-render-td (cont width fill) + (with-temp-buffer + (let ((bgcolor (cdr (assq :bgcolor cont))) + (fgcolor (cdr (assq :fgcolor cont))) + (style (cdr (assq :style cont))) + (shr-stylesheet shr-stylesheet) + overlays) + (when style + (setq style (and (string-match "color" style) + (shr-parse-style style)))) + (when bgcolor + (setq style (nconc (list (cons 'background-color bgcolor)) style))) + (when fgcolor + (setq style (nconc (list (cons 'color fgcolor)) style))) + (when style + (setq shr-stylesheet (append style shr-stylesheet))) + (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) + (if cache + (progn + (insert (car cache)) + (let ((end (length (car cache)))) + (dolist (overlay (cadr cache)) + (let ((new-overlay + (make-overlay (1+ (- end (nth 0 overlay))) + (1+ (- end (nth 1 overlay))))) + (properties (nth 2 overlay))) + (while properties + (overlay-put new-overlay + (pop properties) (pop properties))))))) + (let ((shr-width width) + (shr-indentation 0)) + (shr-descend (cons 'td cont))) + (delete-region + (point) + (+ (point) + (skip-chars-backward " \t\n"))) + (push (list (cons width cont) (buffer-string) + (shr-overlays-in-region (point-min) (point-max))) + shr-content-cache))) + (goto-char (point-min)) + (let ((max 0)) + (while (not (eobp)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (when fill + (goto-char (point-min)) + ;; If the buffer is totally empty, then put a single blank + ;; line here. + (if (zerop (buffer-size)) + (insert (make-string width ? )) + ;; Otherwise, fill the buffer. + (while (not (eobp)) + (end-of-line) + (when (> (- width (current-column)) 0) + (insert (make-string (- width (current-column)) ? ))) + (forward-line 1)))) + (when style + (shr-colorize-region + (point-min) (point-max) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))) + (if fill + (list max + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (shr-collect-overlays)) + (list max + (shr-natural-width))))))) + +(defun shr-natural-width () + (goto-char (point-min)) + (let ((current 0) + (max 0)) + (while (not (eobp)) + (end-of-line) + (setq current (+ current (current-column))) + (unless (get-text-property (point) 'shr-break) + (setq max (max max current) + current 0)) + (forward-line 1)) + max)) + +(defun shr-collect-overlays () + (save-excursion + (goto-char (point-min)) + (let ((overlays nil)) + (while (not (eobp)) + (push (shr-overlays-in-region (point) (line-end-position)) + overlays) + (forward-line 1)) + (nreverse overlays)))) + +(defun shr-overlays-in-region (start end) + (let (result) + (dolist (overlay (overlays-in start end)) + (push (list (if (> start (overlay-start overlay)) + (- end start) + (- end (overlay-start overlay))) + (if (< end (overlay-end overlay)) + 0 + (- end (overlay-end overlay))) + (overlay-properties overlay)) + result)) + (nreverse result))) + +(defun shr-pro-rate-columns (columns) + (let ((total-percentage 0) + (widths (make-vector (length columns) 0))) + (dotimes (i (length columns)) + (setq total-percentage (+ total-percentage (aref columns i)))) + (setq total-percentage (/ 1.0 total-percentage)) + (dotimes (i (length columns)) + (aset widths i (max (truncate (* (aref columns i) + total-percentage + (- shr-width (1+ (length columns))))) + 10))) + widths)) + +;; Return a summary of the number and shape of the TDs in the table. +(defun shr-column-specs (cont) + (let ((columns (make-vector (shr-max-columns cont) 1))) + (dolist (row cont) + (when (eq (car row) 'tr) + (let ((i 0)) + (dolist (column (cdr row)) + (when (memq (car column) '(td th)) + (let ((width (cdr (assq :width (cdr column))))) + (when (and width + (string-match "\\([0-9]+\\)%" width)) + (aset columns i + (/ (string-to-number (match-string 1 width)) + 100.0)))) + (setq i (1+ i))))))) + columns)) + +(defun shr-count (cont elem) + (let ((i 0)) + (dolist (sub cont) + (when (eq (car sub) elem) + (setq i (1+ i)))) + i)) + +(defun shr-max-columns (cont) + (let ((max 0)) + (dolist (row cont) + (when (eq (car row) 'tr) + (setq max (max max (+ (shr-count (cdr row) 'td) + (shr-count (cdr row) 'th)))))) + max)) + +(provide 'shr) + +;;; shr.el ends here diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index fcf8bfc575..9c6af8b9df 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -43,7 +43,6 @@ ;; `sieve-manage-close' ;; close a server connection. ;; -;; `sieve-manage-authenticate' ;; `sieve-manage-listscripts' ;; `sieve-manage-deletescript' ;; `sieve-manage-getscript' @@ -51,14 +50,11 @@ ;; ;; and that's it. Example of a managesieve session in *scratch*: ;; -;; (setq my-buf (sieve-manage-open "my.server.com")) -;; " *sieve* my.server.com:2000*" +;; (with-current-buffer (sieve-manage-open "mail.example.com") +;; (sieve-manage-authenticate) +;; (sieve-manage-listscripts)) ;; -;; (sieve-manage-authenticate "myusername" "mypassword" my-buf) -;; 'auth -;; -;; (sieve-manage-listscripts my-buf) -;; ("vacation" "testscript" ("splitmail") "badscript") +;; => ((active . "main") "vacation") ;; ;; References: ;; @@ -74,7 +70,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -83,10 +79,12 @@ (require 'password)) (eval-when-compile + (require 'cl) ; caddr (require 'sasl) (require 'starttls)) (autoload 'sasl-find-mechanism "sasl") (autoload 'starttls-open-stream "starttls") +(autoload 'auth-source-user-or-password "auth-source") ;; User customizable variables: @@ -100,11 +98,6 @@ :type 'string :group 'sieve-manage) -(defcustom sieve-manage-default-user (user-login-name) - "Default username to use." - :type 'string - :group 'sieve-manage) - (defcustom sieve-manage-server-eol "\r\n" "The EOL string sent from the server." :type 'string @@ -158,31 +151,32 @@ for doing the actual authentication." :group 'sieve-manage) (defcustom sieve-manage-default-port 2000 - "Default port number for managesieve protocol." + "Default port number or service name for managesieve protocol." :type 'integer :group 'sieve-manage) +(defcustom sieve-manage-default-stream 'network + "Default stream type to use for `sieve-manage'. +Must be a name of a stream in `sieve-manage-stream-alist'." + :type 'symbol + :group 'sieve-manage) + ;; Internal variables: (defconst sieve-manage-local-variables '(sieve-manage-server sieve-manage-port sieve-manage-auth sieve-manage-stream - sieve-manage-username - sieve-manage-password sieve-manage-process sieve-manage-client-eol sieve-manage-server-eol sieve-manage-capability)) -(defconst sieve-manage-default-stream 'network) (defconst sieve-manage-coding-system-for-read 'binary) (defconst sieve-manage-coding-system-for-write 'binary) (defvar sieve-manage-stream nil) (defvar sieve-manage-auth nil) (defvar sieve-manage-server nil) (defvar sieve-manage-port nil) -(defvar sieve-manage-username nil) -(defvar sieve-manage-password nil) (defvar sieve-manage-state 'closed "Managesieve state. Valid states are `closed', `initial', `nonauth', and `auth'.") @@ -191,65 +185,10 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") ;; Internal utility functions -(defsubst sieve-manage-disable-multibyte () +(defmacro sieve-manage-disable-multibyte () "Enable multibyte in the current buffer." - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil))) - -(declare-function password-read "password-cache" (prompt &optional key)) -(declare-function password-cache-add "password-cache" (key password)) -(declare-function password-cache-remove "password-cache" (key)) - -;; Uses the dynamically bound `reason' variable. -(defvar reason) -(defun sieve-manage-interactive-login (buffer loginfunc) - "Login to server in BUFFER. -LOGINFUNC is passed a username and a password, it should return t if -it was successful authenticating itself to the server, nil otherwise. -Returns t if login was successful, nil otherwise." - (with-current-buffer buffer - (make-local-variable 'sieve-manage-username) - (make-local-variable 'sieve-manage-password) - (let (user passwd ret reason passwd-key) - (condition-case () - (while (or (not user) (not passwd)) - (setq user (or sieve-manage-username - (read-from-minibuffer - (concat "Managesieve username for " - sieve-manage-server ": ") - (or user sieve-manage-default-user))) - passwd-key (concat "managesieve:" user "@" sieve-manage-server - ":" sieve-manage-port) - passwd (or sieve-manage-password - (password-read (concat "Managesieve password for " - user "@" sieve-manage-server - ": ") - passwd-key))) - (when (y-or-n-p "Store password for this session? ") - (password-cache-add passwd-key (copy-sequence passwd))) - (when (and user passwd) - (if (funcall loginfunc user passwd) - (setq ret t - sieve-manage-username user) - (if reason - (message "Login failed (reason given: %s)..." reason) - (message "Login failed...")) - (password-cache-remove passwd-key) - (setq sieve-manage-password nil) - (setq passwd nil) - (setq reason nil) - (sit-for 1)))) - (quit (with-current-buffer buffer - (password-cache-remove passwd-key) - (setq user nil - passwd nil - sieve-manage-password nil))) - (error (with-current-buffer buffer - (password-cache-remove passwd-key) - (setq user nil - passwd nil - sieve-manage-password nil)))) - ret))) + (unless (featurep 'xemacs) + '(set-buffer-multibyte nil))) (defun sieve-manage-erase (&optional p buffer) (let ((buffer (or buffer (current-buffer)))) @@ -331,70 +270,72 @@ Returns t if login was successful, nil otherwise." process))) ;; Authenticators - (defun sieve-sasl-auth (buffer mech) "Login to server using the SASL MECH method." (message "sieve: Authenticating using %s..." mech) - (if (sieve-manage-interactive-login - buffer - (lambda (user passwd) - (let (client step tag data rsp) - (setq client (sasl-make-client (sasl-find-mechanism (list mech)) - user "sieve" sieve-manage-server)) - (setq sasl-read-passphrase (function (lambda (prompt) passwd))) - (setq step (sasl-next-step client nil)) - (setq tag - (sieve-manage-send - (concat - "AUTHENTICATE \"" - mech - "\"" - (and (sasl-step-data step) - (concat - " \"" - (base64-encode-string - (sasl-step-data step) - 'no-line-break) - "\""))))) - (catch 'done - (while t - (setq rsp nil) - (goto-char (point-min)) - (while (null (or (progn - (setq rsp (sieve-manage-is-string)) - (if (not (and rsp (looking-at - sieve-manage-server-eol))) - (setq rsp nil) - (goto-char (match-end 0)) - rsp)) - (setq rsp (sieve-manage-is-okno)))) - (accept-process-output sieve-manage-process 1) - (goto-char (point-min))) - (sieve-manage-erase) - (when (sieve-manage-ok-p rsp) - (when (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)) - (sasl-step-set-data - step (base64-decode-string (match-string 1 (cadr rsp))))) - (if (and (setq step (sasl-next-step client step)) - (setq data (sasl-step-data step))) - ;; We got data for server but it's finished - (error "Server not ready for SASL data: %s" data) - ;; The authentication process is finished. - (throw 'done t))) - (unless (stringp rsp) - (apply 'error "Server aborted SASL authentication: %s %s %s" - rsp)) - (sasl-step-set-data step (base64-decode-string rsp)) - (setq step (sasl-next-step client step)) - (sieve-manage-send - (if (sasl-step-data step) - (concat "\"" - (base64-encode-string (sasl-step-data step) - 'no-line-break) - "\"") - ""))))))) - (message "sieve: Authenticating using %s...done" mech) - (message "sieve: Authenticating using %s...failed" mech))) + (with-current-buffer buffer + (let* ((user-password (auth-source-user-or-password + '("login" "password") + sieve-manage-server + "sieve" nil t)) + (client (sasl-make-client (sasl-find-mechanism (list mech)) + (car user-password) "sieve" sieve-manage-server)) + (sasl-read-passphrase + ;; We *need* to copy the password, because sasl will modify it + ;; somehow. + `(lambda (prompt) ,(copy-sequence (cadr user-password)))) + (step (sasl-next-step client nil)) + (tag (sieve-manage-send + (concat + "AUTHENTICATE \"" + mech + "\"" + (and (sasl-step-data step) + (concat + " \"" + (base64-encode-string + (sasl-step-data step) + 'no-line-break) + "\""))))) + data rsp) + (catch 'done + (while t + (setq rsp nil) + (goto-char (point-min)) + (while (null (or (progn + (setq rsp (sieve-manage-is-string)) + (if (not (and rsp (looking-at + sieve-manage-server-eol))) + (setq rsp nil) + (goto-char (match-end 0)) + rsp)) + (setq rsp (sieve-manage-is-okno)))) + (accept-process-output sieve-manage-process 1) + (goto-char (point-min))) + (sieve-manage-erase) + (when (sieve-manage-ok-p rsp) + (when (and (cadr rsp) + (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp))) + (sasl-step-set-data + step (base64-decode-string (match-string 1 (cadr rsp))))) + (if (and (setq step (sasl-next-step client step)) + (setq data (sasl-step-data step))) + ;; We got data for server but it's finished + (error "Server not ready for SASL data: %s" data) + ;; The authentication process is finished. + (throw 'done t))) + (unless (stringp rsp) + (error "Server aborted SASL authentication: %s" (caddr rsp))) + (sasl-step-set-data step (base64-decode-string rsp)) + (setq step (sasl-next-step client step)) + (sieve-manage-send + (if (sasl-step-data step) + (concat "\"" + (base64-encode-string (sasl-step-data step) + 'no-line-break) + "\"") + "")))) + (message "sieve: Login using %s...done" mech)))) (defun sieve-manage-cram-md5-p (buffer) (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) @@ -449,13 +390,14 @@ Optional argument AUTH indicates authenticator to use, see If nil, chooses the best stream the server is capable of. Optional argument BUFFER is buffer (buffer, or string naming buffer) to work in." - (setq buffer (or buffer (format " *sieve* %s:%d" server (or port 2000)))) + (or port (setq port sieve-manage-default-port)) + (setq buffer (or buffer (format " *sieve* %s:%s" server port))) (with-current-buffer (get-buffer-create buffer) (mapc 'make-local-variable sieve-manage-local-variables) (sieve-manage-disable-multibyte) (buffer-disable-undo) (setq sieve-manage-server (or server sieve-manage-server)) - (setq sieve-manage-port (or port sieve-manage-port)) + (setq sieve-manage-port port) (setq sieve-manage-stream (or stream sieve-manage-stream)) (message "sieve: Connecting to %s..." sieve-manage-server) (if (let ((sieve-manage-stream @@ -506,6 +448,17 @@ to work in." (sieve-manage-erase) buffer))) +(defun sieve-manage-authenticate (&optional buffer) + "Authenticate on server in BUFFER. +Return `sieve-manage-state' value." + (with-current-buffer (or buffer (current-buffer)) + (if (eq sieve-manage-state 'nonauth) + (when (funcall (nth 2 (assq sieve-manage-auth + sieve-manage-authenticator-alist)) + (current-buffer)) + (setq sieve-manage-state 'auth)) + sieve-manage-state))) + (defun sieve-manage-opened (&optional buffer) "Return non-nil if connection to managesieve server in BUFFER is open. If BUFFER is nil then the current buffer is used." @@ -529,32 +482,19 @@ If BUFFER is nil, the current buffer is used." (sieve-manage-erase) t)) -(defun sieve-manage-authenticate (&optional user passwd buffer) - "Authenticate to server in BUFFER, using current buffer if nil. -It uses the authenticator specified when opening the server. If the -authenticator requires username/passwords, they are queried from the -user and optionally stored in the buffer. If USER and/or PASSWD is -specified, the user will not be questioned and the username and/or -password is remembered in the buffer." - (with-current-buffer (or buffer (current-buffer)) - (if (not (eq sieve-manage-state 'nonauth)) - (eq sieve-manage-state 'auth) - (make-local-variable 'sieve-manage-username) - (make-local-variable 'sieve-manage-password) - (if user (setq sieve-manage-username user)) - (if passwd (setq sieve-manage-password passwd)) - (if (funcall (nth 2 (assq sieve-manage-auth - sieve-manage-authenticator-alist)) buffer) - (setq sieve-manage-state 'auth))))) - (defun sieve-manage-capability (&optional name value buffer) + "Check if capability NAME of server BUFFER match VALUE. +If it does, return the server value of NAME. If not returns nil. +If VALUE is nil, do not check VALUE and return server value. +If NAME is nil, return the full server list of capabilities." (with-current-buffer (or buffer (current-buffer)) (if (null name) sieve-manage-capability - (if (null value) - (nth 1 (assoc name sieve-manage-capability)) - (when (string-match value (nth 1 (assoc name sieve-manage-capability))) - (nth 1 (assoc name sieve-manage-capability))))))) + (let ((server-value (cadr (assoc name sieve-manage-capability)))) + (when (or (null value) + (and server-value + (string-match value server-value))) + server-value))))) (defun sieve-manage-listscripts (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -701,5 +641,4 @@ password is remembered in the buffer." (provide 'sieve-manage) -;; arch-tag: 321c4640-1371-4495-9baf-8ccb71dd5bd1 ;; sieve-manage.el ends here diff --git a/lisp/gnus/sieve-mode.el b/lisp/gnus/sieve-mode.el index dfbfdde6b5..6acb6e74fb 100644 --- a/lisp/gnus/sieve-mode.el +++ b/lisp/gnus/sieve-mode.el @@ -49,7 +49,6 @@ (autoload 'sieve-manage "sieve") (autoload 'sieve-upload "sieve") -(require 'easymenu) (eval-when-compile (require 'font-lock)) @@ -186,6 +185,7 @@ "Menubar used in sieve mode.") ;; Code for Sieve editing mode. +(autoload 'easy-menu-add-item "easymenu") ;;;###autoload (define-derived-mode sieve-mode c-mode "Sieve" @@ -216,5 +216,4 @@ Turning on Sieve mode runs `sieve-mode-hook'." (provide 'sieve-mode) -;; arch-tag: 3b8ab76d-065d-4c52-b1e8-ab2ec21f2ace ;; sieve-mode.el ends here diff --git a/lisp/gnus/sieve.el b/lisp/gnus/sieve.el index 6f235eecf6..825bdd65ec 100644 --- a/lisp/gnus/sieve.el +++ b/lisp/gnus/sieve.el @@ -320,11 +320,13 @@ Server : " server ":" (or port "2000") " (insert "\n")))) (defun sieve-open-server (server &optional port) - ;; open server - (set (make-local-variable 'sieve-manage-buffer) - (sieve-manage-open server)) - ;; authenticate - (sieve-manage-authenticate nil nil sieve-manage-buffer)) + "Open SERVER (on PORT) and authenticate." + (with-current-buffer + (or ;; open server + (set (make-local-variable 'sieve-manage-buffer) + (sieve-manage-open server)) + (error "Error opening server %s" server)) + (sieve-manage-authenticate))) (defun sieve-refresh-scriptlist () (interactive) @@ -380,5 +382,4 @@ Server : " server ":" (or port "2000") " (provide 'sieve) -;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94 ;; sieve.el ends here diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index 0692966fbf..00c221fcb6 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -102,7 +102,8 @@ is nil, use `smiley-style'." ;; The XEmacs version has a baroque, if not rococo, set of these. (defcustom smiley-regexp-alist - '(("\\(;-?)\\)\\W" 1 "blink") + '(("\\(;-)\\)\\W" 1 "blink") + ("[^;]\\(;)\\)\\W" 1 "blink") ("\\(:-]\\)\\W" 1 "forced") ("\\(8-)\\)\\W" 1 "braindamaged") ("\\(:-|\\)\\W" 1 "indifferent") @@ -119,6 +120,7 @@ is nil, use `smiley-style'." The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in regexp to replace with IMAGE. IMAGE is the name of an image file in `smiley-data-directory'." + :version "24.1" :type '(repeat (list regexp (integer :tag "Regexp match number") (string :tag "Image name"))) @@ -226,5 +228,4 @@ With arg, turn displaying on if and only if arg is positive." (provide 'smiley) -;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818 ;;; smiley.el ends here diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index 0ae7bbb5c8..c25c9c669a 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -119,7 +119,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'dig) @@ -371,12 +371,9 @@ KEYFILE should contain a PEM encoded key and certificate." (if keyfile keyfile (smime-get-key-with-certs-by-email - (completing-read - (concat "Sign using key" - (if smime-keys - (concat " (default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil (car-safe (car-safe smime-keys)))))) + (gnus-completing-read + "Sign using key" + smime-keys nil (car-safe (car-safe smime-keys)))))) (error "Signing failed")))) (defun smime-encrypt-buffer (&optional certfiles buffer) @@ -429,10 +426,9 @@ Any details (stdout and stderr) are left in the buffer specified by (insert-buffer-substring smime-details-buffer) nil)) -(defvar from) - -(defun smime-decrypt-region (b e keyfile) +(defun smime-decrypt-region (b e keyfile &optional from) "Decrypt S/MIME message in region between B and E with key in KEYFILE. +Optional FROM specifies sender's mail address. On success, replaces region with decrypted data and return non-nil. Any details (stderr on success, stdout and stderr on error) are left in the buffer specified by `smime-details-buffer'." @@ -455,8 +451,7 @@ in the buffer specified by `smime-details-buffer'." (delete-file tmpfile))) (progn (delete-region b e) - (when (boundp 'from) - ;; `from' is dynamically bound in mm-dissect. + (when from (insert "From: " from "\n")) (insert-buffer-substring buffer) (kill-buffer buffer) @@ -502,11 +497,9 @@ in the buffer specified by `smime-details-buffer'." (expand-file-name (or keyfile (smime-get-key-by-email - (completing-read - (concat "Decipher using key" - (if smime-keys (concat " (default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil (car-safe (car-safe smime-keys))))))))) + (gnus-completing-read + "Decipher using key" + smime-keys nil (car-safe (car-safe smime-keys))))))))) ;; Various operations @@ -592,17 +585,20 @@ A string or a list of strings is returned." (kill-buffer digbuf) retbuf)) +(declare-function ldap-search "ldap" + (filter &optional host attributes attrsonly withdn)) + (defun smime-cert-by-ldap-1 (mail host) "Get cetificate for MAIL from the ldap server at HOST." (let ((ldapresult (funcall - (if (or (featurep 'xemacs) - ;; For Emacs >= 22 we don't need smime-ldap.el - (< emacs-major-version 22)) + (if (featurep 'xemacs) (progn (require 'smime-ldap) 'smime-ldap-search) - 'ldap-search) + (progn + (require 'ldap) + 'ldap-search)) (concat "mail=" mail) host '("userCertificate") nil)) (retbuf (generate-new-buffer (format "*certificate for %s*" mail))) @@ -649,19 +645,18 @@ A string or a list of strings is returned." (defvar smime-buffer "*SMIME*") -(defvar smime-mode-map nil) -(put 'smime-mode 'mode-class 'special) - -(unless smime-mode-map - (setq smime-mode-map (make-sparse-keymap)) - (suppress-keymap smime-mode-map) +(defvar smime-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'smime-exit) + (define-key map "f" 'smime-certificate-info) + map)) - (define-key smime-mode-map "q" 'smime-exit) - (define-key smime-mode-map "f" 'smime-certificate-info)) +(autoload 'gnus-completing-read "gnus-util") -(autoload 'gnus-run-mode-hooks "gnus-util") - -(defun smime-mode () +(put 'smime-mode 'mode-class 'special) +(define-derived-mode smime-mode fundamental-mode ;special-mode + "SMIME" "Major mode for browsing, viewing and fetching certificates. All normal editing commands are switched off. @@ -670,16 +665,10 @@ All normal editing commands are switched off. The following commands are available: \\{smime-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'smime-mode) - (setq mode-name "SMIME") (setq mode-line-process nil) - (use-local-map smime-mode-map) (buffer-disable-undo) (setq truncate-lines t) - (setq buffer-read-only t) - (gnus-run-mode-hooks 'smime-mode-hook)) + (setq buffer-read-only t)) (defun smime-certificate-info (certfile) (interactive "fCertificate file: ") @@ -708,8 +697,7 @@ The following commands are available: "Go to the SMIME buffer." (interactive) (unless (get-buffer smime-buffer) - (save-excursion - (set-buffer (get-buffer-create smime-buffer)) + (with-current-buffer (get-buffer-create smime-buffer) (smime-mode))) (smime-draw-buffer) (switch-to-buffer smime-buffer)) @@ -729,5 +717,4 @@ The following commands are available: (provide 'smime) -;; arch-tag: e3f9b938-5085-4510-8a11-6625269c9a9e ;;; smime.el ends here diff --git a/lisp/gnus/spam-report.el b/lisp/gnus/spam-report.el index 4b492f02fa..fd37bf17c7 100644 --- a/lisp/gnus/spam-report.el +++ b/lisp/gnus/spam-report.el @@ -95,12 +95,12 @@ undo that change.") "Report an article as spam by resending via email. Reports is as ham when HAM is set." (dolist (article articles) - (gnus-message 6 + (gnus-message 6 "Reporting %s article %d to <%s>..." (if ham "ham" "spam") article spam-report-resend-to) (unless spam-report-resend-to - (customize-set-variable + (customize-set-variable spam-report-resend-to (read-from-minibuffer "email address to resend SPAM/HAM to? "))) ;; This is ganked from the `gnus-summary-resend-message' function. @@ -109,8 +109,7 @@ Reports is as ham when HAM is set." ;; select this particular article (gnus-summary-select-article nil nil nil article) ;; resend it to the destination address - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (message-resend spam-report-resend-to)))) (defun spam-report-resend-ham (articles) @@ -257,6 +256,7 @@ This is initialized based on `user-mail-address'." 80)) (error "Could not open connection to %s" host)) (set-marker (process-mark tcp-connection) (point-min)) + (gnus-set-process-query-on-exit-flag tcp-connection nil) (process-send-string tcp-connection (format "GET %s HTTP/1.1\nUser-Agent: %s\nHost: %s\n\n" @@ -267,7 +267,7 @@ This is initialized based on `user-mail-address'." (gnus-message 7 "Waiting for response from %s..." host) (while (and (memq (process-status tcp-connection) '(open run)) (zerop (buffer-size))) - (accept-process-output tcp-connection)) + (accept-process-output tcp-connection 1)) (gnus-message 7 "Waiting for response from %s... done" host))))) ;;;###autoload @@ -292,8 +292,7 @@ symbol `ask', query before flushing the queue file." (gnus-message 7 "Processing requests using `%s'." spam-report-url-ping-function)) (or file (setq file spam-report-requests-file)) - (save-excursion - (set-buffer (find-file-noselect file)) + (with-current-buffer (find-file-noselect file) (goto-char (point-min)) (while (and (not (eobp)) (re-search-forward @@ -385,5 +384,4 @@ Process queued spam reports." (provide 'spam-report) -;; arch-tag: f6683295-ec89-4ab5-8803-8cc842293022 ;;; spam-report.el ends here. diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el index afa0d502bc..eeb112f29b 100644 --- a/lisp/gnus/spam-stat.el +++ b/lisp/gnus/spam-stat.el @@ -557,6 +557,8 @@ check the variable `spam-stat-score-data'." (when (re-search-forward "^Xref:.*\n" nil t) (delete-region (match-beginning 0) (match-end 0))))) +(autoload 'time-to-number-of-days "time-date") + (defun spam-stat-process-directory (dir func) "Process all the regular files in directory DIR using function FUNC." (let* ((files (directory-files dir t "^[^.]")) @@ -671,5 +673,4 @@ COUNT defaults to 5" (provide 'spam-stat) -;; arch-tag: ff1d2200-8ddb-42fb-bb7b-1b5e20448554 ;;; spam-stat.el ends here diff --git a/lisp/gnus/spam-wash.el b/lisp/gnus/spam-wash.el index 585f78d6d4..01c584969b 100644 --- a/lisp/gnus/spam-wash.el +++ b/lisp/gnus/spam-wash.el @@ -69,5 +69,4 @@ (provide 'spam-wash) -;; arch-tag: 3c7f94a7-c96d-4c77-bb59-950df12bc85f ;;; spam-wash.el ends here diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 8d7ed9fdd0..194668e8dc 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -39,15 +39,15 @@ ;;{{{ compilation directives and autoloads/requires -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) -(require 'message) ;for the message-fetch-field functions +(require 'message) ;for the message-fetch-field functions (require 'gnus-sum) -(require 'gnus-uu) ; because of key prefix issues +(require 'gnus-uu) ; because of key prefix issues ;;; for the definitions of group content classification and spam processors (require 'gnus) @@ -93,12 +93,16 @@ Populated by `spam-install-backend-super'.") "Exit behavior at the time of summary exit. Note that setting the `spam-use-move' or `spam-use-copy' backends on a group through group/topic parameters overrides this mechanism." - :type '(choice (const 'default :tag - "Move spam out of all groups. Move ham out of spam groups.") - (const 'move-all :tag - "Move spam out of all groups. Move ham out of all groups.") - (const 'move-none :tag - "Never move spam or ham out of any groups.")) + :type '(choice + (const + 'default + :tag "Move spam out of all groups and ham out of spam groups.") + (const + 'move-all + :tag "Move spam out of all groups and ham out of all groups.") + (const + 'move-none + :tag "Never move spam or ham out of any groups.")) :group 'spam) (defcustom spam-directory (nnheader-concat gnus-directory "spam/") @@ -296,27 +300,27 @@ them." :group 'spam) (defcustom spam-install-hooks (or - spam-use-dig - spam-use-gmane-xref - spam-use-blacklist - spam-use-whitelist - spam-use-whitelist-exclusive - spam-use-blackholes - spam-use-hashcash - spam-use-regex-headers - spam-use-regex-body - spam-use-bogofilter - spam-use-bogofilter-headers - spam-use-spamassassin - spam-use-spamassassin-headers - spam-use-bsfilter - spam-use-bsfilter-headers - spam-use-BBDB - spam-use-BBDB-exclusive - spam-use-ifile - spam-use-stat - spam-use-spamoracle - spam-use-crm114) + spam-use-dig + spam-use-gmane-xref + spam-use-blacklist + spam-use-whitelist + spam-use-whitelist-exclusive + spam-use-blackholes + spam-use-hashcash + spam-use-regex-headers + spam-use-regex-body + spam-use-bogofilter + spam-use-bogofilter-headers + spam-use-spamassassin + spam-use-spamassassin-headers + spam-use-bsfilter + spam-use-bsfilter-headers + spam-use-BBDB + spam-use-BBDB-exclusive + spam-use-ifile + spam-use-stat + spam-use-spamoracle + spam-use-crm114) "Whether the spam hooks should be installed. Default to t if one of the spam-use-* variables is set." :group 'spam @@ -330,8 +334,8 @@ Default to t if one of the spam-use-* variables is set." ;;; TODO: deprecate this variable, it's confusing since it's a list of strings, ;;; not regular expressions (defcustom spam-junk-mailgroups (cons - spam-split-group - '("mail.junk" "poste.pourriel")) + spam-split-group + '("mail.junk" "poste.pourriel")) "Mailgroups with spam contents. All unmarked article in such group receive the spam mark on group entry." :type '(repeat (string :tag "Group")) @@ -345,7 +349,7 @@ Only meaningful if you enable `spam-use-gmane-xref'." :group 'spam) (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org" - "dev.null.dk" "relays.visi.com") + "dev.null.dk" "relays.visi.com") "List of blackhole servers. Only meaningful if you enable `spam-use-blackholes'." :type '(repeat (string :tag "Server")) @@ -405,9 +409,9 @@ Only meaningful if you enable `spam-use-regex-body'." (defcustom spam-summary-score-preferred-header nil "Preferred header to use for `spam-summary-score'." :type '(choice :tag "Header name" - (symbol :tag "SpamAssassin etc" X-Spam-Status) - (symbol :tag "Bogofilter" X-Bogosity) - (const :tag "No preference, take best guess." nil)) + (symbol :tag "SpamAssassin etc" X-Spam-Status) + (symbol :tag "Bogofilter" X-Bogosity) + (const :tag "No preference, take best guess." nil)) :group 'spam) (defgroup spam-ifile nil @@ -419,7 +423,7 @@ Only meaningful if you enable `spam-use-regex-body'." (defcustom spam-ifile-program (executable-find "ifile") "Name of the ifile program." :type '(choice (file :tag "Location of ifile") - (const :tag "ifile is not installed")) + (const :tag "ifile is not installed")) :group 'spam-ifile) (make-obsolete-variable 'spam-ifile-database-path 'spam-ifile-database @@ -427,7 +431,7 @@ Only meaningful if you enable `spam-use-regex-body'." (defcustom spam-ifile-database nil "File name of the ifile database." :type '(choice (file :tag "Location of the ifile database") - (const :tag "Use the default")) + (const :tag "Use the default")) :group 'spam-ifile) (defcustom spam-ifile-spam-category "spam" @@ -439,7 +443,7 @@ Only meaningful if you enable `spam-use-regex-body'." "Name of the ham ifile category. If nil, the current group name will be used." :type '(choice (string :tag "Use a fixed category") - (const :tag "Use the current group name")) + (const :tag "Use the current group name")) :group 'spam-ifile) (defcustom spam-ifile-all-categories nil @@ -458,7 +462,7 @@ your main source of newsgroup names." (defcustom spam-bogofilter-program (executable-find "bogofilter") "Name of the Bogofilter program." :type '(choice (file :tag "Location of bogofilter") - (const :tag "Bogofilter is not installed")) + (const :tag "Bogofilter is not installed")) :group 'spam-bogofilter) (defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?") @@ -497,8 +501,8 @@ your main source of newsgroup names." "Location of the Bogofilter database. When nil, use the default location." :type '(choice (directory - :tag "Location of the Bogofilter database directory") - (const :tag "Use the default")) + :tag "Location of the Bogofilter database directory") + (const :tag "Use the default")) :group 'spam-bogofilter) (defgroup spam-bsfilter nil @@ -510,7 +514,7 @@ When nil, use the default location." (defcustom spam-bsfilter-program (executable-find "bsfilter") "Name of the Bsfilter program." :type '(choice (file :tag "Location of bsfilter") - (const :tag "Bsfilter is not installed")) + (const :tag "Bsfilter is not installed")) :group 'spam-bsfilter) (defcustom spam-bsfilter-header "X-Spam-Flag" @@ -546,8 +550,8 @@ When nil, use the default location." (defcustom spam-bsfilter-database-directory nil "Directory path of the Bsfilter databases." :type '(choice (directory - :tag "Location of the Bsfilter database directory") - (const :tag "Use the default")) + :tag "Location of the Bsfilter database directory") + (const :tag "Use the default")) :group 'spam-bsfilter) (defgroup spam-spamoracle nil @@ -558,13 +562,13 @@ When nil, use the default location." "Location of spamoracle database file. When nil, use the default spamoracle database." :type '(choice (directory :tag "Location of spamoracle database file.") - (const :tag "Use the default")) + (const :tag "Use the default")) :group 'spam-spamoracle) (defcustom spam-spamoracle-binary (executable-find "spamoracle") "Location of the spamoracle binary." :type '(choice (directory :tag "Location of the spamoracle binary") - (const :tag "Use the default")) + (const :tag "Use the default")) :group 'spam-spamoracle) (defgroup spam-spamassassin nil @@ -578,7 +582,7 @@ When nil, use the default spamoracle database." Hint: set this to \"spamc\" if you have spamd running. See the spamc and spamd man pages for more information on these programs." :type '(choice (file :tag "Location of spamc") - (const :tag "spamassassin is not installed")) + (const :tag "spamassassin is not installed")) :group 'spam-spamassassin) (defcustom spam-spamassassin-arguments () @@ -608,7 +612,7 @@ identification" (defcustom spam-sa-learn-program (executable-find "sa-learn") "Name of the sa-learn program." :type '(choice (file :tag "Location of spamassassin") - (const :tag "spamassassin is not installed")) + (const :tag "spamassassin is not installed")) :group 'spam-spamassassin) (defcustom spam-sa-learn-rebuild t @@ -642,7 +646,7 @@ order for SpamAssassin to recognize the new registered spam." (defcustom spam-crm114-program (executable-find "mailfilter.crm") "File path of the CRM114 Mailfilter executable program." :type '(choice (file :tag "Location of CRM114 Mailfilter") - (const :tag "CRM114 Mailfilter is not installed")) + (const :tag "CRM114 Mailfilter is not installed")) :group 'spam-crm114) (defcustom spam-crm114-header "X-CRM114-Status" @@ -678,8 +682,8 @@ order for SpamAssassin to recognize the new registered spam." (defcustom spam-crm114-database-directory nil "Directory path of the CRM114 Mailfilter databases." :type '(choice (directory - :tag "Location of the CRM114 Mailfilter database directory") - (const :tag "Use the default")) + :tag "Location of the CRM114 Mailfilter database directory") + (const :tag "Use the default")) :group 'spam-crm114) ;;; Key bindings for spam control. @@ -689,14 +693,15 @@ order for SpamAssassin to recognize the new registered spam." "Sx" gnus-summary-mark-as-spam "Mst" spam-generic-score "Msx" gnus-summary-mark-as-spam - "\M-d" gnus-summary-mark-as-spam) + "\M-d" gnus-summary-mark-as-spam + "$" gnus-summary-mark-as-spam) (defvar spam-cache-lookups t "Whether spam.el will try to cache lookups using `spam-caches'.") (defvar spam-caches (make-hash-table - :size 10 - :test 'equal) + :size 10 + :test 'equal) "Cache of spam detection entries.") (defvar spam-old-articles nil @@ -735,11 +740,11 @@ When either list is nil, the other is returned." (if (and list1 list2) ;; we have two non-nil lists (progn - (dolist (item (append list1 list2)) - (when (and (memq item list1) (memq item list2)) - (setq list1 (delq item list1)) - (setq list2 (delq item list2)))) - (append list1 list2)) + (dolist (item (append list1 list2)) + (when (and (memq item list1) (memq item list2)) + (setq list1 (delq item list1)) + (setq list2 (delq item list2)))) + (append list1 list2)) ;; if either of the lists was nil, return the other one (if list1 list1 list2))) @@ -747,9 +752,9 @@ When either list is nil, the other is returned." "Checks if MARK is considered a ham mark in GROUP." (when (stringp group) (let* ((marks (spam-group-ham-marks group spam)) - (marks (if (symbolp mark) - marks - (mapcar 'symbol-value marks)))) + (marks (if (symbolp mark) + marks + (mapcar 'symbol-value marks)))) (memq mark marks)))) (defun spam-group-spam-mark-p (group mark) @@ -760,10 +765,10 @@ When either list is nil, the other is returned." "In GROUP, get all the ham marks." (when (stringp group) (let* ((marks (if spam - (gnus-parameter-spam-marks group) - (gnus-parameter-ham-marks group))) - (marks (car marks)) - (marks (if (listp (car marks)) (car marks) marks))) + (gnus-parameter-spam-marks group) + (gnus-parameter-ham-marks group))) + (marks (car marks)) + (marks (if (listp (car marks)) (car marks) marks))) marks))) (defun spam-group-spam-marks (group) @@ -774,15 +779,15 @@ When either list is nil, the other is returned." "Is GROUP a spam group?" (if (and (stringp group) (< 0 (length group))) (or (member group spam-junk-mailgroups) - (memq 'gnus-group-spam-classification-spam - (gnus-parameter-spam-contents group))) + (memq 'gnus-group-spam-classification-spam + (gnus-parameter-spam-contents group))) nil)) (defun spam-group-ham-contents-p (group) "Is GROUP a ham group?" (if (stringp group) (memq 'gnus-group-spam-classification-ham - (gnus-parameter-spam-contents group)) + (gnus-parameter-spam-contents group)) nil)) (defun spam-classifications () @@ -811,20 +816,20 @@ When either list is nil, the other is returned." (defun spam-list-articles (articles classification) (let ((mark-check (if (eq classification 'spam) - 'spam-group-spam-mark-p - 'spam-group-ham-mark-p)) - alist mark-cache-yes mark-cache-no) + 'spam-group-spam-mark-p + 'spam-group-ham-mark-p)) + alist mark-cache-yes mark-cache-no) (dolist (article articles) (let ((mark (gnus-summary-article-mark article))) - (unless (or (memq mark mark-cache-yes) - (memq mark mark-cache-no)) - (if (funcall mark-check - gnus-newsgroup-name - mark) - (push mark mark-cache-yes) - (push mark mark-cache-no))) - (when (memq mark mark-cache-yes) - (push article alist)))) + (unless (or (memq mark mark-cache-yes) + (memq mark mark-cache-no)) + (if (funcall mark-check + gnus-newsgroup-name + mark) + (push mark mark-cache-yes) + (push mark mark-cache-no))) + (when (memq mark mark-cache-yes) + (push article alist)))) alist)) ;;}}} @@ -840,13 +845,13 @@ backend is STATISTICAL." (setq spam-backends (add-to-list 'spam-backends backend)) (while properties (let ((property (pop properties)) - (value (pop properties))) + (value (pop properties))) (if (spam-backend-property-valid-p property) - (put backend property value) - (gnus-error - 5 - "spam-install-backend-super got an invalid property %s" - property))))) + (put backend property value) + (gnus-error + 5 + "spam-install-backend-super got an invalid property %s" + property))))) (defun spam-backend-list (&optional type) "Return a list of all the backend symbols, constrained by TYPE. @@ -855,16 +860,16 @@ When TYPE is 'mover, only mover backends are returned." (let (list) (dolist (backend spam-backends) (when (or - (null type) ;either no type was requested - ;; or the type is 'mover and the backend is a mover - (and - (eq type 'mover) - (spam-backend-mover-p backend)) - ;; or the type is 'non-mover and the backend is not a mover - (and - (eq type 'non-mover) - (not (spam-backend-mover-p backend)))) - (push backend list))) + (null type) ;either no type was requested + ;; or the type is 'mover and the backend is a mover + (and + (eq type 'mover) + (spam-backend-mover-p backend)) + ;; or the type is 'non-mover and the backend is not a mover + (and + (eq type 'non-mover) + (not (spam-backend-mover-p backend)))) + (push backend list))) list)) (defun spam-backend-check (backend) @@ -888,16 +893,16 @@ that the message is definitely a spam." "Return information about BACKEND." (if (spam-backend-valid-p backend) (let (info) - (setq info (format "Backend %s has the following properties:\n" - backend)) - (dolist (property (spam-backend-properties)) - (setq info (format "%s%s=%s\n" - info - property - (get backend property)))) - info) + (setq info (format "Backend %s has the following properties:\n" + backend)) + (dolist (property (spam-backend-properties)) + (setq info (format "%s%s=%s\n" + info + property + (get backend property)))) + info) (gnus-error 5 "spam-backend-info was asked about an invalid backend %s" - backend))) + backend))) (defun spam-backend-function (backend classification type) "Get the BACKEND function for CLASSIFICATION and TYPE. @@ -907,11 +912,11 @@ CLASSIFICATION is 'ham or 'spam." (spam-classification-valid-p classification) (spam-backend-function-type-valid-p type)) (let ((retrieval - (intern - (format "spam-backend-%s-%s-function" - classification - type)))) - (funcall retrieval backend)) + (intern + (format "spam-backend-%s-%s-function" + classification + type)))) + (funcall retrieval backend)) (gnus-error 5 "%s was passed invalid backend %s, classification %s, or type %s" @@ -921,15 +926,15 @@ CLASSIFICATION is 'ham or 'spam." type))) (defun spam-backend-article-list-property (classification - &optional unregister) + &optional unregister) "Property name of article list with CLASSIFICATION and UNREGISTER." (let* ((r (if unregister "unregister" "register")) - (prop (format "%s-%s" classification r))) + (prop (format "%s-%s" classification r))) prop)) (defun spam-backend-get-article-todo-list (backend - classification - &optional unregister) + classification + &optional unregister) "Get the articles to be processed for BACKEND and CLASSIFICATION. With UNREGISTER, get articles to be unregistered. This is a temporary storage function - nothing here persists." @@ -937,7 +942,8 @@ This is a temporary storage function - nothing here persists." backend (intern (spam-backend-article-list-property classification unregister)))) -(defun spam-backend-put-article-todo-list (backend classification list &optional unregister) +(defun spam-backend-put-article-todo-list (backend classification list + &optional unregister) "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION. With UNREGISTER, set articles to be unregistered. This is a temporary storage function - nothing here persists." @@ -1035,125 +1041,125 @@ backends)." ;;{{{ backend installations (spam-install-checkonly-backend 'spam-use-blackholes - 'spam-check-blackholes) + 'spam-check-blackholes) (spam-install-checkonly-backend 'spam-use-hashcash - 'spam-check-hashcash) + 'spam-check-hashcash) (spam-install-checkonly-backend 'spam-use-spamassassin-headers - 'spam-check-spamassassin-headers) + 'spam-check-spamassassin-headers) (spam-install-checkonly-backend 'spam-use-bogofilter-headers - 'spam-check-bogofilter-headers) + 'spam-check-bogofilter-headers) (spam-install-checkonly-backend 'spam-use-bsfilter-headers - 'spam-check-bsfilter-headers) + 'spam-check-bsfilter-headers) (spam-install-checkonly-backend 'spam-use-gmane-xref - 'spam-check-gmane-xref) + 'spam-check-gmane-xref) (spam-install-checkonly-backend 'spam-use-regex-headers - 'spam-check-regex-headers) + 'spam-check-regex-headers) (spam-install-statistical-checkonly-backend 'spam-use-regex-body - 'spam-check-regex-body) + 'spam-check-regex-body) -;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy) instead +;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy) (spam-install-mover-backend 'spam-use-move - 'spam-move-ham-routine - 'spam-move-spam-routine - nil - nil) + 'spam-move-ham-routine + 'spam-move-spam-routine + nil + nil) (spam-install-nocheck-backend 'spam-use-copy - 'spam-copy-ham-routine - 'spam-copy-spam-routine - nil - nil) + 'spam-copy-ham-routine + 'spam-copy-spam-routine + nil + nil) (spam-install-nocheck-backend 'spam-use-gmane - 'spam-report-gmane-unregister-routine - 'spam-report-gmane-register-routine - 'spam-report-gmane-register-routine - 'spam-report-gmane-unregister-routine) + 'spam-report-gmane-unregister-routine + 'spam-report-gmane-register-routine + 'spam-report-gmane-register-routine + 'spam-report-gmane-unregister-routine) (spam-install-nocheck-backend 'spam-use-resend - 'spam-report-resend-register-ham-routine - 'spam-report-resend-register-routine - nil - nil) + 'spam-report-resend-register-ham-routine + 'spam-report-resend-register-routine + nil + nil) (spam-install-backend 'spam-use-BBDB - 'spam-check-BBDB - 'spam-BBDB-register-routine - nil - 'spam-BBDB-unregister-routine - nil) + 'spam-check-BBDB + 'spam-BBDB-register-routine + nil + 'spam-BBDB-unregister-routine + nil) (spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive) (spam-install-backend 'spam-use-blacklist - 'spam-check-blacklist - nil - 'spam-blacklist-register-routine - nil - 'spam-blacklist-unregister-routine) + 'spam-check-blacklist + nil + 'spam-blacklist-register-routine + nil + 'spam-blacklist-unregister-routine) (spam-install-backend 'spam-use-whitelist - 'spam-check-whitelist - 'spam-whitelist-register-routine - nil - 'spam-whitelist-unregister-routine - nil) + 'spam-check-whitelist + 'spam-whitelist-register-routine + nil + 'spam-whitelist-unregister-routine + nil) (spam-install-statistical-backend 'spam-use-ifile - 'spam-check-ifile - 'spam-ifile-register-ham-routine - 'spam-ifile-register-spam-routine - 'spam-ifile-unregister-ham-routine - 'spam-ifile-unregister-spam-routine) + 'spam-check-ifile + 'spam-ifile-register-ham-routine + 'spam-ifile-register-spam-routine + 'spam-ifile-unregister-ham-routine + 'spam-ifile-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-spamoracle - 'spam-check-spamoracle - 'spam-spamoracle-learn-ham - 'spam-spamoracle-learn-spam - 'spam-spamoracle-unlearn-ham - 'spam-spamoracle-unlearn-spam) + 'spam-check-spamoracle + 'spam-spamoracle-learn-ham + 'spam-spamoracle-learn-spam + 'spam-spamoracle-unlearn-ham + 'spam-spamoracle-unlearn-spam) (spam-install-statistical-backend 'spam-use-stat - 'spam-check-stat - 'spam-stat-register-ham-routine - 'spam-stat-register-spam-routine - 'spam-stat-unregister-ham-routine - 'spam-stat-unregister-spam-routine) + 'spam-check-stat + 'spam-stat-register-ham-routine + 'spam-stat-register-spam-routine + 'spam-stat-unregister-ham-routine + 'spam-stat-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-spamassassin - 'spam-check-spamassassin - 'spam-spamassassin-register-ham-routine - 'spam-spamassassin-register-spam-routine - 'spam-spamassassin-unregister-ham-routine - 'spam-spamassassin-unregister-spam-routine) + 'spam-check-spamassassin + 'spam-spamassassin-register-ham-routine + 'spam-spamassassin-register-spam-routine + 'spam-spamassassin-unregister-ham-routine + 'spam-spamassassin-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-bogofilter - 'spam-check-bogofilter - 'spam-bogofilter-register-ham-routine - 'spam-bogofilter-register-spam-routine - 'spam-bogofilter-unregister-ham-routine - 'spam-bogofilter-unregister-spam-routine) + 'spam-check-bogofilter + 'spam-bogofilter-register-ham-routine + 'spam-bogofilter-register-spam-routine + 'spam-bogofilter-unregister-ham-routine + 'spam-bogofilter-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-bsfilter - 'spam-check-bsfilter - 'spam-bsfilter-register-ham-routine - 'spam-bsfilter-register-spam-routine - 'spam-bsfilter-unregister-ham-routine - 'spam-bsfilter-unregister-spam-routine) + 'spam-check-bsfilter + 'spam-bsfilter-register-ham-routine + 'spam-bsfilter-register-spam-routine + 'spam-bsfilter-unregister-ham-routine + 'spam-bsfilter-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-crm114 - 'spam-check-crm114 - 'spam-crm114-register-ham-routine - 'spam-crm114-register-spam-routine - 'spam-crm114-unregister-ham-routine - 'spam-crm114-unregister-spam-routine) + 'spam-check-crm114 + 'spam-crm114-register-ham-routine + 'spam-crm114-register-spam-routine + 'spam-crm114-unregister-ham-routine + 'spam-crm114-unregister-spam-routine) ;;}}} ;;{{{ scoring and summary formatting @@ -1161,31 +1167,31 @@ backends)." "Return the extra headers spam.el thinks are necessary." (let (list) (when (or spam-use-spamassassin - spam-use-spamassassin-headers - spam-use-regex-headers) + spam-use-spamassassin-headers + spam-use-regex-headers) (push 'X-Spam-Status list)) (when (or spam-use-bogofilter - spam-use-regex-headers) + spam-use-regex-headers) (push 'X-Bogosity list)) (when (or spam-use-crm114 - spam-use-regex-headers) + spam-use-regex-headers) (push 'X-CRM114-Status list)) list)) (defun spam-user-format-function-S (headers) (when headers (format "%3.2f" - (spam-summary-score headers spam-summary-score-preferred-header)))) + (spam-summary-score headers spam-summary-score-preferred-header)))) (defun spam-article-sort-by-spam-status (h1 h2) "Sort articles by score." (let (result) (dolist (header (spam-necessary-extra-headers)) (let ((s1 (spam-summary-score h1 header)) - (s2 (spam-summary-score h2 header))) + (s2 (spam-summary-score h2 header))) (unless (= s1 s2) - (setq result (< s1 s2)) - (return)))) + (setq result (< s1 s2)) + (return)))) result)) (defvar spam-spamassassin-score-regexp @@ -1222,13 +1228,13 @@ With SPECIFIC-HEADER, returns only that header's score. Will not return a nil score." (let (score) (dolist (header - (if specific-header - (list specific-header) - (spam-necessary-extra-headers))) + (if specific-header + (list specific-header) + (spam-necessary-extra-headers))) (setq score - (spam-extra-header-to-number header headers)) + (spam-extra-header-to-number header headers)) (when score - (return))) + (return))) (or score 0))) (defun spam-generic-score (&optional recheck) @@ -1255,15 +1261,15 @@ Will not return a nil score." (let (found) (dolist (backend (spam-backend-list)) (when (and (spam-backend-statistical-p backend) - (or (symbol-value backend) - (memq backend force-symbols))) - (setq found backend))) + (or (symbol-value backend) + (memq backend force-symbols))) + (setq found backend))) found)) (defvar spam-list-of-processors ;; note the nil processors are not defined in gnus.el '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) - (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) + (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) (gnus-group-spam-exit-processor-stat spam spam-use-stat) @@ -1286,6 +1292,7 @@ variable. When the processor variable is nil, just the classification and spam-use-* check variable are used. This is superseded by the new spam backend code, so it's only consulted for backwards compatibility.") +(make-obsolete-variable 'spam-list-of-processors nil "22.1") (defun spam-group-processor-p (group backend &optional classification) "Checks if GROUP has a BACKEND with CLASSIFICATION registered. @@ -1294,38 +1301,38 @@ gnus.el and in spam-list-of-processors. In the case of mover backends, checks the setting of `spam-summary-exit-behavior' in addition to the set values for the group." (if (and (stringp group) - (symbolp backend)) + (symbolp backend)) (let ((old-style (assq backend spam-list-of-processors)) - (parameters (nth 0 (gnus-parameter-spam-process group))) - found) - (if old-style ; old-style processor - (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) - ;; now search for the parameter - (dolist (parameter parameters) - (when (and (null found) - (listp parameter) - (eq classification (nth 0 parameter)) - (eq backend (nth 1 parameter))) - (setq found t))) - - ;; now, if the parameter was not found, do the - ;; spam-summary-exit-behavior-logic for mover backends - (unless found - (when (spam-backend-mover-p backend) - (setq - found - (cond - ((eq spam-summary-exit-behavior 'move-all) t) - ((eq spam-summary-exit-behavior 'move-none) nil) - ((eq spam-summary-exit-behavior 'default) - (or (eq classification 'spam) ;move spam out of all groups - ;; move ham out of spam groups - (and (eq classification 'ham) - (spam-group-spam-contents-p group)))) - (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" - spam-summary-exit-behavior)))))) - - found)) + (parameters (nth 0 (gnus-parameter-spam-process group))) + found) + (if old-style ; old-style processor + (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) + ;; now search for the parameter + (dolist (parameter parameters) + (when (and (null found) + (listp parameter) + (eq classification (nth 0 parameter)) + (eq backend (nth 1 parameter))) + (setq found t))) + + ;; now, if the parameter was not found, do the + ;; spam-summary-exit-behavior-logic for mover backends + (unless found + (when (spam-backend-mover-p backend) + (setq + found + (cond + ((eq spam-summary-exit-behavior 'move-all) t) + ((eq spam-summary-exit-behavior 'move-none) nil) + ((eq spam-summary-exit-behavior 'default) + (or (eq classification 'spam) ;move spam out of all groups + ;; move ham out of spam groups + (and (eq classification 'ham) + (spam-group-spam-contents-p group)))) + (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" + spam-summary-exit-behavior)))))) + + found)) nil)) ;;}}} @@ -1337,21 +1344,21 @@ addition to the set values for the group." ;; group parameters (when (spam-group-spam-contents-p gnus-newsgroup-name) (gnus-message 6 "Marking %s articles as spam" - (if spam-mark-only-unseen-as-spam - "unseen" - "unread")) + (if spam-mark-only-unseen-as-spam + "unseen" + "unread")) (let ((articles (if spam-mark-only-unseen-as-spam - gnus-newsgroup-unseen - gnus-newsgroup-unreads))) + gnus-newsgroup-unseen + gnus-newsgroup-unreads))) (if spam-mark-new-messages-in-spam-group-as-spam - (dolist (article articles) - (gnus-summary-mark-article article gnus-spam-mark)) - (gnus-message 9 "Did not mark new messages as spam."))))) + (dolist (article articles) + (gnus-summary-mark-article article gnus-spam-mark)) + (gnus-message 9 "Did not mark new messages as spam."))))) (defun spam-summary-prepare () (setq spam-old-articles - (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham)) - (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam)))) + (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham)) + (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam)))) (spam-mark-junk-as-spam-routine)) ;; The spam processors are invoked for any group, spam or ham or neither @@ -1367,46 +1374,46 @@ addition to the set values for the group." ;; we have to iterate over the processors, or else we'll be too slow (dolist (classification (spam-classifications)) (let* ((old-articles (cdr-safe (assq classification spam-old-articles))) - (new-articles (spam-list-articles - gnus-newsgroup-articles - classification)) - (changed-articles (spam-set-difference new-articles old-articles))) - ;; now that we have the changed articles, we go through the processors - (dolist (backend (spam-backend-list)) - (let (unregister-list) - (dolist (article changed-articles) - (let ((id (spam-fetch-field-message-id-fast article))) - (when (spam-log-unregistration-needed-p - id 'process classification backend) - (push article unregister-list)))) - ;; call spam-register-routine with specific articles to unregister, - ;; when there are articles to unregister and the check is enabled - (when (and unregister-list (symbol-value backend)) - (spam-backend-put-article-todo-list backend - classification - unregister-list - t)))))) + (new-articles (spam-list-articles + gnus-newsgroup-articles + classification)) + (changed-articles (spam-set-difference new-articles old-articles))) + ;; now that we have the changed articles, we go through the processors + (dolist (backend (spam-backend-list)) + (let (unregister-list) + (dolist (article changed-articles) + (let ((id (spam-fetch-field-message-id-fast article))) + (when (spam-log-unregistration-needed-p + id 'process classification backend) + (push article unregister-list)))) + ;; call spam-register-routine with specific articles to unregister, + ;; when there are articles to unregister and the check is enabled + (when (and unregister-list (symbol-value backend)) + (spam-backend-put-article-todo-list backend + classification + unregister-list + t)))))) ;; do the non-moving backends first, then the moving ones (dolist (backend-type '(non-mover mover)) (dolist (classification (spam-classifications)) - (dolist (backend (spam-backend-list backend-type)) - (when (spam-group-processor-p - gnus-newsgroup-name - backend - classification) - (spam-backend-put-article-todo-list backend - classification - (spam-list-articles - gnus-newsgroup-articles - classification)))))) + (dolist (backend (spam-backend-list backend-type)) + (when (spam-group-processor-p + gnus-newsgroup-name + backend + classification) + (spam-backend-put-article-todo-list backend + classification + (spam-list-articles + gnus-newsgroup-articles + classification)))))) (spam-resolve-registrations-routine) ; do the registrations now ;; we mark all the leftover spam articles as expired at the end (dolist (article (spam-list-articles - gnus-newsgroup-articles - 'spam)) + gnus-newsgroup-articles + 'spam)) (gnus-summary-mark-article article gnus-expirable-mark))) (setq spam-old-articles nil)) @@ -1427,67 +1434,94 @@ addition to the set values for the group." (gnus-summary-kill-process-mark) (let ((backend-supports-deletions - (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name)) - (respool-method (gnus-find-method-for-group gnus-newsgroup-name)) - article mark deletep respool) + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)) + (respool-method (gnus-find-method-for-group gnus-newsgroup-name)) + article mark deletep respool valid-move-destinations) (when (member 'respool groups) - (setq respool t) ; boolean for later + (setq respool t) ; boolean for later (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it + ;; exclude invalid move destinations + (dolist (group groups) + (unless + (or + (and + (eq classification 'spam) + (spam-group-spam-contents-p gnus-newsgroup-name) + (spam-group-spam-contents-p group) + (gnus-message + 3 + "Sorry, can't move spam from spam group %s to spam group %s" + gnus-newsgroup-name + group)) + (and + (eq classification 'ham) + (spam-group-ham-contents-p gnus-newsgroup-name) + (spam-group-ham-contents-p group) + (gnus-message + 3 + "Sorry, can't move ham from ham group %s to ham group %s" + gnus-newsgroup-name + group))) + (push group valid-move-destinations))) + + (setq groups (nreverse valid-move-destinations)) + ;; now do the actual move (dolist (group groups) + (when (and articles (stringp group)) - ;; first, mark the article with the process mark and, if needed, - ;; the unread or expired mark (for ham and spam respectively) + ;; first, mark the article with the process mark and, if needed, + ;; the unread or expired mark (for ham and spam respectively) + (dolist (article articles) + (when (and (eq classification 'ham) + spam-mark-ham-unread-before-move-from-spam-group) + (gnus-message 9 "Marking ham article %d unread before move" + article) + (gnus-summary-mark-article article gnus-unread-mark)) + (when (and (eq classification 'spam) + (not copy)) + (gnus-message 9 "Marking spam article %d expirable before move" + article) + (gnus-summary-mark-article article gnus-expirable-mark)) + (gnus-summary-set-process-mark article) + + (if respool ; respooling is with a "fake" group + (let ((spam-split-disabled + (or spam-split-disabled + (and (eq classification 'ham) + spam-disable-spam-split-during-ham-respool)))) + (gnus-message 9 "Respooling article %d with method %s" + article respool-method) + (gnus-summary-respool-article nil respool-method)) + ;; else, we are not respooling + (if (or (not backend-supports-deletions) + (> (length groups) 1)) + (progn ; if copying, copy and set deletep + (gnus-message 9 "Copying article %d to group %s" + article group) + (gnus-summary-copy-article nil group) + (setq deletep t)) + (gnus-message 9 "Moving article %d to group %s" + article group) + (gnus-summary-move-article nil group)))))) ; else move articles + + ;; now delete the articles, unless a) copy is t, and there was a copy done + ;; b) a move was done to a single group + ;; c) backend-supports-deletions is nil + (unless copy + (when (and deletep backend-supports-deletions) (dolist (article articles) - (when (and (eq classification 'ham) - spam-mark-ham-unread-before-move-from-spam-group) - (gnus-message 9 "Marking ham article %d unread before move" - article) - (gnus-summary-mark-article article gnus-unread-mark)) - (when (and (eq classification 'spam) - (not copy)) - (gnus-message 9 "Marking spam article %d expirable before move" - article) - (gnus-summary-mark-article article gnus-expirable-mark)) (gnus-summary-set-process-mark article) - - (if respool ; respooling is with a "fake" group - (let ((spam-split-disabled - (or spam-split-disabled - (and (eq classification 'ham) - spam-disable-spam-split-during-ham-respool)))) - (gnus-message 9 "Respooling article %d with method %s" - article respool-method) - (gnus-summary-respool-article nil respool-method)) - (if (or (not backend-supports-deletions) ; else, we are not respooling - (> (length groups) 1)) - (progn ; if copying, copy and set deletep - (gnus-message 9 "Copying article %d to group %s" - article group) - (gnus-summary-copy-article nil group) - (setq deletep t)) - (gnus-message 9 "Moving article %d to group %s" - article group) - (gnus-summary-move-article nil group))))) ; else move articles - - ;; now delete the articles, unless a) copy is t, and there was a copy done - ;; b) a move was done to a single group - ;; c) backend-supports-deletions is nil - (unless copy - (when (and deletep backend-supports-deletions) - (dolist (article articles) - (gnus-summary-set-process-mark article) - (gnus-message 9 "Deleting article %d" article)) - (when articles - (let ((gnus-novice-user nil)) ; don't ask me if I'm sure - (gnus-summary-delete-article nil))))) - - (gnus-summary-yank-process-mark) - (length articles)))) + (gnus-message 9 "Deleting article %d" article)) + (when articles + (let ((gnus-novice-user nil)) ; don't ask me if I'm sure + (gnus-summary-delete-article nil))))) + (gnus-summary-yank-process-mark) + (length articles))) (defun spam-copy-spam-routine (articles) (spam-copy-or-move-routine @@ -1535,44 +1569,44 @@ addition to the set values for the group." ;; (nnml-possibly-change-directory ;; (gnus-group-real-name gnus-newsgroup-name)) ;; (setq article-filename (expand-file-name -;; (int-to-string article) nnml-current-directory))) +;; (int-to-string article) nnml-current-directory))) ;; (if (file-exists-p article-filename) -;; article-filename +;; article-filename ;; nil))) (defun spam-fetch-field-fast (article field &optional prepared-data-header) - "Fetch a FIELD for ARTICLE quickly, using the internal gnus-data-list function. + "Fetch a FIELD for ARTICLE with the internal `gnus-data-list' function. When PREPARED-DATA-HEADER is given, don't look in the Gnus data. When FIELD is 'number, ARTICLE can be any number (since we want to find it out)." (when (numberp article) (let* ((data-header (or prepared-data-header - (spam-fetch-article-header article)))) + (spam-fetch-article-header article)))) (if (arrayp data-header) - (cond - ((equal field 'number) - (mail-header-number data-header)) - ((equal field 'from) - (mail-header-from data-header)) - ((equal field 'message-id) - (mail-header-message-id data-header)) - ((equal field 'subject) - (mail-header-subject data-header)) - ((equal field 'references) - (mail-header-references data-header)) - ((equal field 'date) - (mail-header-date data-header)) - ((equal field 'xref) - (mail-header-xref data-header)) - ((equal field 'extra) - (mail-header-extra data-header)) - (t - (gnus-error - 5 - "spam-fetch-field-fast: unknown field %s requested" - field) - nil)) - (gnus-message 6 "Article %d has a nil data header" article))))) + (cond + ((equal field 'number) + (mail-header-number data-header)) + ((equal field 'from) + (mail-header-from data-header)) + ((equal field 'message-id) + (mail-header-message-id data-header)) + ((equal field 'subject) + (mail-header-subject data-header)) + ((equal field 'references) + (mail-header-references data-header)) + ((equal field 'date) + (mail-header-date data-header)) + ((equal field 'xref) + (mail-header-xref data-header)) + ((equal field 'extra) + (mail-header-extra data-header)) + (t + (gnus-error + 5 + "spam-fetch-field-fast: unknown field %s requested" + field) + nil)) + (gnus-message 6 "Article %d has a nil data header" article))))) (defun spam-fetch-field-from-fast (article &optional prepared-data-header) (spam-fetch-field-fast article 'from prepared-data-header)) @@ -1586,27 +1620,26 @@ to find it out)." (defun spam-generate-fake-headers (article) (let ((dh (spam-fetch-article-header article))) (if dh - (concat - (format - ;; 80-character limit makes for strange constructs - (concat "From: %s\nSubject: %s\nMessage-ID: %s\n" - "Date: %s\nReferences: %s\nXref: %s\n") - (spam-fetch-field-fast article 'from dh) - (spam-fetch-field-fast article 'subject dh) - (spam-fetch-field-fast article 'message-id dh) - (spam-fetch-field-fast article 'date dh) - (spam-fetch-field-fast article 'references dh) - (spam-fetch-field-fast article 'xref dh)) - (when (spam-fetch-field-fast article 'extra dh) - (format "%s\n" (spam-fetch-field-fast article 'extra dh)))) + (concat + (format + ;; 80-character limit makes for strange constructs + (concat "From: %s\nSubject: %s\nMessage-ID: %s\n" + "Date: %s\nReferences: %s\nXref: %s\n") + (spam-fetch-field-fast article 'from dh) + (spam-fetch-field-fast article 'subject dh) + (spam-fetch-field-fast article 'message-id dh) + (spam-fetch-field-fast article 'date dh) + (spam-fetch-field-fast article 'references dh) + (spam-fetch-field-fast article 'xref dh)) + (when (spam-fetch-field-fast article 'extra dh) + (format "%s\n" (spam-fetch-field-fast article 'extra dh)))) (gnus-message 5 "spam-generate-fake-headers: article %d didn't have a valid header" article)))) (defun spam-fetch-article-header (article) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-read-header article) (nth 3 (assq article gnus-newsgroup-data)))) ;;}}} @@ -1626,122 +1659,122 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (unless spam-split-disabled (let ((spam-split-group-choice spam-split-group)) (dolist (check specific-checks) - (when (stringp check) - (setq spam-split-group-choice check) - (setq specific-checks (delq check specific-checks)))) + (when (stringp check) + (setq spam-split-group-choice check) + (setq specific-checks (delq check specific-checks)))) (let ((spam-split-group spam-split-group-choice) - (widening-needed-check (spam-widening-needed-p specific-checks))) - (save-excursion - (save-restriction - (when widening-needed-check - (widen) - (gnus-message 8 "spam-split: widening the buffer (%s requires it)" - widening-needed-check)) - (let ((backends (spam-backend-list)) - decision) - (while (and backends (not decision)) - (let* ((backend (pop backends)) - (check-function (spam-backend-check backend)) - (spam-split-group (if spam-split-symbolic-return - 'spam - spam-split-group))) - (when (or - ;; either, given specific checks, this is one of them - (memq backend specific-checks) - ;; or, given no specific checks, spam-use-CHECK is set - (and (null specific-checks) (symbol-value backend))) - (gnus-message 6 "spam-split: calling the %s function" - check-function) - (setq decision (funcall check-function)) - ;; if we got a decision at all, save the current check - (when decision - (setq spam-split-last-successful-check backend)) - - (when (eq decision 'spam) - (unless spam-split-symbolic-return - (gnus-error - 5 - (format "spam-split got %s but %s is nil" - decision - spam-split-symbolic-return))))))) - (if (eq decision t) - (if spam-split-symbolic-return-positive 'ham nil) - decision)))))))) + (widening-needed-check (spam-widening-needed-p specific-checks))) + (save-excursion + (save-restriction + (when widening-needed-check + (widen) + (gnus-message 8 "spam-split: widening the buffer (%s requires it)" + widening-needed-check)) + (let ((backends (spam-backend-list)) + decision) + (while (and backends (not decision)) + (let* ((backend (pop backends)) + (check-function (spam-backend-check backend)) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (when (or + ;; either, given specific checks, this is one of them + (memq backend specific-checks) + ;; or, given no specific checks, spam-use-CHECK is set + (and (null specific-checks) (symbol-value backend))) + (gnus-message 6 "spam-split: calling the %s function" + check-function) + (setq decision (funcall check-function)) + ;; if we got a decision at all, save the current check + (when decision + (setq spam-split-last-successful-check backend)) + + (when (eq decision 'spam) + (unless spam-split-symbolic-return + (gnus-error + 5 + (format "spam-split got %s but %s is nil" + decision + spam-split-symbolic-return))))))) + (if (eq decision t) + (if spam-split-symbolic-return-positive 'ham nil) + decision)))))))) (defun spam-find-spam () "Detect spam in the current newsgroup using `spam-split'." (interactive) (let* ((group gnus-newsgroup-name) - (autodetect (gnus-parameter-spam-autodetect group)) - (methods (gnus-parameter-spam-autodetect-methods group)) - (first-method (nth 0 methods)) - (articles (if spam-autodetect-recheck-messages - gnus-newsgroup-articles - gnus-newsgroup-unseen)) - article-cannot-be-faked) + (autodetect (gnus-parameter-spam-autodetect group)) + (methods (gnus-parameter-spam-autodetect-methods group)) + (first-method (nth 0 methods)) + (articles (if spam-autodetect-recheck-messages + gnus-newsgroup-articles + gnus-newsgroup-unseen)) + article-cannot-be-faked) (dolist (backend methods) (when (spam-backend-statistical-p backend) - (setq article-cannot-be-faked t) - (return))) + (setq article-cannot-be-faked t) + (return))) (when (memq 'default methods) (setq article-cannot-be-faked t)) (when (and autodetect - (not (equal first-method 'none))) + (not (equal first-method 'none))) (mapcar (lambda (article) - (let ((id (spam-fetch-field-message-id-fast article)) - (subject (spam-fetch-field-subject-fast article)) - (sender (spam-fetch-field-from-fast article)) - registry-lookup) - - (unless id - (gnus-message 6 "Article %d has no message ID!" article)) - - (when (and id spam-log-to-registry) - (setq registry-lookup (spam-log-registration-type id 'incoming)) - (when registry-lookup - (gnus-message - 9 - "spam-find-spam: message %s was already registered incoming" - id))) - - (let* ((spam-split-symbolic-return t) - (spam-split-symbolic-return-positive t) - (fake-headers (spam-generate-fake-headers article)) - (split-return - (or registry-lookup - (with-temp-buffer - (if article-cannot-be-faked - (gnus-request-article-this-buffer - article - group) - ;; else, we fake the article - (when fake-headers (insert fake-headers))) - (if (or (null first-method) - (equal first-method 'default)) - (spam-split) - (apply 'spam-split methods)))))) - (if (equal split-return 'spam) - (gnus-summary-mark-article article gnus-spam-mark)) - - (when (and id split-return spam-log-to-registry) - (when (zerop (gnus-registry-group-count id)) - (gnus-registry-add-group - id group subject sender)) - - (unless registry-lookup - (spam-log-processing-to-registry - id - 'incoming - split-return - spam-split-last-successful-check - group)))))) + (let ((id (spam-fetch-field-message-id-fast article)) + (subject (spam-fetch-field-subject-fast article)) + (sender (spam-fetch-field-from-fast article)) + registry-lookup) + + (unless id + (gnus-message 6 "Article %d has no message ID!" article)) + + (when (and id spam-log-to-registry) + (setq registry-lookup (spam-log-registration-type id 'incoming)) + (when registry-lookup + (gnus-message + 9 + "spam-find-spam: message %s was already registered incoming" + id))) + + (let* ((spam-split-symbolic-return t) + (spam-split-symbolic-return-positive t) + (fake-headers (spam-generate-fake-headers article)) + (split-return + (or registry-lookup + (with-temp-buffer + (if article-cannot-be-faked + (gnus-request-article-this-buffer + article + group) + ;; else, we fake the article + (when fake-headers (insert fake-headers))) + (if (or (null first-method) + (equal first-method 'default)) + (spam-split) + (apply 'spam-split methods)))))) + (if (equal split-return 'spam) + (gnus-summary-mark-article article gnus-spam-mark)) + + (when (and id split-return spam-log-to-registry) + (when (zerop (gnus-registry-group-count id)) + (gnus-registry-add-group + id group subject sender)) + + (unless registry-lookup + (spam-log-processing-to-registry + id + 'incoming + split-return + spam-split-last-successful-check + group)))))) articles)))) ;;}}} @@ -1753,104 +1786,104 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (dolist (backend-type '(non-mover mover)) (dolist (classification (spam-classifications)) (dolist (backend (spam-backend-list backend-type)) - (let ((rlist (spam-backend-get-article-todo-list - backend classification)) - (ulist (spam-backend-get-article-todo-list - backend classification t)) - (delcount 0)) - - ;; clear the old lists right away - (spam-backend-put-article-todo-list backend - classification - nil - nil) - (spam-backend-put-article-todo-list backend - classification - nil - t) - - ;; eliminate duplicates - (dolist (article (copy-sequence ulist)) - (when (memq article rlist) - (incf delcount) - (setq rlist (delq article rlist)) - (setq ulist (delq article ulist)))) - - (unless (zerop delcount) - (gnus-message - 9 - "%d messages were saved the trouble of unregistering and then registering" - delcount)) - - ;; unregister articles - (unless (zerop (length ulist)) - (let ((num (spam-unregister-routine classification backend ulist))) - (when (> num 0) - (gnus-message - 6 - "%d %s messages were unregistered by backend %s." - num - classification - backend)))) - - ;; register articles - (unless (zerop (length rlist)) - (let ((num (spam-register-routine classification backend rlist))) - (when (> num 0) - (gnus-message - 6 - "%d %s messages were registered by backend %s." - num - classification - backend))))))))) + (let ((rlist (spam-backend-get-article-todo-list + backend classification)) + (ulist (spam-backend-get-article-todo-list + backend classification t)) + (delcount 0)) + + ;; clear the old lists right away + (spam-backend-put-article-todo-list backend + classification + nil + nil) + (spam-backend-put-article-todo-list backend + classification + nil + t) + + ;; eliminate duplicates + (dolist (article (copy-sequence ulist)) + (when (memq article rlist) + (incf delcount) + (setq rlist (delq article rlist)) + (setq ulist (delq article ulist)))) + + (unless (zerop delcount) + (gnus-message + 9 + "%d messages did not have to unregister and then register" + delcount)) + + ;; unregister articles + (unless (zerop (length ulist)) + (let ((num (spam-unregister-routine classification backend ulist))) + (when (> num 0) + (gnus-message + 6 + "%d %s messages were unregistered by backend %s." + num + classification + backend)))) + + ;; register articles + (unless (zerop (length rlist)) + (let ((num (spam-register-routine classification backend rlist))) + (when (> num 0) + (gnus-message + 6 + "%d %s messages were registered by backend %s." + num + classification + backend))))))))) (defun spam-unregister-routine (classification - backend - specific-articles) + backend + specific-articles) (spam-register-routine classification backend specific-articles t)) (defun spam-register-routine (classification - backend - specific-articles - &optional unregister) + backend + specific-articles + &optional unregister) (when (and (spam-classification-valid-p classification) - (spam-backend-valid-p backend)) + (spam-backend-valid-p backend)) (let* ((register-function - (spam-backend-function backend classification 'registration)) - (unregister-function - (spam-backend-function backend classification 'unregistration)) - (run-function (if unregister - unregister-function - register-function)) - (log-function (if unregister - 'spam-log-undo-registration - 'spam-log-processing-to-registry)) - article articles) + (spam-backend-function backend classification 'registration)) + (unregister-function + (spam-backend-function backend classification 'unregistration)) + (run-function (if unregister + unregister-function + register-function)) + (log-function (if unregister + 'spam-log-undo-registration + 'spam-log-processing-to-registry)) + article articles) (when run-function - ;; make list of articles, using specific-articles if given - (setq articles (or specific-articles - (spam-list-articles - gnus-newsgroup-articles - classification))) - ;; process them + ;; make list of articles, using specific-articles if given + (setq articles (or specific-articles + (spam-list-articles + gnus-newsgroup-articles + classification))) + ;; process them (when (> (length articles) 0) - (gnus-message 5 "%s %d %s articles as %s using backend %s" - (if unregister "Unregistering" "Registering") - (length articles) - (if specific-articles "specific" "") - classification - backend) - (funcall run-function articles) - ;; now log all the registrations (or undo them, depending on - ;; unregister) - (dolist (article articles) - (funcall log-function - (spam-fetch-field-message-id-fast article) - 'process - classification - backend - gnus-newsgroup-name)))) + (gnus-message 5 "%s %d %s articles as %s using backend %s" + (if unregister "Unregistering" "Registering") + (length articles) + (if specific-articles "specific" "") + classification + backend) + (funcall run-function articles) + ;; now log all the registrations (or undo them, depending on + ;; unregister) + (dolist (article articles) + (funcall log-function + (spam-fetch-field-message-id-fast article) + 'process + classification + backend + gnus-newsgroup-name)))) ;; return the number of articles processed (length articles)))) @@ -1858,50 +1891,51 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-log-processing-to-registry (id type classification backend group) (when spam-log-to-registry (if (and (stringp id) - (stringp group) - (spam-process-type-valid-p type) - (spam-classification-valid-p classification) - (spam-backend-valid-p backend)) - (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) - (cell (list classification backend group))) - (push cell cell-list) - (gnus-registry-store-extra-entry - id - type - cell-list)) + (stringp group) + (spam-process-type-valid-p type) + (spam-classification-valid-p classification) + (spam-backend-valid-p backend)) + (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + (cell (list classification backend group))) + (push cell cell-list) + (gnus-registry-store-extra-entry + id + type + cell-list)) (gnus-error 7 - (format "%s call with bad ID, type, classification, spam-backend, or group" - "spam-log-processing-to-registry"))))) + (format + "%s call with bad ID, type, classification, spam-backend, or group" + "spam-log-processing-to-registry"))))) ;;; check if a ham- or spam-processor registration has been done (defun spam-log-registered-p (id type) (when spam-log-to-registry (if (and (stringp id) - (spam-process-type-valid-p type)) - (cdr-safe (gnus-registry-fetch-extra id type)) + (spam-process-type-valid-p type)) + (cdr-safe (gnus-registry-fetch-extra id type)) (progn - (gnus-error - 7 - (format "%s called with bad ID, type, classification, or spam-backend" - "spam-log-registered-p")) - nil)))) + (gnus-error + 7 + (format "%s called with bad ID, type, classification, or spam-backend" + "spam-log-registered-p")) + nil)))) ;;; check what a ham- or spam-processor registration says ;;; returns nil if conflicting registrations are found (defun spam-log-registration-type (id type) (let ((count 0) - decision) + decision) (dolist (reg (spam-log-registered-p id type)) (let ((classification (nth 0 reg))) - (when (spam-classification-valid-p classification) - (when (and decision - (not (eq classification decision))) - (setq count (+ 1 count))) - (setq decision classification)))) + (when (spam-classification-valid-p classification) + (when (and decision + (not (eq classification decision))) + (setq count (+ 1 count))) + (setq decision classification)))) (if (< 0 count) - nil + nil decision))) @@ -1909,47 +1943,49 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-log-unregistration-needed-p (id type classification backend) (when spam-log-to-registry (if (and (stringp id) - (spam-process-type-valid-p type) - (spam-classification-valid-p classification) - (spam-backend-valid-p backend)) - (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) - found) - (dolist (cell cell-list) - (unless found - (when (and (eq classification (nth 0 cell)) - (eq backend (nth 1 cell))) - (setq found t)))) - found) + (spam-process-type-valid-p type) + (spam-classification-valid-p classification) + (spam-backend-valid-p backend)) + (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + found) + (dolist (cell cell-list) + (unless found + (when (and (eq classification (nth 0 cell)) + (eq backend (nth 1 cell))) + (setq found t)))) + found) (progn - (gnus-error - 7 - (format "%s called with bad ID, type, classification, or spam-backend" - "spam-log-unregistration-needed-p")) - nil)))) + (gnus-error + 7 + (format "%s called with bad ID, type, classification, or spam-backend" + "spam-log-unregistration-needed-p")) + nil)))) ;;; undo a ham- or spam-processor registration (the group is not used) -(defun spam-log-undo-registration (id type classification backend &optional group) +(defun spam-log-undo-registration (id type classification backend + &optional group) (when (and spam-log-to-registry - (spam-log-unregistration-needed-p id type classification backend)) + (spam-log-unregistration-needed-p id type classification backend)) (if (and (stringp id) - (spam-process-type-valid-p type) - (spam-classification-valid-p classification) - (spam-backend-valid-p backend)) - (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) - new-cell-list found) - (dolist (cell cell-list) - (unless (and (eq classification (nth 0 cell)) - (eq backend (nth 1 cell))) - (push cell new-cell-list))) - (gnus-registry-store-extra-entry - id - type - new-cell-list)) + (spam-process-type-valid-p type) + (spam-classification-valid-p classification) + (spam-backend-valid-p backend)) + (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + new-cell-list found) + (dolist (cell cell-list) + (unless (and (eq classification (nth 0 cell)) + (eq backend (nth 1 cell))) + (push cell new-cell-list))) + (gnus-registry-store-extra-entry + id + type + new-cell-list)) (progn - (gnus-error 7 (format "%s call with bad ID, type, spam-backend, or group" - "spam-log-undo-registration")) - nil)))) + (gnus-error 7 (format + "%s call with bad ID, type, spam-backend, or group" + "spam-log-undo-registration")) + nil)))) ;;}}} @@ -1958,12 +1994,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;;{{{ Gmane xrefs (defun spam-check-gmane-xref () (let ((header (or - (message-fetch-field "Xref") - (message-fetch-field "Newsgroups")))) - (when header ; return nil when no header + (message-fetch-field "Xref") + (message-fetch-field "Newsgroups")))) + (when header ; return nil when no header (when (string-match spam-gmane-xref-spam-group - header) - spam-split-group)))) + header) + spam-split-group)))) ;;}}} @@ -1971,7 +2007,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-check-regex-body () (let ((spam-regex-headers-ham spam-regex-body-ham) - (spam-regex-headers-spam spam-regex-body-spam)) + (spam-regex-headers-spam spam-regex-body-spam)) (spam-check-regex-headers t))) ;;}}} @@ -1980,20 +2016,20 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-check-regex-headers (&optional body) (let ((type (if body "body" "header")) - ret found) + ret found) (dolist (h-regex spam-regex-headers-ham) (unless found - (goto-char (point-min)) - (when (re-search-forward h-regex nil t) - (message "Ham regex %s search positive." type) - (setq found t)))) + (goto-char (point-min)) + (when (re-search-forward h-regex nil t) + (message "Ham regex %s search positive." type) + (setq found t)))) (dolist (s-regex spam-regex-headers-spam) (unless found - (goto-char (point-min)) - (when (re-search-forward s-regex nil t) - (message "Spam regex %s search positive." type) - (setq found t) - (setq ret spam-split-group)))) + (goto-char (point-min)) + (when (re-search-forward s-regex nil t) + (message "Spam regex %s search positive." type) + (setq found t) + (setq ret spam-split-group)))) ret)) ;;}}} @@ -2003,44 +2039,44 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-reverse-ip-string (ip) (when (stringp ip) (mapconcat 'identity - (nreverse (split-string ip "\\.")) - "."))) + (nreverse (split-string ip "\\.")) + "."))) (defun spam-check-blackholes () "Check the Received headers for blackholed relays." (let ((headers (message-fetch-field "received")) - ips matches) + ips matches) (when headers (with-temp-buffer - (insert headers) - (goto-char (point-min)) - (gnus-message 6 "Checking headers for relay addresses") - (while (re-search-forward - "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) - (gnus-message 9 "Blackhole search found host IP %s." (match-string 1)) - (push (spam-reverse-ip-string (match-string 1)) - ips))) + (insert headers) + (goto-char (point-min)) + (gnus-message 6 "Checking headers for relay addresses") + (while (re-search-forward + "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) + (gnus-message 9 "Blackhole search found host IP %s." (match-string 1)) + (push (spam-reverse-ip-string (match-string 1)) + ips))) (dolist (server spam-blackhole-servers) - (dolist (ip ips) - (unless (and spam-blackhole-good-server-regex - ;; match the good-server-regex against the reversed (again) IP string - (string-match - spam-blackhole-good-server-regex - (spam-reverse-ip-string ip))) - (unless matches - (let ((query-string (concat ip "." server))) - (if spam-use-dig - (let ((query-result (query-dig query-string))) - (when query-result - (gnus-message 6 "(DIG): positive blackhole check '%s'" - query-result) - (push (list ip server query-result) - matches))) - ;; else, if not using dig.el - (when (dns-query query-string) - (gnus-message 6 "positive blackhole check") - (push (list ip server (dns-query query-string 'TXT)) - matches))))))))) + (dolist (ip ips) + (unless (and spam-blackhole-good-server-regex + ;; match against the reversed (again) IP string + (string-match + spam-blackhole-good-server-regex + (spam-reverse-ip-string ip))) + (unless matches + (let ((query-string (concat ip "." server))) + (if spam-use-dig + (let ((query-result (query-dig query-string))) + (when query-result + (gnus-message 6 "(DIG): positive blackhole check '%s'" + query-result) + (push (list ip server query-result) + matches))) + ;; else, if not using dig.el + (when (dns-query query-string) + (gnus-message 6 "positive blackhole check") + (push (list ip server (dns-query query-string 'TXT)) + matches))))))))) (when matches spam-split-group))) ;;}}} @@ -2049,7 +2085,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-check-hashcash () "Check the headers for hashcash payments." - (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean + (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean ;;}}} @@ -2070,16 +2106,16 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (eval-and-compile (when (condition-case nil - (progn - (require 'bbdb) - (require 'bbdb-com)) - (file-error - ;; `bbdb-records' should not be bound as an autoload function - ;; before loading bbdb because of `bbdb-hashtable-size'. - (defalias 'bbdb-records 'ignore) - (defalias 'spam-BBDB-register-routine 'ignore) - (defalias 'spam-enter-ham-BBDB 'ignore) - nil)) + (progn + (require 'bbdb) + (require 'bbdb-com)) + (file-error + ;; `bbdb-records' should not be bound as an autoload function + ;; before loading bbdb because of `bbdb-hashtable-size'. + (defalias 'bbdb-records 'ignore) + (defalias 'spam-BBDB-register-routine 'ignore) + (defalias 'spam-enter-ham-BBDB 'ignore) + nil)) ;; when the BBDB changes, we want to clear out our cache (defun spam-clear-cache-BBDB (&rest immaterial) @@ -2090,32 +2126,32 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-enter-ham-BBDB (addresses &optional remove) "Enter an address into the BBDB; implies ham (non-spam) sender" (dolist (from addresses) - (when (stringp from) - (let* ((parsed-address (gnus-extract-address-components from)) - (name (or (nth 0 parsed-address) "Ham Sender")) - (remove-function (if remove - 'bbdb-delete-record-internal - 'ignore)) - (net-address (nth 1 parsed-address)) - (record (and net-address - (bbdb-search-simple nil net-address)))) - (when net-address - (gnus-message 6 "%s address %s %s BBDB" - (if remove "Deleting" "Adding") - from - (if remove "from" "to")) - (if record - (funcall remove-function record) - (bbdb-create-internal name nil net-address nil nil - "ham sender added by spam.el"))))))) + (when (stringp from) + (let* ((parsed-address (gnus-extract-address-components from)) + (name (or (nth 0 parsed-address) "Ham Sender")) + (remove-function (if remove + 'bbdb-delete-record-internal + 'ignore)) + (net-address (nth 1 parsed-address)) + (record (and net-address + (bbdb-search-simple nil net-address)))) + (when net-address + (gnus-message 6 "%s address %s %s BBDB" + (if remove "Deleting" "Adding") + from + (if remove "from" "to")) + (if record + (funcall remove-function record) + (bbdb-create-internal name nil net-address nil nil + "ham sender added by spam.el"))))))) (defun spam-BBDB-register-routine (articles &optional unregister) (let (addresses) - (dolist (article articles) - (when (stringp (spam-fetch-field-from-fast article)) - (push (spam-fetch-field-from-fast article) addresses))) - ;; now do the register/unregister action - (spam-enter-ham-BBDB addresses unregister))) + (dolist (article articles) + (when (stringp (spam-fetch-field-from-fast article)) + (push (spam-fetch-field-from-fast article) addresses))) + ;; now do the register/unregister action + (spam-enter-ham-BBDB addresses unregister))) (defun spam-BBDB-unregister-routine (articles) (spam-BBDB-register-routine articles t)) @@ -2123,32 +2159,32 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-check-BBDB () "Mail from people in the BBDB is classified as ham or non-spam" (let ((who (message-fetch-field "from")) - bbdb-cache bbdb-hashtable) - (when spam-cache-lookups - (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches)) - (unless bbdb-cache - (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value - ;; this is based on the expanded (bbdb-hashtable) macro - ;; without the debugging support - (with-current-buffer (bbdb-buffer) - (save-excursion - (save-window-excursion - (bbdb-records nil t) - (mapatoms - (lambda (symbol) - (intern (downcase (symbol-name symbol)) bbdb-cache)) - bbdb-hashtable)))) - (puthash 'spam-use-BBDB bbdb-cache spam-caches))) - (when who - (setq who (nth 1 (gnus-extract-address-components who))) - (if - (if spam-cache-lookups - (intern-soft (downcase who) bbdb-cache) - (bbdb-search-simple nil who)) - t - (if spam-use-BBDB-exclusive - spam-split-group - nil))))))) + bbdb-cache bbdb-hashtable) + (when spam-cache-lookups + (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches)) + (unless bbdb-cache + (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value + ;; this is based on the expanded (bbdb-hashtable) macro + ;; without the debugging support + (with-current-buffer (bbdb-buffer) + (save-excursion + (save-window-excursion + (bbdb-records nil t) + (mapatoms + (lambda (symbol) + (intern (downcase (symbol-name symbol)) bbdb-cache)) + bbdb-hashtable)))) + (puthash 'spam-use-BBDB bbdb-cache spam-caches))) + (when who + (setq who (nth 1 (gnus-extract-address-components who))) + (if + (if spam-cache-lookups + (intern-soft (downcase who) bbdb-cache) + (bbdb-search-simple nil who)) + t + (if spam-use-BBDB-exclusive + spam-split-group + nil))))))) ;;}}} @@ -2168,45 +2204,44 @@ See `spam-ifile-database'." (defun spam-check-ifile () "Check the ifile backend for the classification of this message." (let ((article-buffer-name (buffer-name)) - category return) + category return) (with-temp-buffer (let ((temp-buffer-name (buffer-name)) - (db-param (spam-get-ifile-database-parameter))) - (save-excursion - (set-buffer article-buffer-name) - (apply 'call-process-region - (point-min) (point-max) spam-ifile-program - nil temp-buffer-name nil "-c" - (if db-param `(,db-param "-q") `("-q")))) - ;; check the return now (we're back in the temp buffer) - (goto-char (point-min)) - (if (not (eobp)) - (setq category (buffer-substring (point) (point-at-eol)))) - (when (not (zerop (length category))) ; we need a category here - (if spam-ifile-all-categories - (setq return category) - ;; else, if spam-ifile-all-categories is not set... - (when (string-equal spam-ifile-spam-category category) - (setq return spam-split-group)))))) ; note return is nil otherwise + (db-param (spam-get-ifile-database-parameter))) + (with-current-buffer article-buffer-name + (apply 'call-process-region + (point-min) (point-max) spam-ifile-program + nil temp-buffer-name nil "-c" + (if db-param `(,db-param "-q") `("-q")))) + ;; check the return now (we're back in the temp buffer) + (goto-char (point-min)) + (if (not (eobp)) + (setq category (buffer-substring (point) (point-at-eol)))) + (when (not (zerop (length category))) ; we need a category here + (if spam-ifile-all-categories + (setq return category) + ;; else, if spam-ifile-all-categories is not set... + (when (string-equal spam-ifile-spam-category category) + (setq return spam-split-group)))))) ; note return is nil otherwise return)) (defun spam-ifile-register-with-ifile (articles category &optional unregister) "Register an article, given as a string, with a category. Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (let ((category (or category gnus-newsgroup-name)) - (add-or-delete-option (if unregister "-d" "-i")) - (db (spam-get-ifile-database-parameter)) - parameters) + (add-or-delete-option (if unregister "-d" "-i")) + (db (spam-get-ifile-database-parameter)) + parameters) (with-temp-buffer (dolist (article articles) - (let ((article-string (spam-get-article-as-string article))) - (when (stringp article-string) - (insert article-string)))) + (let ((article-string (spam-get-article-as-string article))) + (when (stringp article-string) + (insert article-string)))) (apply 'call-process-region - (point-min) (point-max) spam-ifile-program - nil nil nil - add-or-delete-option category - (if db `(,db "-h") `("-h")))))) + (point-min) (point-max) spam-ifile-program + nil nil nil + add-or-delete-option category + (if db `(,db "-h") `("-h")))))) (defun spam-ifile-register-spam-routine (articles &optional unregister) (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister)) @@ -2235,40 +2270,40 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (eval-and-compile (when (condition-case nil - (let ((spam-stat-install-hooks nil)) - (require 'spam-stat)) - (file-error - (defalias 'spam-stat-register-ham-routine 'ignore) - (defalias 'spam-stat-register-spam-routine 'ignore) - nil)) + (let ((spam-stat-install-hooks nil)) + (require 'spam-stat)) + (file-error + (defalias 'spam-stat-register-ham-routine 'ignore) + (defalias 'spam-stat-register-spam-routine 'ignore) + nil)) (defun spam-check-stat () "Check the spam-stat backend for the classification of this message" (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override - (spam-stat-buffer (buffer-name)) ; stat the current buffer - category return) - (spam-stat-split-fancy))) + (spam-stat-buffer (buffer-name)) ; stat the current buffer + category return) + (spam-stat-split-fancy))) (defun spam-stat-register-spam-routine (articles &optional unregister) (dolist (article articles) - (let ((article-string (spam-get-article-as-string article))) - (with-temp-buffer - (insert article-string) - (if unregister - (spam-stat-buffer-change-to-non-spam) - (spam-stat-buffer-is-spam)))))) + (let ((article-string (spam-get-article-as-string article))) + (with-temp-buffer + (insert article-string) + (if unregister + (spam-stat-buffer-change-to-non-spam) + (spam-stat-buffer-is-spam)))))) (defun spam-stat-unregister-spam-routine (articles) (spam-stat-register-spam-routine articles t)) (defun spam-stat-register-ham-routine (articles &optional unregister) (dolist (article articles) - (let ((article-string (spam-get-article-as-string article))) - (with-temp-buffer - (insert article-string) - (if unregister - (spam-stat-buffer-change-to-spam) - (spam-stat-buffer-is-non-spam)))))) + (let ((article-string (spam-get-article-as-string article))) + (with-temp-buffer + (insert article-string) + (if unregister + (spam-stat-buffer-change-to-spam) + (spam-stat-buffer-is-non-spam)))))) (defun spam-stat-unregister-ham-routine (articles) (spam-stat-register-ham-routine articles t)) @@ -2318,38 +2353,37 @@ With a non-nil REMOVE, remove the ADDRESSES." ;; else, we have a list of addresses here (unless (file-exists-p (file-name-directory file)) (make-directory (file-name-directory file) t)) - (save-excursion - (set-buffer - (find-file-noselect file)) + (with-current-buffer + (find-file-noselect file) (dolist (a addresses) - (when (stringp a) - (goto-char (point-min)) - (if (re-search-forward (regexp-quote a) nil t) - ;; found the address - (when remove - (spam-kill-whole-line)) - ;; else, the address was not found - (unless remove - (goto-char (point-max)) - (unless (bobp) - (insert "\n")) - (insert a "\n"))))) + (when (stringp a) + (goto-char (point-min)) + (if (re-search-forward (regexp-quote a) nil t) + ;; found the address + (when remove + (spam-kill-whole-line)) + ;; else, the address was not found + (unless remove + (goto-char (point-max)) + (unless (bobp) + (insert "\n")) + (insert a "\n"))))) (save-buffer)))) (defun spam-filelist-build-cache (type) (let ((cache (if (eq type 'spam-use-blacklist) - spam-blacklist-cache - spam-whitelist-cache)) - parsed-cache) + spam-blacklist-cache + spam-whitelist-cache)) + parsed-cache) (unless (gethash type spam-caches) (while cache - (let ((address (pop cache))) - (unless (zerop (length address)) ; 0 for a nil address too - (setq address (regexp-quote address)) - ;; fix regexp-quote's treatment of user-intended regexes - (while (string-match "\\\\\\*" address) - (setq address (replace-match ".*" t t address)))) - (push address parsed-cache))) + (let ((address (pop cache))) + (unless (zerop (length address)) ; 0 for a nil address too + (setq address (regexp-quote address)) + ;; fix regexp-quote's treatment of user-intended regexes + (while (string-match "\\\\\\*" address) + (setq address (replace-match ".*" t t address)))) + (push address parsed-cache))) (puthash type parsed-cache spam-caches)))) (defun spam-filelist-check-cache (type from) @@ -2357,9 +2391,9 @@ With a non-nil REMOVE, remove the ADDRESSES." (spam-filelist-build-cache type) (let (found) (dolist (address (gethash type spam-caches)) - (when (and address (string-match address from)) - (setq found t) - (return))) + (when (and address (string-match address from)) + (setq found t) + (return))) found))) ;;; returns t if the sender is in the whitelist, nil or @@ -2371,7 +2405,7 @@ With a non-nil REMOVE, remove the ADDRESSES." (if (spam-from-listed-p 'spam-use-whitelist) t (if spam-use-whitelist-exclusive - spam-split-group + spam-split-group nil))) (defun spam-check-blacklist () @@ -2385,59 +2419,60 @@ With a non-nil REMOVE, remove the ADDRESSES." (when (file-readable-p file) (let (contents address) (with-temp-buffer - (insert-file-contents file) - (while (not (eobp)) - (setq address (buffer-substring (point) (point-at-eol))) - (forward-line 1) - ;; insert the e-mail address if detected, otherwise the raw data - (unless (zerop (length address)) - (let ((pure-address (nth 1 (gnus-extract-address-components address)))) - (push (or pure-address address) contents))))) + (insert-file-contents file) + (while (not (eobp)) + (setq address (buffer-substring (point) (point-at-eol))) + (forward-line 1) + ;; insert the e-mail address if detected, otherwise the raw data + (unless (zerop (length address)) + (let ((pure-address + (nth 1 (gnus-extract-address-components address)))) + (push (or pure-address address) contents))))) (nreverse contents)))) (defun spam-from-listed-p (type) (let ((from (message-fetch-field "from")) - found) + found) (spam-filelist-check-cache type from))) (defun spam-filelist-register-routine (articles blacklist &optional unregister) (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist)) - (declassification (if blacklist 'ham 'spam)) - (enter-function - (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist)) - (remove-function - (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist)) - from addresses unregister-list article-unregister-list) + (declassification (if blacklist 'ham 'spam)) + (enter-function + (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist)) + (remove-function + (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist)) + from addresses unregister-list article-unregister-list) (dolist (article articles) (let ((from (spam-fetch-field-from-fast article)) - (id (spam-fetch-field-message-id-fast article)) - sender-ignored) - (when (stringp from) - (dolist (ignore-regex spam-blacklist-ignored-regexes) - (when (and (not sender-ignored) - (stringp ignore-regex) - (string-match ignore-regex from)) - (setq sender-ignored t))) - ;; remember the messages we need to unregister, unless remove is set - (when (and - (null unregister) - (spam-log-unregistration-needed-p - id 'process declassification de-symbol)) - (push article article-unregister-list) - (push from unregister-list)) - (unless sender-ignored - (push from addresses))))) + (id (spam-fetch-field-message-id-fast article)) + sender-ignored) + (when (stringp from) + (dolist (ignore-regex spam-blacklist-ignored-regexes) + (when (and (not sender-ignored) + (stringp ignore-regex) + (string-match ignore-regex from)) + (setq sender-ignored t))) + ;; remember the messages we need to unregister, unless remove is set + (when (and + (null unregister) + (spam-log-unregistration-needed-p + id 'process declassification de-symbol)) + (push article article-unregister-list) + (push from unregister-list)) + (unless sender-ignored + (push from addresses))))) (if unregister - (funcall enter-function addresses t) ; unregister all these addresses + (funcall enter-function addresses t) ; unregister all these addresses ;; else, register normally and unregister what we need to (funcall remove-function unregister-list t) (dolist (article article-unregister-list) - (spam-log-undo-registration - (spam-fetch-field-message-id-fast article) - 'process - declassification - de-symbol)) + (spam-log-undo-registration + (spam-fetch-field-message-id-fast article) + 'process + declassification + de-symbol)) (funcall enter-function addresses nil)))) (defun spam-blacklist-unregister-routine (articles) @@ -2468,9 +2503,9 @@ With a non-nil REMOVE, remove the ADDRESSES." (defun spam-report-resend-register-routine (articles &optional ham) (let* ((resend-to-gp - (if ham - (gnus-parameter-ham-resend-to gnus-newsgroup-name) - (gnus-parameter-spam-resend-to gnus-newsgroup-name))) + (if ham + (gnus-parameter-ham-resend-to gnus-newsgroup-name) + (gnus-parameter-spam-resend-to gnus-newsgroup-name))) (spam-report-resend-to (or (car-safe resend-to-gp) spam-report-resend-to))) (spam-report-resend articles ham))) @@ -2480,15 +2515,15 @@ With a non-nil REMOVE, remove the ADDRESSES." ;;{{{ Bogofilter (defun spam-check-bogofilter-headers (&optional score) (let ((header (message-fetch-field spam-bogofilter-header))) - (when header ; return nil when no header - (if score ; scoring mode - (if (string-match "spamicity=\\([0-9.]+\\)" header) - (match-string 1 header) - "0") - ;; spam detection mode - (when (string-match spam-bogofilter-bogosity-positive-spam-header - header) - spam-split-group))))) + (when header ; return nil when no header + (if score ; scoring mode + (if (string-match "spamicity=\\([0-9.]+\\)" header) + (match-string 1 header) + "0") + ;; spam detection mode + (when (string-match spam-bogofilter-bogosity-positive-spam-header + header) + spam-split-group))))) ;; return something sensible if the score can't be determined (defun spam-bogofilter-score (&optional recheck) @@ -2498,8 +2533,8 @@ With a non-nil REMOVE, remove the ADDRESSES." (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (unless recheck - (spam-check-bogofilter-headers t)) - (spam-check-bogofilter t)))) + (spam-check-bogofilter-headers t)) + (spam-check-bogofilter t)))) (gnus-summary-show-article) (message "Spamicity score %s" score) (or score "0")))) @@ -2508,54 +2543,53 @@ With a non-nil REMOVE, remove the ADDRESSES." "Verify the Bogofilter version is sufficient." (when (eq spam-bogofilter-valid 'unknown) (setq spam-bogofilter-valid - (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\." - (shell-command-to-string - (format "%s -V" spam-bogofilter-program)))))) + (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\." + (shell-command-to-string + (format "%s -V" spam-bogofilter-program)))))) spam-bogofilter-valid) (defun spam-check-bogofilter (&optional score) "Check the Bogofilter backend for the classification of this message." (if (spam-verify-bogofilter) (let ((article-buffer-name (buffer-name)) - (db spam-bogofilter-database-directory) - return) - (with-temp-buffer - (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) - (apply 'call-process-region - (point-min) (point-max) - spam-bogofilter-program - nil temp-buffer-name nil - (if db `("-d" ,db "-v") `("-v")))) - (setq return (spam-check-bogofilter-headers score)))) - return) + (db spam-bogofilter-database-directory) + return) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (with-current-buffer article-buffer-name + (apply 'call-process-region + (point-min) (point-max) + spam-bogofilter-program + nil temp-buffer-name nil + (if db `("-d" ,db "-v") `("-v")))) + (setq return (spam-check-bogofilter-headers score)))) + return) (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-with-bogofilter (articles - spam - &optional unregister) + spam + &optional unregister) "Register an article, given as a string, as spam or non-spam." (if (spam-verify-bogofilter) (dolist (article articles) - (let ((article-string (spam-get-article-as-string article)) - (db spam-bogofilter-database-directory) - (switch (if unregister - (if spam - spam-bogofilter-spam-strong-switch - spam-bogofilter-ham-strong-switch) - (if spam - spam-bogofilter-spam-switch - spam-bogofilter-ham-switch)))) - (when (stringp article-string) - (with-temp-buffer - (insert article-string) - - (apply 'call-process-region - (point-min) (point-max) - spam-bogofilter-program - nil nil nil switch - (if db `("-d" ,db "-v") `("-v"))))))) + (let ((article-string (spam-get-article-as-string article)) + (db spam-bogofilter-database-directory) + (switch (if unregister + (if spam + spam-bogofilter-spam-strong-switch + spam-bogofilter-ham-strong-switch) + (if spam + spam-bogofilter-spam-switch + spam-bogofilter-ham-switch)))) + (when (stringp article-string) + (with-temp-buffer + (insert article-string) + + (apply 'call-process-region + (point-min) (point-max) + spam-bogofilter-program + nil nil nil switch + (if db `("-d" ,db "-v") `("-v"))))))) (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-spam-routine (articles &optional unregister) @@ -2579,46 +2613,45 @@ With a non-nil REMOVE, remove the ADDRESSES." (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) - (let ((status - (apply 'call-process-region - (point-min) (point-max) - spam-spamoracle-binary - nil temp-buffer-name nil - (if spam-spamoracle-database - `("-f" ,spam-spamoracle-database "mark") - '("mark"))))) - (if (eq 0 status) - (progn - (set-buffer temp-buffer-name) - (goto-char (point-min)) - (when (re-search-forward "^X-Spam: yes;" nil t) - spam-split-group)) - (error "Error running spamoracle: %s" status)))))))) + (with-current-buffer article-buffer-name + (let ((status + (apply 'call-process-region + (point-min) (point-max) + spam-spamoracle-binary + nil temp-buffer-name nil + (if spam-spamoracle-database + `("-f" ,spam-spamoracle-database "mark") + '("mark"))))) + (if (eq 0 status) + (progn + (set-buffer temp-buffer-name) + (goto-char (point-min)) + (when (re-search-forward "^X-Spam: yes;" nil t) + spam-split-group)) + (error "Error running spamoracle: %s" status)))))))) (defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister) "Run spamoracle in training mode." (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion - (goto-char (point-min)) - (dolist (article articles) - (insert (spam-get-article-as-string article))) - (let* ((arg (if (spam-xor unregister article-is-spam-p) - "-spam" - "-good")) - (status - (apply 'call-process-region - (point-min) (point-max) - spam-spamoracle-binary - nil temp-buffer-name nil - (if spam-spamoracle-database - `("-f" ,spam-spamoracle-database - "add" ,arg) - `("add" ,arg))))) - (unless (eq 0 status) - (error "Error running spamoracle: %s" status))))))) + (goto-char (point-min)) + (dolist (article articles) + (insert (spam-get-article-as-string article))) + (let* ((arg (if (spam-xor unregister article-is-spam-p) + "-spam" + "-good")) + (status + (apply 'call-process-region + (point-min) (point-max) + spam-spamoracle-binary + nil temp-buffer-name nil + (if spam-spamoracle-database + `("-f" ,spam-spamoracle-database + "add" ,arg) + `("add" ,arg))))) + (unless (eq 0 status) + (error "Error running spamoracle: %s" status))))))) (defun spam-spamoracle-learn-ham (articles &optional unregister) (spam-spamoracle-learn articles nil unregister)) @@ -2638,32 +2671,31 @@ With a non-nil REMOVE, remove the ADDRESSES." ;;; based mostly on the bogofilter code (defun spam-check-spamassassin-headers (&optional score) "Check the SpamAssassin headers for the classification of this message." - (if score ; scoring mode + (if score ; scoring mode (let ((header (message-fetch-field spam-spamassassin-spam-status-header))) - (when header - (if (string-match spam-spamassassin-score-regexp header) - (match-string 1 header) - "0"))) + (when header + (if (string-match spam-spamassassin-score-regexp header) + (match-string 1 header) + "0"))) ;; spam detection mode (let ((header (message-fetch-field spam-spamassassin-spam-flag-header))) - (when header ; return nil when no header - (when (string-match spam-spamassassin-positive-spam-flag-header - header) - spam-split-group))))) + (when header ; return nil when no header + (when (string-match spam-spamassassin-positive-spam-flag-header + header) + spam-split-group))))) (defun spam-check-spamassassin (&optional score) "Check the SpamAssassin backend for the classification of this message." (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) - (apply 'call-process-region - (point-min) (point-max) spam-assassin-program - nil temp-buffer-name nil spam-spamassassin-arguments)) - ;; check the return now (we're back in the temp buffer) - (goto-char (point-min)) - (spam-check-spamassassin-headers score))))) + (with-current-buffer article-buffer-name + (apply 'call-process-region + (point-min) (point-max) spam-assassin-program + nil temp-buffer-name nil spam-spamassassin-arguments)) + ;; check the return now (we're back in the temp buffer) + (goto-char (point-min)) + (spam-check-spamassassin-headers score))))) ;; return something sensible if the score can't be determined (defun spam-spamassassin-score (&optional recheck) @@ -2673,41 +2705,40 @@ With a non-nil REMOVE, remove the ADDRESSES." (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (unless recheck - (spam-check-spamassassin-headers t)) - (spam-check-spamassassin t)))) + (spam-check-spamassassin-headers t)) + (spam-check-spamassassin t)))) (gnus-summary-show-article) (message "SpamAssassin score %s" score) (or score "0")))) (defun spam-spamassassin-register-with-sa-learn (articles spam - &optional unregister) + &optional unregister) "Register articles with spamassassin's sa-learn as spam or non-spam." (if articles (let ((action (if unregister spam-sa-learn-unregister-switch - (if spam spam-sa-learn-spam-switch - spam-sa-learn-ham-switch))) - (summary-buffer-name (buffer-name))) - (with-temp-buffer - ;; group the articles into mbox format - (dolist (article articles) - (let (article-string) - (save-excursion - (set-buffer summary-buffer-name) - (setq article-string (spam-get-article-as-string article))) - (when (stringp article-string) - (insert "From \n") ; mbox separator (sa-learn only checks the - ; first five chars, so we can get away with - ; a bogus line)) - (insert article-string) - (insert "\n")))) - ;; call sa-learn on all messages at the same time - (apply 'call-process-region - (point-min) (point-max) - spam-sa-learn-program - nil nil nil "--mbox" - (if spam-sa-learn-rebuild - (list action) - `("--no-rebuild" ,action))))))) + (if spam spam-sa-learn-spam-switch + spam-sa-learn-ham-switch))) + (summary-buffer-name (buffer-name))) + (with-temp-buffer + ;; group the articles into mbox format + (dolist (article articles) + (let (article-string) + (with-current-buffer summary-buffer-name + (setq article-string (spam-get-article-as-string article))) + (when (stringp article-string) + (insert "From \n") ; mbox separator (sa-learn only checks the + ; first five chars, so we can get away with + ; a bogus line)) + (insert article-string) + (insert "\n")))) + ;; call sa-learn on all messages at the same time + (apply 'call-process-region + (point-min) (point-max) + spam-sa-learn-program + nil nil nil "--mbox" + (if spam-sa-learn-rebuild + (list action) + `("--no-rebuild" ,action))))))) (defun spam-spamassassin-register-spam-routine (articles &optional unregister) (spam-spamassassin-register-with-sa-learn articles t unregister)) @@ -2728,11 +2759,11 @@ With a non-nil REMOVE, remove the ADDRESSES." (defun spam-check-bsfilter-headers (&optional score) (if score (or (nnmail-fetch-field spam-bsfilter-probability-header) - "0") + "0") (let ((header (nnmail-fetch-field spam-bsfilter-header))) (when header ; return nil when no header - (when (string-match "YES" header) - spam-split-group))))) + (when (string-match "YES" header) + spam-split-group))))) ;; return something sensible if the score can't be determined (defun spam-bsfilter-score (&optional recheck) @@ -2742,8 +2773,8 @@ With a non-nil REMOVE, remove the ADDRESSES." (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (unless recheck - (spam-check-bsfilter-headers t)) - (spam-check-bsfilter t)))) + (spam-check-bsfilter-headers t)) + (spam-check-bsfilter t)))) (gnus-summary-show-article) (message "Spamicity score %s" score) (or score "0")))) @@ -2751,48 +2782,47 @@ With a non-nil REMOVE, remove the ADDRESSES." (defun spam-check-bsfilter (&optional score) "Check the Bsfilter backend for the classification of this message." (let ((article-buffer-name (buffer-name)) - (dir spam-bsfilter-database-directory) - return) + (dir spam-bsfilter-database-directory) + return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) - (apply 'call-process-region - (point-min) (point-max) - spam-bsfilter-program - nil temp-buffer-name nil - "--pipe" - "--insert-flag" - "--insert-probability" - (when dir - (list "--homedir" dir)))) - (setq return (spam-check-bsfilter-headers score)))) + (with-current-buffer article-buffer-name + (apply 'call-process-region + (point-min) (point-max) + spam-bsfilter-program + nil temp-buffer-name nil + "--pipe" + "--insert-flag" + "--insert-probability" + (when dir + (list "--homedir" dir)))) + (setq return (spam-check-bsfilter-headers score)))) return)) (defun spam-bsfilter-register-with-bsfilter (articles - spam - &optional unregister) + spam + &optional unregister) "Register an article, given as a string, as spam or non-spam." (dolist (article articles) (let ((article-string (spam-get-article-as-string article)) - (switch (if unregister - (if spam - spam-bsfilter-spam-strong-switch - spam-bsfilter-ham-strong-switch) - (if spam - spam-bsfilter-spam-switch - spam-bsfilter-ham-switch)))) + (switch (if unregister + (if spam + spam-bsfilter-spam-strong-switch + spam-bsfilter-ham-strong-switch) + (if spam + spam-bsfilter-spam-switch + spam-bsfilter-ham-switch)))) (when (stringp article-string) - (with-temp-buffer - (insert article-string) - (apply 'call-process-region - (point-min) (point-max) - spam-bsfilter-program - nil nil nil switch - "--update" - (when spam-bsfilter-database-directory - (list "--homedir" - spam-bsfilter-database-directory)))))))) + (with-temp-buffer + (insert article-string) + (apply 'call-process-region + (point-min) (point-max) + spam-bsfilter-program + nil nil nil switch + "--update" + (when spam-bsfilter-database-directory + (list "--homedir" + spam-bsfilter-database-directory)))))))) (defun spam-bsfilter-register-spam-routine (articles &optional unregister) (spam-bsfilter-register-with-bsfilter articles t unregister)) @@ -2811,15 +2841,15 @@ With a non-nil REMOVE, remove the ADDRESSES." ;;{{{ CRM114 Mailfilter (defun spam-check-crm114-headers (&optional score) (let ((header (message-fetch-field spam-crm114-header))) - (when header ; return nil when no header - (if score ; scoring mode - (if (string-match "( pR: \\([0-9.-]+\\)" header) - (match-string 1 header) - "0") - ;; spam detection mode - (when (string-match spam-crm114-positive-spam-header - header) - spam-split-group))))) + (when header ; return nil when no header + (if score ; scoring mode + (if (string-match "( pR: \\([0-9.-]+\\)" header) + (match-string 1 header) + "0") + ;; spam detection mode + (when (string-match spam-crm114-positive-spam-header + header) + spam-split-group))))) ;; return something sensible if the score can't be determined (defun spam-crm114-score () @@ -2829,7 +2859,7 @@ With a non-nil REMOVE, remove the ADDRESSES." (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (spam-check-crm114-headers t) - (spam-check-crm114 t)))) + (spam-check-crm114 t)))) (gnus-summary-show-article) (message "pR: %s" score) (or score "0")))) @@ -2837,42 +2867,41 @@ With a non-nil REMOVE, remove the ADDRESSES." (defun spam-check-crm114 (&optional score) "Check the CRM114 Mailfilter backend for the classification of this message." (let ((article-buffer-name (buffer-name)) - (db spam-crm114-database-directory) - return) + (db spam-crm114-database-directory) + return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) - (save-excursion - (set-buffer article-buffer-name) - (apply 'call-process-region - (point-min) (point-max) - spam-crm114-program - nil temp-buffer-name nil + (with-current-buffer article-buffer-name + (apply 'call-process-region + (point-min) (point-max) + spam-crm114-program + nil temp-buffer-name nil (when db (list (concat "--fileprefix=" db))))) - (setq return (spam-check-crm114-headers score)))) + (setq return (spam-check-crm114-headers score)))) return)) (defun spam-crm114-register-with-crm114 (articles - spam - &optional unregister) + spam + &optional unregister) "Register an article, given as a string, as spam or non-spam." (dolist (article articles) (let ((article-string (spam-get-article-as-string article)) - (db spam-crm114-database-directory) - (switch (if unregister - (if spam - spam-crm114-spam-strong-switch - spam-crm114-ham-strong-switch) - (if spam - spam-crm114-spam-switch - spam-crm114-ham-switch)))) + (db spam-crm114-database-directory) + (switch (if unregister + (if spam + spam-crm114-spam-strong-switch + spam-crm114-ham-strong-switch) + (if spam + spam-crm114-spam-switch + spam-crm114-ham-switch)))) (when (stringp article-string) - (with-temp-buffer - (insert article-string) + (with-temp-buffer + (insert article-string) - (apply 'call-process-region - (point-min) (point-max) - spam-crm114-program - nil nil nil + (apply 'call-process-region + (point-min) (point-max) + spam-crm114-program + nil nil nil (when db (list switch (concat "--fileprefix=" db))))))))) (defun spam-crm114-register-spam-routine (articles &optional unregister) @@ -2912,7 +2941,7 @@ installed through `spam-necessary-extra-headers'." (setq spam-install-hooks t) ;; TODO: How do we redo this every time the `spam' face is customized? (push '((eq mark gnus-spam-mark) . spam) - gnus-summary-highlight) + gnus-summary-highlight) ;; Add hooks for loading and saving the spam stats (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) @@ -2941,5 +2970,4 @@ installed through `spam-necessary-extra-headers'." (provide 'spam) -;; arch-tag: 07e6e0ca-ab0a-4412-b445-1f6c72a4f27f ;;; spam.el ends here diff --git a/lisp/gnus/starttls.el b/lisp/gnus/starttls.el index 5355119f40..763b3d0131 100644 --- a/lisp/gnus/starttls.el +++ b/lisp/gnus/starttls.el @@ -254,8 +254,7 @@ handshake, or nil on failure." (starttls-set-process-query-on-exit-flag process nil) (while (and (processp process) (eq (process-status process) 'run) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (goto-char old-max) (not (setq done (re-search-forward starttls-connect nil t))))) @@ -270,6 +269,7 @@ handshake, or nil on failure." host port (if done "done" "failed")) process)) +;;;###autoload (defun starttls-open-stream (name buffer host port) "Open a TLS connection for a port to a host. Returns a subprocess object to represent the connection. @@ -311,5 +311,4 @@ GNUTLS requires a port number." (provide 'starttls) -;; arch-tag: 648b3bd8-63bd-47f5-904c-7c819aea2297 ;;; starttls.el ends here diff --git a/lisp/gnus/utf7.el b/lisp/gnus/utf7.el index 9d2a475008..b55b2cdb82 100644 --- a/lisp/gnus/utf7.el +++ b/lisp/gnus/utf7.el @@ -78,7 +78,7 @@ (defconst utf7-utf-16-coding-system (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS 'utf-16-be-no-signature) - ((and (mm-coding-system-p 'utf-16-be) ; Emacs 21.3, Emacs 22 + ((and (mm-coding-system-p 'utf-16-be) ; Emacs ;; Avoid versions with BOM. (= 2 (length (encode-coding-string "a" 'utf-16-be)))) 'utf-16-be) @@ -112,7 +112,7 @@ Use IMAP modification if FOR-IMAP is non-nil." (skip-chars-forward not-direct-encoding-chars))) (if (and (= fc esc-char) (= run-length 1)) ; Lone esc-char? - (delete-backward-char 1) ; Now there's one too many + (delete-char -1) ; Now there's one too many (utf7-fragment-encode p (point) for-imap)) (insert "-"))))))) @@ -153,7 +153,7 @@ Use IMAP modification if FOR-IMAP is non-nil." (save-excursion (utf7-fragment-decode p (point) for-imap) (goto-char p) - (delete-backward-char 1))))))))) + (delete-char -1))))))))) (defun utf7-fragment-decode (start end &optional for-imap) "Decode base64 encoded fragment from START to END of UTF-7 text in buffer. @@ -205,6 +205,7 @@ Characters are in raw byte pairs in narrowed buffer." (mm-decode-coding-region (point-min) (point-max) 'iso-8859-1) (mm-enable-multibyte)) +;;;###autoload (defun utf7-encode (string &optional for-imap) "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) @@ -228,5 +229,4 @@ Characters are in raw byte pairs in narrowed buffer." (provide 'utf7) -;; arch-tag: 96078b55-85c7-4161-aed2-932c24b282c7 ;;; utf7.el ends here diff --git a/lisp/gnus/webmail.el b/lisp/gnus/webmail.el deleted file mode 100644 index 66a17fa7fd..0000000000 --- a/lisp/gnus/webmail.el +++ /dev/null @@ -1,1152 +0,0 @@ -;;; webmail.el --- interface of web mail - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - -;; Author: Shenghuo Zhu <[email protected]> -;; Keywords: hotmail netaddress my-deja netscape - -;; 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 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Note: Now mail.yahoo.com provides POP3 service, the webmail -;; fetching is not going to be supported. - -;; Note: You need to have `url' and `w3' installed for this backend to -;; work. `w3' must be 4.0pre46+one-line-cookie patch or standalone -;; `url'. - -;; Todo: To support more web mail servers. - -;; Known bugs: -;; 1. Net@ddress may corrupt `X-Face'. - -;; Warning: -;; Webmail is an experimental function, which means NO WARRANTY. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) -(require 'mml) -(eval-when-compile - (ignore-errors - (require 'url) - (require 'url-cookie))) -;; Report failure to find w3 at load time if appropriate. -(eval '(progn - (require 'url) - (require 'url-cookie))) - -;;; - -(defvar webmail-type-definition - '((hotmail - ;; Hotmail hate other HTTP user agents and use one line cookie - (paranoid agent cookie post) - (address . "www.hotmail.com") - (open-url "http://www.hotmail.com/") - (open-snarf . webmail-hotmail-open) - ;; W3 hate redirect POST - (login-url - "http://%s/cgi-bin/dologin?login=%s&passwd=%s&enter=Sign+in&sec=no&curmbox=ACTIVE&_lang=&js=yes&id=2&tw=-10000&beta=" - webmail-aux user password) - ;;(login-snarf . webmail-hotmail-login) - ;;(list-url "%s" webmail-aux) - (list-snarf . webmail-hotmail-list) - (article-snarf . webmail-hotmail-article) - (trash-url - "%s&login=%s&f=33792&curmbox=ACTIVE&_lang=&foo=inbox&js=&page=&%s=on&_HMaction=MoveTo&tobox=trAsH&nullbox=" - webmail-aux user id)) - (yahoo - (paranoid agent cookie post) - (address . "mail.yahoo.com") - (open-url "http://mail.yahoo.com/") - (open-snarf . webmail-yahoo-open) - (login-url;; yahoo will not accept GET - content - ("%s" webmail-aux) - ".tries=&.src=ym&.last=&promo=&.intl=&.bypass=&.partner=&.chkP=Y&.done=&login=%s&passwd=%s" - user password) - (login-snarf . webmail-yahoo-login) - (list-url "%s&rb=Inbox&YN=1" webmail-aux) - (list-snarf . webmail-yahoo-list) - (article-snarf . webmail-yahoo-article) - (trash-url - "%s/ym/ShowFolder?YY=52107&inc=50&order=down&sort=date&pos=0&box=Inbox&DEL=Delete&destBox=&Mid=%s&destBox2=" - webmail-aux id)) - (netaddress - (paranoid cookie post) - (address . "www.netaddress.com") - (open-url "http://www.netaddress.com/") - (open-snarf . webmail-netaddress-open) - (login-url - content - ("%s" webmail-aux) - "LoginState=2&SuccessfulLogin=%%2Ftpl&NewServerName=www.netaddress.com&JavaScript=JavaScript1.2&DomainID=4&Domain=usa.net&NA31site=classic.netaddress.com&NA31port=80&UserID=%s&passwd=%s" - user password) - (login-snarf . webmail-netaddress-login) - (list-url - "http://www.netaddress.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True" - webmail-session) - (list-snarf . webmail-netaddress-list) - (article-url "http://www.netaddress.com/") - (article-snarf . webmail-netaddress-article) - (trash-url - "http://www.netaddress.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1" - webmail-session id)) - (netscape - (paranoid cookie post agent) - (address . "webmail.netscape.com") - (open-url "http://ureg.netscape.com/iiop/UReg2/login/login?U2_LA=en&U2_BACK_FROM_CJ=true&U2_CS=iso-8859-1&U2_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_NEW_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_EXITURL=http://home.netscape.com/&U2_SOURCE=Webmail") - (open-snarf . webmail-netscape-open) - (login-url - content - ("http://ureg.netscape.com/iiop/UReg2/login/loginform") - "U2_USERNAME=%s&U2_PASSWORD=%s%s" - user password webmail-aux) - (login-snarf . webmail-netaddress-login) - (list-url - "http://webmail.netscape.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True" - webmail-session) - (list-snarf . webmail-netaddress-list) - (article-url "http://webmail.netscape.com/") - (article-snarf . webmail-netscape-article) - (trash-url - "http://webmail.netscape.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1" - webmail-session id)) - (my-deja - (paranoid cookie post) - (address . "www.my-deja.com") - ;;(open-snarf . webmail-my-deja-open) - (login-url - content - ("http://mydeja.google.com/cgi-bin/deja/maillogin.py") - "userid=%s&password=%s" - user password) - (list-snarf . webmail-my-deja-list) - (article-snarf . webmail-my-deja-article) - (trash-url webmail-aux id)))) - -(defvar webmail-variables - '(address article-snarf article-url list-snarf list-url - login-url login-snarf open-url open-snarf site articles - post-process paranoid trash-url)) - -(defconst webmail-version "webmail 1.0") - -(defvar webmail-newmail-only nil - "Only fetch new mails.") - -(defvar webmail-move-to-trash-can t - "Move mail to trash can after fetch it.") - -;;; Internal variables - -(defvar webmail-address nil) -(defvar webmail-paranoid nil) -(defvar webmail-aux nil) -(defvar webmail-session nil) -(defvar webmail-article-snarf nil) -(defvar webmail-article-url nil) -(defvar webmail-list-snarf nil) -(defvar webmail-list-url nil) -(defvar webmail-login-url nil) -(defvar webmail-login-snarf nil) -(defvar webmail-open-snarf nil) -(defvar webmail-open-url nil) -(defvar webmail-trash-url nil) -(defvar webmail-articles nil) -(defvar webmail-post-process nil) - -(defvar webmail-buffer nil) -(defvar webmail-buffer-list nil) - -(defvar webmail-type nil) - -(defvar webmail-error-function nil) - -(defvar webmail-debug-file "~/.emacs-webmail-debug") - -;;; Interface functions - -(defun webmail-debug (str) - (with-temp-buffer - (insert "\n---------------- A bug at " str " ------------------\n") - (dolist (sym '(webmail-type user)) - (if (boundp sym) - (gnus-pp `(setq ,sym ',(eval sym))))) - (insert "---------------- webmail buffer ------------------\n\n") - (insert-buffer-substring webmail-buffer) - (insert "\n---------------- end of buffer ------------------\n\n") - (append-to-file (point-min) (point-max) webmail-debug-file))) - -(defun webmail-error (str) - (if webmail-error-function - (funcall webmail-error-function str)) - (message "%s HTML has changed or your w3 package is too old.(%s)" - webmail-type str) - (error "%s HTML has changed or your w3 package is too old.(%s)" - webmail-type str)) - -(defun webmail-setdefault (type) - (let ((type-def (cdr (assq type webmail-type-definition))) - (vars webmail-variables) - pair) - (setq webmail-type type) - (dolist (var vars) - (if (setq pair (assq var type-def)) - (set (intern (concat "webmail-" (symbol-name var))) (cdr pair)) - (set (intern (concat "webmail-" (symbol-name var))) nil))))) - -(defun webmail-eval (expr) - (cond - ((consp expr) - (cons (webmail-eval (car expr)) (webmail-eval (cdr expr)))) - ((symbolp expr) - (eval expr)) - (t - expr))) - -(defun webmail-url (xurl) - (mm-with-unibyte-current-buffer - (cond - ((eq (car xurl) 'content) - (pop xurl) - (mm-url-fetch-simple (if (stringp (car xurl)) - (car xurl) - (apply 'format (webmail-eval (car xurl)))) - (apply 'format (webmail-eval (cdr xurl))))) - ((eq (car xurl) 'post) - (pop xurl) - (mm-url-fetch-form (car xurl) (webmail-eval (cdr xurl)))) - (t - (mm-url-insert (apply 'format (webmail-eval xurl))))))) - -(defun webmail-init () - "Initialize buffers and such." - (if (gnus-buffer-live-p webmail-buffer) - (set-buffer webmail-buffer) - (setq webmail-buffer - (nnheader-set-temp-buffer " *webmail*")) - (mm-disable-multibyte))) - -(defvar url-package-name) -(defvar url-package-version) -(defvar url-cookie-multiple-line) -(defvar url-confirmation-func) - -;; Hack W3 POST redirect. See `url-parse-mime-headers'. -;; -;; Netscape uses "GET" as redirect method when orignal method is POST -;; and status is 302, .i.e no security risks by default without -;; confirmation. -;; -;; Some web servers (at least Apache used by yahoo) return status 302 -;; instead of 303, though they mean 303. - -(defun webmail-url-confirmation-func (prompt) - (cond - ((equal prompt (concat "Honor redirection with non-GET method " - "(possible security risks)? ")) - nil) - ((equal prompt "Continue (with method of GET)? ") - t) - (t (error prompt)))) - -(defun webmail-refresh-redirect () - "Redirect refresh url in META." - (goto-char (point-min)) - (while (re-search-forward - "<meta[ \t\r\n]*http-equiv=\"Refresh\"[^>]*URL=\\([^\"]+\\)\"" - nil t) - (let ((url (match-string 1))) - (erase-buffer) - (mm-with-unibyte-current-buffer - (mm-url-insert url))) - (goto-char (point-min)))) - -(defun webmail-fetch (file subtype user password) - (save-excursion - (webmail-setdefault subtype) - (let ((url-package-name (if (memq 'agent webmail-paranoid) - "Mozilla" - url-package-name)) - (url-package-version (if (memq 'agent webmail-paranoid) - "4.0" - url-package-version)) - (url-cookie-multiple-line (if (memq 'cookie webmail-paranoid) - nil - url-cookie-multiple-line)) - (url-confirmation-func (if (memq 'post webmail-paranoid) - 'webmail-url-confirmation-func - url-confirmation-func)) - (url-http-silence-on-insecure-redirection t) - url-cookie-storage url-cookie-secure-storage - url-cookie-confirmation - item id (n 0)) - (webmail-init) - (setq webmail-articles nil) - (when webmail-open-url - (erase-buffer) - (webmail-url webmail-open-url)) - (if webmail-open-snarf (funcall webmail-open-snarf)) - (when webmail-login-url - (erase-buffer) - (webmail-url webmail-login-url)) - (if webmail-login-snarf - (funcall webmail-login-snarf)) - (when webmail-list-url - (erase-buffer) - (webmail-url webmail-list-url)) - (if webmail-list-snarf - (funcall webmail-list-snarf)) - (while (setq item (pop webmail-articles)) - (message "Fetching mail #%d..." (setq n (1+ n))) - (erase-buffer) - (mm-with-unibyte-current-buffer - (mm-url-insert (cdr item))) - (setq id (car item)) - (if webmail-article-snarf - (funcall webmail-article-snarf file id)) - (when (and webmail-trash-url webmail-move-to-trash-can) - (message "Move mail #%d to trash can..." n) - (condition-case err - (progn - (webmail-url webmail-trash-url) - (let (buf) - (while (setq buf (pop webmail-buffer-list)) - (kill-buffer buf)))) - (error - (let (buf) - (while (setq buf (pop webmail-buffer-list)) - (kill-buffer buf))) - (error err)))))) - (if webmail-post-process - (funcall webmail-post-process)))) - -(defun webmail-encode-8bit () - (goto-char (point-min)) - (skip-chars-forward "^\200-\377") - (while (not (eobp)) - (insert (format "&%d;" (mm-char-int (char-after)))) - (delete-char 1) - (skip-chars-forward "^\200-\377"))) - -;;; hotmail - -(defun webmail-hotmail-open () - (goto-char (point-min)) - (if (re-search-forward - "action=\"https?://\\([^/]+\\)/cgi-bin/dologin" nil t) - (setq webmail-aux (match-string 1)) - (webmail-error "open@1"))) - -(defun webmail-hotmail-login () - (let (site) - (goto-char (point-min)) - (if (re-search-forward - "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t) - (setq site (match-string 1)) - (webmail-error "login@1")) - (goto-char (point-min)) - (if (re-search-forward - "\\(/cgi-bin/HoTMaiL\\?[^\"]*a=b[^\"]*\\)" nil t) - (setq webmail-aux (concat "http://" site (match-string 1))) - (webmail-error "login@2")))) - -(defun webmail-hotmail-list () - (goto-char (point-min)) - (skip-chars-forward " \t\n\r") - (let (site url newp (total "0")) - (if (eobp) - (setq total "0") - (if (re-search-forward "\\([0-9]+\\) *<b>(\\([0-9]+\\) new)" nil t) - (message "Found %s (%s new)" (setq total (match-string 1)) - (match-string 2)) - (if (re-search-forward "\\([0-9]+\\) new" nil t) - (message "Found %s new" (setq total (match-string 1))) - (webmail-error "list@0")))) - (unless (equal total "0") - (goto-char (point-min)) - (if (re-search-forward - "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t) - (setq site (match-string 1)) - (webmail-error "list@1")) - (goto-char (point-min)) - (if (re-search-forward "disk=\\([^&]*\\)&" nil t) - (setq webmail-aux - (concat "http://" site "/cgi-bin/HoTMaiL?disk=" - (match-string 1))) - (webmail-error "list@2")) - (goto-char (point-max)) - (while (re-search-backward - "newmail\\.gif\\|href=\"\\(/cgi-bin/getmsg\\?[^\"]+\\)\"" - nil t) - (if (setq url (match-string 1)) - (progn - (if (or newp (not webmail-newmail-only)) - (let (id) - (if (string-match "msg=\\([^&]+\\)" url) - (setq id (match-string 1 url))) - (push (cons id (concat "http://" site url "&raw=0")) - webmail-articles))) - (setq newp nil)) - (setq newp t)))))) - -;; Thank [email protected] (Victor S. Miller) for raw=0 - -(defun webmail-hotmail-article (file id) - (goto-char (point-min)) - (skip-chars-forward " \t\n\r") - (unless (eobp) - (if (not (search-forward "<pre>" nil t)) - (webmail-error "article@3")) - (skip-chars-forward "\n\r\t ") - (delete-region (point-min) (point)) - (if (not (search-forward "</pre>" nil t)) - (webmail-error "[email protected]")) - (delete-region (match-beginning 0) (point-max)) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (while (re-search-forward "\r\n?" nil t) - (replace-match "\n")) - (goto-char (point-min)) - (insert "\n\n") - (if (not (looking-at "\n*From ")) - (insert "From nobody " (current-time-string) "\n") - (forward-line)) - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (mm-append-to-file (point-min) (point-max) file))) - -(defun webmail-hotmail-article-old (file id) - (let (p attachment count mime hotmail-direct) - (save-restriction - (webmail-encode-8bit) - (goto-char (point-min)) - (if (not (search-forward "<DIV>" nil t)) - (if (not (search-forward "Reply All" nil t)) - (webmail-error "article@1") - (setq hotmail-direct t)) - (goto-char (match-beginning 0))) - (narrow-to-region (point-min) (point)) - (if (not (search-backward "<table" nil t 2)) - (webmail-error "[email protected]")) - (delete-region (point-min) (match-beginning 0)) - (while (search-forward "<a href=" nil t) - (setq p (match-beginning 0)) - (search-forward "</a>" nil t) - (delete-region p (match-end 0))) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (backward-char) - (delete-region (point) (point-max))) - (goto-char (point-max)) - (widen) - (insert "\n") - (setq p (point)) - (while (re-search-forward - "<tt>\\|<div>\\|\\(http://[^/]+/cgi-bin/getmsg/\\([^\?]+\\)\?[^\"]*\\)\"" - nil t) - (if (setq attachment (match-string 1)) - (let ((filename (match-string 2)) - bufname);; Attachment - (delete-region p (match-end 0)) - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert attachment) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (setq mime t) - (insert "<#part type=" - (or (and filename - (string-match "\\.[^\\.]+$" filename) - (mailcap-extension-to-mime - (match-string 0 filename))) - "application/octet-stream")) - (insert " buffer=\"" bufname "\"") - (insert " filename=\"" filename "\"") - (insert " disposition=\"inline\"") - (insert "><#/part>\n") - (setq p (point))) - (delete-region p (match-end 0)) - (if hotmail-direct - (if (not (search-forward "</tt>" nil t)) - (webmail-error "[email protected]") - (delete-region (match-beginning 0) (match-end 0))) - (setq count 1) - (while (and (> count 0) - (re-search-forward "</div>\\|\\(<div>\\)" nil t)) - (if (match-string 1) - (setq count (1+ count)) - (if (= (setq count (1- count)) 0) - (delete-region (match-beginning 0) - (match-end 0)))))) - (narrow-to-region p (point)) - (goto-char (point-min)) - (cond - ((looking-at "<pre>") - (goto-char (match-end 0)) - (if (looking-at "$") (forward-char)) - (delete-region (point-min) (point)) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - nil) - (t - (setq mime t) - (insert "<#part type=\"text/html\" disposition=inline>") - (goto-char (point-max)) - (insert "<#/part>"))) - (goto-char (point-max)) - (setq p (point)) - (widen))) - (delete-region p (point-max)) - (goto-char (point-min)) - ;; Some blank line to separate mails. - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if id - (insert (format "X-Message-ID: <%[email protected]>\n" id))) - (unless (looking-at "$") - (if (search-forward "\n\n" nil t) - (forward-line -1) - (webmail-error "article@2"))) - (narrow-to-region (point) (point-max)) - (if mime - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max))))) - (goto-char (point-min)) - (widen) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - (mm-append-to-file (point-min) (point-max) file))) - -;;; yahoo - -(defun webmail-yahoo-open () - (goto-char (point-min)) - (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t) - (setq webmail-aux (match-string 1)) - (webmail-error "open@1"))) - -(defun webmail-yahoo-login () - (goto-char (point-min)) - (if (re-search-forward "http://[^/]+[0-9]\\.mail\\.yahoo\\.com/" nil t) - (setq webmail-aux (match-string 0)) - (webmail-error "login@1")) - (if (re-search-forward "YY=[0-9]+" nil t) - (setq webmail-aux (concat webmail-aux "ym/ShowFolder?" - (match-string 0))) - (webmail-error "login@2"))) - -(defun webmail-yahoo-list () - (let (url (newp t) (tofetch 0)) - (goto-char (point-min)) - (when (re-search-forward - "showing [0-9]+-\\([0-9]+\\) of \\([0-9]+\\)" nil t) - ;;(setq listed (match-string 1)) - (message "Found %s mail(s)" (match-string 2))) - (if (string-match "http://[^/]+" webmail-aux) - (setq webmail-aux (match-string 0 webmail-aux)) - (webmail-error "list@1")) - (goto-char (point-min)) - (while (re-search-forward - "bgcolor=\"#eeeeee\"\\|href=\"\\(/ym/ShowLetter\\?MsgId=\\([^&]+\\)&[^\"]*\\)\"" - nil t) - (if (setq url (match-string 1)) - (progn - (when (or newp (not webmail-newmail-only)) - (push (cons (match-string 2) (concat webmail-aux url "&toc=1")) - webmail-articles) - (setq tofetch (1+ tofetch))) - (setq newp t)) - (setq newp nil))) - (setq webmail-articles (nreverse webmail-articles)) - (message "Fetching %d mail(s)" tofetch))) - -(defun webmail-yahoo-article (file id) - (let (p attachment) - (save-restriction - (goto-char (point-min)) - (if (not (search-forward "value=\"Done\"" nil t)) - (webmail-error "article@1")) - (if (not (search-forward "<table" nil t)) - (webmail-error "article@2")) - (delete-region (point-min) (match-beginning 0)) - (if (not (search-forward "</table>" nil t)) - (webmail-error "article@3")) - (narrow-to-region (point-min) (match-end 0)) - (while (search-forward "<a href=" nil t) - (setq p (match-beginning 0)) - (search-forward "</a>" nil t) - (delete-region p (match-end 0))) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-max)) - (widen) - (insert "\n") - (setq p (point)) - (while (re-search-forward "[^\"]*/ShowLetter/[^\?]+\?[^\"]*" nil t) - (setq attachment (match-string 0)) - (let (bufname ct ctl cd description) - (if (not (search-forward "<table" nil t)) - (webmail-error "article@4")) - (delete-region p (match-beginning 0)) - (if (not (search-forward "</table>" nil t)) - (webmail-error "article@5")) - (narrow-to-region p (match-end 0)) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (delete-blank-lines) - (setq ct (mail-fetch-field "content-type") - ctl (and ct (mail-header-parse-content-type ct)) - ;;cte (mail-fetch-field "content-transfer-encoding") - cd (mail-fetch-field "content-disposition") - description (mail-fetch-field "content-description") - id (mail-fetch-field "content-id")) - (delete-region (point-min) (point-max)) - (widen) - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert (concat webmail-aux attachment)) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (insert "<#part") - (if (and ctl (not (equal (car ctl) "text/"))) - (insert " type=\"" (car ctl) "\"")) - (insert " buffer=\"" bufname "\"") - (if cd - (insert " disposition=\"" cd "\"")) - (if description - (insert " description=\"" description "\"")) - (insert "><#/part>\n") - (setq p (point)))) - (delete-region p (point-max)) - (goto-char (point-min)) - ;; Some blank line to separate mails. - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if id - (insert (format "X-Message-ID: <%[email protected]>\n" id))) - (unless (looking-at "$") - (if (search-forward "\n\n" nil t) - (forward-line -1) - (webmail-error "article@2"))) - (narrow-to-region (point) (point-max)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max)))) - (goto-char (point-min)) - (widen) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - (mm-append-to-file (point-min) (point-max) file))) - -;;; netaddress - -(defun webmail-netscape-open () - (goto-char (point-min)) - (setq webmail-aux "") - (while (re-search-forward - "TYPE=hidden *NAME=\\([^ ]+\\) *VALUE=\"\\([^\"]+\\)" - nil t) - (setq webmail-aux (concat webmail-aux "&" (match-string 1) "=" - (match-string 2))))) - -(defun webmail-netaddress-open () - (goto-char (point-min)) - (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t) - (setq webmail-aux (concat (car webmail-open-url) (match-string 1))) - (webmail-error "open@1"))) - -(defun webmail-netaddress-login () - (webmail-refresh-redirect) - (goto-char (point-min)) - (if (re-search-forward "tpl/[^/]+/\\([^/]+\\)" nil t) - (setq webmail-session (match-string 1)) - (webmail-error "login@1"))) - -(defun webmail-netaddress-list () - (webmail-refresh-redirect) - (let (item id) - (goto-char (point-min)) - (when (re-search-forward - "(\\([0-9]+\\) unread, \\([0-9]+\\) total)" nil t) - (message "Found %s mail(s), %s unread" - (match-string 2) (match-string 1))) - (goto-char (point-min)) - (while (re-search-forward - "MR\\[i\\]\\.R='\\([^']*\\)'\\|MR\\[i\\]\\.Q='\\([^']+\\)'" nil t) - (if (setq id (match-string 2)) - (setq item - (cons id - (format "%s/tpl/Message/%s/Read?Q=%s&FolderID=-4&SortUseCase=True&Sort=Date&Headers=True" - (car webmail-article-url) - webmail-session id))) - (if (or (not webmail-newmail-only) - (equal (match-string 1) "True")) - (push item webmail-articles)))) - (setq webmail-articles (nreverse webmail-articles)))) - -(defun webmail-netaddress-single-part () - (goto-char (point-min)) - (cond - ((looking-at "[\t\040\r\n]*<font face=[^>]+>[\t\040\r\n]*") - ;; text/plain - (replace-match "") - (while (re-search-forward "[\t\040\r\n]+" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (re-search-forward "<br>" nil t) - (replace-match "\n")) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - nil) - (t - (insert "<#part type=\"text/html\" disposition=inline>") - (goto-char (point-max)) - (insert "<#/part>") - t))) - -(defun webmail-netaddress-article (file id) - (webmail-refresh-redirect) - (let (p p1 attachment count mime type) - (save-restriction - (webmail-encode-8bit) - (goto-char (point-min)) - (if (not (search-forward "Trash" nil t)) - (webmail-error "article@1")) - (if (not (search-forward "<form>" nil t)) - (webmail-error "article@2")) - (delete-region (point-min) (match-beginning 0)) - (if (not (search-forward "</form>" nil t)) - (webmail-error "article@3")) - (narrow-to-region (point-min) (match-end 0)) - (goto-char (point-min)) - (while (re-search-forward "[\040\t\r\n]+" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (search-forward "<b>" nil t) - (replace-match "\n")) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^\040+\\|\040+$" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (re-search-forward "\040+" nil t) - (replace-match " ")) - (goto-char (point-max)) - (widen) - (insert "\n\n") - (setq p (point)) - (unless (search-forward "<!-- Data -->" nil t) - (webmail-error "article@4")) - (forward-line 14) - (delete-region p (point)) - (goto-char (point-max)) - (unless (re-search-backward - "[\040\t]*<br>[\040\t\r\n]*<br>[\040\t\r\n]*<form" p t) - (webmail-error "article@5")) - (delete-region (point) (point-max)) - (goto-char p) - (while (search-forward - "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" - nil t 2) - (setq mime t) - (unless (search-forward "</TABLE>" nil t) - (webmail-error "article@6")) - (setq p1 (point)) - (if (search-backward "<IMG " p t) - (progn - (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t) - (webmail-error "article@7")) - (setq attachment (match-string 1)) - (setq type (match-string 2)) - (unless (search-forward "</TABLE>" nil t) - (webmail-error "article@8")) - (delete-region p (point)) - (let (bufname);; Attachment - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert (concat (car webmail-open-url) attachment)) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (insert "<#part type=" type) - (insert " buffer=\"" bufname "\"") - (insert " disposition=\"inline\"") - (insert "><#/part>\n") - (setq p (point)))) - (delete-region p p1) - (narrow-to-region - p - (if (search-forward - "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" - nil t) - (match-beginning 0) - (point-max))) - (webmail-netaddress-single-part) - (goto-char (point-max)) - (setq p (point)) - (widen))) - (unless mime - (narrow-to-region p (point-max)) - (setq mime (webmail-netaddress-single-part)) - (widen)) - (goto-char (point-min)) - ;; Some blank line to separate mails. - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if id - (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address))) - (unless (looking-at "$") - (if (search-forward "\n\n" nil t) - (forward-line -1) - (webmail-error "article@2"))) - (when mime - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "MIME-Version\\|Content-Type") - (delete-region (point) - (progn - (forward-line 1) - (if (re-search-forward "^[^ \t]" nil t) - (goto-char (match-beginning 0)) - (point-max)))) - (forward-line 1))) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) (point-max)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max)))) - (goto-char (point-min)) - (widen)) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - (mm-append-to-file (point-min) (point-max) file))) - -(defun webmail-netscape-article (file id) - (let (p p1 attachment count mime type) - (save-restriction - (webmail-encode-8bit) - (goto-char (point-min)) - (if (not (search-forward "Trash" nil t)) - (webmail-error "article@1")) - (if (not (search-forward "<form>" nil t)) - (webmail-error "article@2")) - (delete-region (point-min) (match-beginning 0)) - (if (not (search-forward "</form>" nil t)) - (webmail-error "article@3")) - (narrow-to-region (point-min) (match-end 0)) - (goto-char (point-min)) - (while (re-search-forward "[\040\t\r\n]+" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (re-search-forward "<a href=[^>]*>[^<]*</a>" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (search-forward "<b>" nil t) - (replace-match "\n")) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^\040+\\|\040+$" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (re-search-forward "\040+" nil t) - (replace-match " ")) - (goto-char (point-max)) - (widen) - (insert "\n\n") - (setq p (point)) - (unless (search-forward "<!-- Data -->" nil t) - (webmail-error "article@4")) - (forward-line 14) - (delete-region p (point)) - (goto-char (point-max)) - (unless (re-search-backward - "<form name=\"Transfer2\"" p t) - (webmail-error "article@5")) - (delete-region (point) (point-max)) - (goto-char p) - (while (search-forward - "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" - nil t 2) - (setq mime t) - (unless (search-forward "</TABLE>" nil t) - (webmail-error "article@6")) - (setq p1 (point)) - (if (search-backward "<IMG " p t) - (progn - (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t) - (webmail-error "article@7")) - (setq attachment (match-string 1)) - (setq type (match-string 2)) - (unless (search-forward "</TABLE>" nil t) - (webmail-error "article@8")) - (delete-region p (point)) - (let (bufname);; Attachment - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert (concat (car webmail-open-url) attachment)) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (insert "<#part type=" type) - (insert " buffer=\"" bufname "\"") - (insert " disposition=\"inline\"") - (insert "><#/part>\n") - (setq p (point)))) - (delete-region p p1) - (narrow-to-region - p - (if (search-forward - "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" - nil t) - (match-beginning 0) - (point-max))) - (webmail-netaddress-single-part) - (goto-char (point-max)) - (setq p (point)) - (widen))) - (unless mime - (narrow-to-region p (point-max)) - (setq mime (webmail-netaddress-single-part)) - (widen)) - (goto-char (point-min)) - ;; Some blank line to separate mails. - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if id - (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address))) - (unless (looking-at "$") - (if (search-forward "\n\n" nil t) - (forward-line -1) - (webmail-error "article@2"))) - (when mime - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "MIME-Version\\|Content-Type") - (delete-region (point) - (progn - (forward-line 1) - (if (re-search-forward "^[^ \t]" nil t) - (goto-char (match-beginning 0)) - (point-max)))) - (forward-line 1))) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) (point-max)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max)))) - (goto-char (point-min)) - (widen)) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - (mm-append-to-file (point-min) (point-max) file))) - -;;; my-deja - -(defun webmail-my-deja-open () - (webmail-refresh-redirect) - (goto-char (point-min)) - (if (re-search-forward "action=\"\\([^\"]+maillogin\\.py[^\"]*\\)\"" - nil t) - (setq webmail-aux (match-string 1)) - (webmail-error "open@1"))) - -(defun webmail-my-deja-list () - (let (item id newp base) - (goto-char (point-min)) - (when (re-search-forward "href=\"\\(\\([^\"]*\\)/mailnf\\.[^\"]*\\)\"" - nil t) - (let ((url (match-string 1))) - (setq base (match-string 2)) - (erase-buffer) - (mm-url-insert url))) - (goto-char (point-min)) - (when (re-search-forward - "(\\([0-9]+\\) Message.?-[^>]*\\([0-9]+\\) New" - nil t) - (message "Found %s mail(s), %s unread" - (match-string 1) (match-string 2))) - (goto-char (point-min)) - (while (re-search-forward - "newmail\\.gif\\|href=\"[^\"]*\\(mailnf\\.[^\"]+act=view[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" - nil t) - (if (setq id (match-string 2)) - (when (and (or newp (not webmail-newmail-only)) - (not (assoc id webmail-articles))) - (push (cons id (setq webmail-aux - (concat base "/" (match-string 1)))) - webmail-articles) - (setq newp nil)) - (setq newp t))) - (setq webmail-articles (nreverse webmail-articles)))) - -(defun webmail-my-deja-article-part (base) - (let (p) - (cond - ((looking-at "[\t\040\r\n]*<!--[^>]*>") - (replace-match "")) - ((looking-at "[\t\040\r\n]*</PRE>") - (replace-match "")) - ((looking-at "[\t\040\r\n]*<PRE>") - ;; text/plain - (replace-match "") - (save-restriction - (narrow-to-region (point) - (if (re-search-forward "</?PRE>" nil t) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-max)))) - ((looking-at "[\t\040\r\n]*<TABLE") - (save-restriction - (narrow-to-region (point) - (if (search-forward "</TABLE>" nil t 2) - (point) - (point-max))) - (goto-char (point-min)) - (let (name type url bufname) - (if (and (search-forward "File Name:" nil t) - (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t)) - (setq name (match-string 1))) - (if (and (search-forward "File Type:" nil t) - (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t)) - (setq type (match-string 1))) - (unless (re-search-forward "action=\"getattach\\.cgi/\\([^\"]+\\)" - nil t) - (webmail-error "article@5")) - (setq url (concat base "/getattach.cgi/" (match-string 1) - "?sm=Download")) - (while (re-search-forward - "type=hidden name=\"\\([^\"]+\\)\" value=\"\\([^\"]+\\)" - nil t) - (setq url (concat url "&" (match-string 1) "=" - (match-string 2)))) - (delete-region (point-min) (point-max)) - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert url) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (insert "<#part type=\"" type "\"") - (if name (insert " filename=\"" name "\"")) - (insert " buffer=\"" bufname "\"") - (insert " disposition=inline><#/part>")))) - (t - (insert "<#part type=\"text/html\" disposition=inline>") - (goto-char (point-max)) - (insert "<#/part>"))))) - -(defun webmail-my-deja-article (file id) - (let (base) - (goto-char (point-min)) - (unless (string-match "\\([^\"]+\\)/mail" webmail-aux) - (webmail-error "article@0")) - (setq base (match-string 1 webmail-aux)) - (when (re-search-forward - "href=\"[^\"]*\\(mailnf\\.[^\"]+act=move[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" - nil t) - (setq webmail-aux (concat base "/" (match-string 1))) - (string-match "mid=[^\"&]+" webmail-aux) - (setq webmail-aux (replace-match "mid=%s" nil nil webmail-aux))) - (unless (search-forward "<HR noshade>" nil t) - (webmail-error "article@1")) - (delete-region (point-min) (point)) - (unless (search-forward "<HR noshade>" nil t) - (webmail-error "article@2")) - (save-restriction - (narrow-to-region (point-min) (point)) - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (while (re-search-forward "\n\n+" nil t) - (replace-match "\n")) - (goto-char (point-max))) - (save-restriction - (narrow-to-region (point) (point-max)) - (goto-char (point-max)) - (unless (search-backward "<HR noshade>" nil t) - (webmail-error "article@3")) - (unless (search-backward "</TT>" nil t) - (webmail-error "article@4")) - (delete-region (point) (point-max)) - (goto-char (point-min)) - (while (not (eobp)) - (webmail-my-deja-article-part base)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max))))) - (goto-char (point-min)) - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if (eq (char-after) ?\n) - (delete-char 1)) - (mm-append-to-file (point-min) (point-max) file))) - -(provide 'webmail) - -;; arch-tag: f75a4558-a8f6-46ec-b1c3-7a6434b3dd71 -;;; webmail.el ends here diff --git a/lisp/gnus/yenc.el b/lisp/gnus/yenc.el index c31f59c64e..0c8759791f 100644 --- a/lisp/gnus/yenc.el +++ b/lisp/gnus/yenc.el @@ -89,8 +89,9 @@ (when (re-search-forward "^=yend.*$" end t) (setq last (match-beginning 0)) (setq footer-alist (yenc-parse-line (match-string 0))) - (letf (((default-value 'enable-multibyte-characters) nil)) - (setq work-buffer (generate-new-buffer " *yenc-work*"))) + (setq work-buffer (generate-new-buffer " *yenc-work*")) + (unless (featurep 'xemacs) + (with-current-buffer work-buffer (set-buffer-multibyte nil))) (while (< first last) (setq char (char-after first)) (cond ((or (eq char ?\r) @@ -135,5 +136,4 @@ (provide 'yenc) -;; arch-tag: 74df17e8-6fa8-4071-9f7d-54d548d79d9a ;;; yenc.el ends here |