From: Lars Ingebrigtsen Date: Mon, 20 Feb 2012 07:20:52 +0000 (+0100) Subject: Merge remote-tracking branch 'origin/no-gnus' X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=commitdiff_plain;h=a10e061d0e6d4792608c61659d34a0c770c1129b;hp=2451dac5939c4bc01d9d15adb57235a7668b0144 Merge remote-tracking branch 'origin/no-gnus' --- diff --git a/.gitignore b/.gitignore index 840562a30..6445f3398 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,7 @@ contrib/gnus-mdrtn.el contrib/on-loginfo contrib/request-assign.future etc/Makefile +.gitattributes lisp/.gitattributes lisp/*.elc lisp/*.rej @@ -27,6 +28,7 @@ lisp/gnus-load.el lisp/old lisp/semantic.cache lisp/version +texi/.gitattributes texi/Makefile texi/auth texi/emacs-mime diff --git a/GNUS-NEWS b/GNUS-NEWS index 12e4c622b..8645500b9 100644 --- a/GNUS-NEWS +++ b/GNUS-NEWS @@ -7,257 +7,33 @@ Please send Gnus bug reports to bugs@gnus.org. For older news, see Gnus info node "New Features". -* Installation changes +* New features -** Upgrading from previous (stable) version if you have used No Gnus. +** If you have the "tnef" program installed, Gnus will display ms-tnef + files, aka "winmail.dat". -If you have tried No Gnus (the unstable Gnus branch leading to this -release) but went back to a stable version, be careful when upgrading to -this version. In particular, you will probably want to remove the -`~/News/marks' directory (perhaps selectively), so that flags are read -from your `~/.newsrc.eld' instead of from the stale marks file, where -this release will store flags for nntp. See a later entry for more -information about nntp marks. Note that downgrading isn't safe in -general. +** Archives (like tar and zip files) will be automatically unpacked, + and the files inside the packages will be displayed as MIME parts. -** Incompatibility when switching from Emacs 23 to Emacs 22 In Emacs 23, -Gnus uses Emacs' new internal coding system `utf-8-emacs' for saving -articles drafts and `~/.newsrc.eld'. These files may not be read -correctly in Emacs 22 and below. If you want to use Gnus across -different Emacs versions, you may set `mm-auto-save-coding-system' to -`emacs-mule'. +** shr has a new command `z' that cycles through image sizes. -** Lisp files are now installed in `.../site-lisp/gnus/' by default. It -defaulted to `.../site-lisp/' formerly. In addition to this, the new -installer issues a warning if other Gnus installations which will shadow -the latest one are detected. You can then remove those shadows manually -or remove them using `make remove-installed-shadows'. +** `backtab' in the summary buffer now selects the previous link in + the article buffer. -** The installation directory name is allowed to have spaces and/or tabs. - - -* New packages and libraries within Gnus - -** Gnus includes the Emacs Lisp SASL library. - -This provides a clean API to SASL mechanisms from within Emacs. The -user visible aspects of this, compared to the earlier situation, include -support for DIGEST-MD5 and NTLM. *Note Emacs SASL: (sasl)Top. - -** ManageSieve connections uses the SASL library by default. - -The primary change this brings is support for DIGEST-MD5 and NTLM, when -the server supports it. - -** Gnus includes a password cache mechanism in password-cache.el. - -It is enabled by default (see `password-cache'), with a short timeout of -16 seconds (see `password-cache-expiry'). If PGG is used as the PGP -back end, the PGP passphrase is managed by this mechanism. Passwords -for ManageSieve connections are managed by this mechanism, after -querying the user about whether to do so. - -** Using EasyPG with Gnus When EasyPG, is available, Gnus will use it -instead of PGG. EasyPG is an Emacs user interface to GNU Privacy Guard. - *Note EasyPG Assistant user's manual: (epa)Top. EasyPG is included in -Emacs 23 and available separately as well. - - -* Changes in group mode - -** Old intermediate incoming mail files (`Incoming*') are deleted after a -couple of days, not immediately. *Note Mail Source Customization::. -(New in Gnus 5.10.10 / No Gnus 0.8) - - - -* Changes in summary and article mode - -** Gnus now supports sticky article buffers. Those are article buffers -that are not reused when you select another article. *Note Sticky -Articles::. - -** Gnus can selectively display `text/html' articles with a WWW browser -with `K H'. *Note MIME Commands::. - -** International host names (IDNA) can now be decoded inside article bodies -using `W i' (`gnus-summary-idna-message'). This requires that GNU Libidn -(`http://www.gnu.org/software/libidn/') has been installed. - -** The non-ASCII group names handling has been much improved. The back -ends that fully support non-ASCII group names are now `nntp', `nnml', -and `nnrss'. Also the agent, the cache, and the marks features work -with those back ends. *Note Non-ASCII Group Names::. - -** Gnus now displays DNS master files sent as text/dns using dns-mode. - -** Gnus supports new limiting commands in the Summary buffer: `/ r' -(`gnus-summary-limit-to-replied') and `/ R' -(`gnus-summary-limit-to-recipient'). *Note Limiting::. - -** You can now fetch all ticked articles from the server using `Y t' -(`gnus-summary-insert-ticked-articles'). *Note Summary Generation -Commands::. - -** Gnus supports a new sort command in the Summary buffer: `C-c C-s C-t' -(`gnus-summary-sort-by-recipient'). *Note Summary Sorting::. - -** S/MIME now features LDAP user certificate searches. You need to -configure the server in `smime-ldap-host-list'. - -** URLs inside OpenPGP headers are retrieved and imported to your PGP key -ring when you click on them. - -** Picons can be displayed right from the textual address, see -`gnus-picon-style'. *Note Picons::. - -** ANSI SGR control sequences can be transformed using `W A'. - -ANSI sequences are used in some Chinese hierarchies for highlighting -articles (`gnus-article-treat-ansi-sequences'). - -** Gnus now MIME decodes articles even when they lack "MIME-Version" header. -This changes the default of `gnus-article-loose-mime'. - -** `gnus-decay-scores' can be a regexp matching score files. For example, -set it to `\\.ADAPT\\'' and only adaptive score files will be decayed. - *Note Score Decays::. - -** Strings prefixing to the `To' and `Newsgroup' headers in summary lines -when using `gnus-ignored-from-addresses' can be customized with -`gnus-summary-to-prefix' and `gnus-summary-newsgroup-prefix'. *Note To -From Newsgroups::. - -** You can replace MIME parts with external bodies. See -`gnus-mime-replace-part' and `gnus-article-replace-part'. *Note MIME -Commands::, *note Using MIME::. - -** The option `mm-fill-flowed' can be used to disable treatment of -format=flowed messages. Also, flowed text is disabled when sending -inline PGP signed messages. *Note Flowed text: (emacs-mime)Flowed text. -(New in Gnus 5.10.7) - -** Now the new command `S W' (`gnus-article-wide-reply-with-original') for -a wide reply in the article buffer yanks a text that is in the active -region, if it is set, as well as the `R' -(`gnus-article-reply-with-original') command. Note that the `R' command -in the article buffer no longer accepts a prefix argument, which was -used to make it do a wide reply. *Note Article Keymap::. - -** The new command `C-h b' (`gnus-article-describe-bindings') used in the -article buffer now shows not only the article commands but also the real -summary commands that are accessible from the article buffer. +** Using the "X-Message-SMTP-Method" header in Message buffers now + allows specifying how messages are to be sent. For example: + X-Message-SMTP-Method: smtp smtp.fsf.org 587 - -* Changes in Message mode - -** Gnus now supports the "hashcash" client puzzle anti-spam mechanism. Use -`(setq message-generate-hashcash t)' to enable. *Note Hashcash::. - -** You can now drag and drop attachments to the Message buffer. See -`mml-dnd-protocol-alist' and `mml-dnd-attach-options'. *Note MIME: -(message)MIME. - -** The option `message-yank-empty-prefix' now controls how empty lines are -prefixed in cited text. *Note Insertion Variables: (message)Insertion -Variables. - -** Gnus uses narrowing to hide headers in Message buffers. The -`References' header is hidden by default. To make all headers visible, -use `(setq message-hidden-headers nil)'. *Note Message Headers: -(message)Message Headers. - -** You can highlight different levels of citations like in the article -buffer. See `gnus-message-highlight-citation'. - -** `auto-fill-mode' is enabled by default in Message mode. See -`message-fill-column'. *Note Message Headers: (message)Various Message -Variables. - -** You can now store signature files in a special directory named -`message-signature-directory'. - -** The option `message-citation-line-format' controls the format of the -"Whomever writes:" line. You need to set -`message-citation-line-function' to -`message-insert-formatted-citation-line' as well. - - -* Changes in back ends - -** The nntp back end stores article marks in `~/News/marks'. - -The directory can be changed using the (customizable) variable -`nntp-marks-directory', and marks can be disabled using the (back end) -variable `nntp-marks-is-evil'. The advantage of this is that you can -copy `~/News/marks' (using rsync, scp or whatever) to another Gnus -installation, and it will realize what articles you have read and -marked. The data in `~/News/marks' has priority over the same data in -`~/.newsrc.eld'. - -** You can import and export your RSS subscriptions from OPML files. *Note -RSS::. - -** IMAP identity (RFC 2971) is supported. - -By default, Gnus does not send any information about itself, but you can -customize it using the variable `nnimap-id'. - -** The `nnrss' back end now supports multilingual text. Non-ASCII group -names for the `nnrss' groups are also supported. *Note RSS::. - -** Retrieving mail with POP3 is supported over SSL/TLS and with StartTLS. +** Gnus keeps track of non-existent articles for nnimap groups, so + that sparse IMAP folders now list a correct number of messages in + them. -** The nnml back end allows other compression programs beside `gzip' for -compressed message files. *Note Mail Spool::. - -** The nnml back end supports group compaction. - -This feature, accessible via the functions `gnus-group-compact-group' -(`G z' in the group buffer) and `gnus-server-compact-server' (`z' in the -server buffer) renumbers all articles in a group, starting from 1 and -removing gaps. As a consequence, you get a correct total article count -(until messages are deleted again). - - - -* Appearance - -** The tool bar has been updated to use GNOME icons. You can also -customize the tool bars: `M-x customize-apropos RET -tool-bar$' should -get you started. (Only for Emacs, not in XEmacs.) - -** The tool bar icons are now (de)activated correctly in the group buffer, -see the variable `gnus-group-update-tool-bar'. Its default value -depends on your Emacs version. - -** You can change the location of XEmacs' toolbars in Gnus buffers. See -`gnus-use-toolbar' and `message-use-toolbar'. - - - -* Miscellaneous changes - -** Having edited the select-method for the foreign server in the server -buffer is immediately reflected to the subscription of the groups which -use the server in question. For instance, if you change -`nntp-via-address' into `bar.example.com' from `foo.example.com', Gnus -will connect to the news host by way of the intermediate host -`bar.example.com' from next time. - -** The `all.SCORE' file can be edited from the group buffer using `W e'. - -** You can set `gnus-mark-copied-or-moved-articles-as-expirable' to a -non-`nil' value so that articles that have been read may be marked as -expirable automatically when copying or moving them to a group that has -auto-expire turned on. The default is `nil' and copying and moving of -articles behave as before; i.e., the expirable marks will be unchanged -except that the marks will be removed when copying or moving articles to -a group that has not turned auto-expire on. *Note Expiring Mail::. - - - +** Gnus will guess the real type of MIME parts of type + application/octet-stream based on the file suffix. So an + application/octet-stream with a name of "rms.jpg" will be displayed + as an image/jpeg type by default, for instance. + * For older news, see Gnus info node "New Features". ---------------------------------------------------------------------- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d631b8b07..69fd5aedc 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2012-02-19 Vida Gábor (tiny change) + + * gnus-demon.el (gnus-demon-init): Don't multiply time twice. + Reported by Peter Münster. + 2012-02-20 Lars Ingebrigtsen * nnimap.el (nnimap-log-command): Add the IMAP address to the log @@ -19,14 +24,87 @@ 2012-02-15 Lars Ingebrigtsen - * shr.el (shr-remove-trailing-whitespace): Really delete the padding on - too-wide lines. + * imap.el: Remove. + + * nntp.el (nntp-coding-system-for-read): Remove. + (nntp-coding-system-for-write): Ditto. + (nntp-open-connection): Just use `binary' directly. + + * gnus-start.el (gnus-clean-old-newsrc): Delete `unexist' from pre-Ma + Gnus 0.3. + +2012-02-16 Lars Ingebrigtsen + + * mm-decode.el (mm-dissect-singlepart): Guess what the type of + application/octet-stream parts really is. + + * gnus-sum.el (gnus-propagate-marks): Remove. 2012-02-15 Paul Eggert * shr.el (shr-rescale-image): Undo previous change; see . +2012-02-15 Lars Magne Ingebrigtsen + + * gnus.el: Ma Gnus v0.3 is released. + +2012-02-15 Lars Ingebrigtsen + + * gnus-sum.el (gnus-summary-local-variables): Make + `gnus-newsgroup-unexist' into a local variable. + +2012-02-14 Teodor Zlatanov + + * registry.el (registry-usage-test, registry-persistence-test): Move to + tests/gnustest-registry.el. + (registry-make-testable-db, registry-match-test) + (registry-instantiation-test): Move to tests/gnustest-registry.el. + + * gnus-registry.el (gnus-registry-misc-test) + (gnus-registry-usage-test): Move to tests/gnustest-registry.el. + + * tests/gnustest-registry.el: New file with the registry and + gnus-registry ERT tests. + +2012-02-13 Katsumi Yamaoka + + * gnus-msg.el (gnus-summary-resend-message): Make + gnus-summary-resend-message-insert-gcc be last item in + message-header-setup-hook. + +2012-02-13 Lars Ingebrigtsen + + * nnfolder.el (nnfolder-marks-directory, nnfolder-marks-is-evil) + (nnfolder-marks, nnfolder-marks-file-suffix, nnfolder-marks-modtime): + Remove. + (nnfolder-open-server): Don't use marks. + (nnfolder-request-delete-group): Ditto. + (nnfolder-request-rename-group): Ditto. + (nnfolder-request-set-mark, nnfolder-request-marks) + (nnfolder-group-marks-pathname, nnfolder-marks-changed-p) + (nnfolder-save-marks, nnfolder-open-marks): Remove. + + * nnml.el (nnml-marks-is-evil, nnml-marks-file-name, nnml-marks) + (nnml-marks-modtime): Remove. + (nnml-request-delete-group): Don't use marks. + (nnml-request-rename-group): Ditto. + (nnml-request-set-mark, nnml-request-marks, nnml-marks-changed-p) + (nnml-save-marks, nnml-open-marks): Remove. + + * nntp.el (nntp-marks-is-evil, nntp-marks-file-name, nntp-marks) + (nntp-marks-modtime, nntp-marks-directory, nntp-request-set-mark) + (nntp-request-marks, nntp-marks-directory, nntp-marks-changed-p) + (nntp-save-marks, nntp-open-marks, nntp-possibly-create-directory) + (nntp-server-to-method-cache): Remove. + + * shr.el (shr-rescale-image): Fix wrong merge. + +2012-02-15 Lars Ingebrigtsen + + * shr.el (shr-remove-trailing-whitespace): Really delete the padding on + too-wide lines. + 2012-02-13 Lars Ingebrigtsen * nnimap.el (nnimap-record-commands): New variable. @@ -70,6 +148,24 @@ * auth-source.el (auth-source-cache-expiry): Add missing :version tags to new defcustoms and defgroups. +2012-02-11 Lars Ingebrigtsen + + * gnus-sum.el (gnus-adjust-marked-articles): Add to + `gnus-newsgroup-unexist'. + + * gnus.el (gnus-article-mark-lists): Add `unexist' to the list of + marks. + (gnus-article-special-mark-lists): Put the `unexist' in the special + marks list instead. + + * gnus-sum.el (gnus-articles-to-read): Don't include unexisting + articles in the list of articles to be selected. + + * nnimap.el (nnimap-retrieve-group-data-early): Query for unexisting + articles. + (nnimap-update-info): Keep track of unexisting articles. + (nnimap-update-qresync-info): Ditto. + 2012-02-10 Lars Ingebrigtsen * message.el (message-default-send-mail-function): Made into own @@ -80,6 +176,45 @@ * gnus.el (gnus-method-ephemeral-p): Move after declaration of defsubst `gnus-sloppily-equal-method-parameters' to avoid a warning. +2012-02-09 Lars Ingebrigtsen + + * mm-archive.el (mm-archive-dissect-and-inline): New function. + (mm-archive-dissect-and-inline): Fix up the undisplayer. + + * gnus-compat.el: Define `timer-set-function'. + + * mm-decode.el (mm-display-external): Output the text from the command + in the buffer after the command finished. This makes text-based + commands behave better. + +2012-02-08 Lars Ingebrigtsen + + * gnus-compat.el: Add a compat for the old `url-retrieve'. + +2012-02-07 Lars Ingebrigtsen + + * gnus-compat.el: Make `help-function-arglist' be compatible on Emacs + 23.1. + +2012-02-07 Katsumi Yamaoka + + * gnus-sum.el (gnus-summary-show-thread): Revert last two changes. + +2012-02-07 Lars Ingebrigtsen + + * message.el (smtpmail-smtp-user): Silence compiler warning. + +2012-02-06 Lars Ingebrigtsen + + * message.el (message-multi-smtp-send-mail): Also allow specifying the + SMTP user name. + +2012-02-06 Katsumi Yamaoka + + * gnus-sum.el (gnus-summary-show-thread): + next-single-char-property-change may return nil in XEmacs. + (gnus-summary-article-map): Fix typo. + 2012-02-09 Lars Ingebrigtsen * gnus-msg.el (gnus-msg-mail): Use `message-mail' if Gnus isn't @@ -107,10 +242,6 @@ lines that are narrower than the window width. Otherwise background "blocks" will look less readable. -2012-02-07 Katsumi Yamaoka - - * gnus-sum.el (gnus-summary-show-thread): Revert last two changes. - 2012-02-07 Lars Ingebrigtsen * nnimap.el (nnimap-transform-headers): Remove unused variable. @@ -132,11 +263,6 @@ * gnus-sum.el (gnus-summary-exit-no-update): Really deaden the summary buffer if `gnus-kill-summary-on-exit' is nil. -2012-02-06 Katsumi Yamaoka - - * gnus-sum.el (gnus-summary-show-thread): - next-single-char-property-change may return nil in XEmacs. - 2012-02-06 Lars Ingebrigtsen * gnus-sum.el (gnus-handle-ephemeral-exit): Allow exiting from Gnus @@ -147,6 +273,98 @@ * gnus-sum.el (gnus-summary-show-thread): next-single-char-property-change never returns nil (Bug#8657). +2012-02-02 Lars Ingebrigtsen + + * message.el (message-multi-smtp-send-mail): New function. + (message-multi-smtp-send-mail): Respect the X-Message-SMTP-Method + header to implement multi-SMTP functionality. + + * gnus-agent.el (gnus-agent-send-mail-function): Removed. + (gnus-agentize): Don't set it. + (gnus-agent-send-mail): Don't use it. + + * gnus-sum.el (gnus-summary-widget-backward): New function and + keystroke. + + * gnus-compat.el: More the compat functions more compatible. + + * shr.el (shr-put-image): Remove underlines from sliced images. + (shr-zoom-image): Compute the region to be replaced more correctly. + +2012-02-02 Katsumi Yamaoka + + * gnus-msg.el (gnus-gcc-self-resent-messages): New user option. + (gnus-summary-resend-message-insert-gcc): New function. + (gnus-summary-resend-message): Modify message-header-setup-hook and + message-sent-hook to make it work for Gcc. + (gnus-inews-do-gcc): Update the number of unread articles of groups + that messages are Gcc'd to. + + * message.el (message-resend): Run message-sent-hook to do Gcc. + +2012-02-01 Lars Ingebrigtsen + + * lpath.el: Fix an XEmacs compilation warning. + + * gnus-compat.el: Require `help-fns' to fix compilation error. + + * gnus-registry.el (gnus-registry-fixup-registry): Move the message to + a higher level to silence compilation. + + * gnus-art.el (gnus-shr-put-image): Take and pass on a `flags' + parameter to allow controlling the scaling. + + * shr.el (shr-zoom-image): New command and keystroke. + (shr-put-image): Take a `size' flag to say how to scale the image. + + * gnus-compat.el: Redefine `delete-directory' to provide recursive + deletion unless already defined. + + * gnus.el (gnus-compat): Require it. + + * gnus-compat.el: New file. + + * gnus-start.el (gnus-clean-old-newsrc): New function. + (gnus-read-newsrc-file): Use it. + + * mm-archive.el (mm-dissect-archive): Use it to get all file names. + Use recursive deletion. + (mm-dissect-archive): Add support for zip files. + + * gnus-util.el (gnus-recursive-directory-files): New function. + + * mm-archive.el (mm-archive-list-files): Inline text and image parts. + (mm-archive-decoders): Add tgz support. + + * mm-decode.el (mm-shr): Make sure that the HTML ends with a newline. + Otherwise inserting text into the Gnus buffer can look odd. + + * gnus-art.el (gnus-mime-inline-part): Slight clean-up. + + * mm-archive.el (mm-archive-decoders): Add support for tar. + + * gnus.el (gnus-logo-color-alist): Change the colours for Ma Gnus. + + * nnmail.el (nnmail-extra-headers): Add Cc to the default. + +2012-01-31 Lars Ingebrigtsen + + * mm-decode.el (mm-dissect-singlepart): Check that the decoder exists. + + * mm-archive.el: New file. + + * mm-decode.el (mm-dissect-singlepart): Use it to decode ms-tnef files. + + * mm-util.el (mm-find-buffer-file-coding-system): Comment fix. + + * message.el (message-goto-*): Make all the `message-goto-*' commands + push the mark before moving point. This makes it easier to go back to + where you came from after editing whatever you jumped to. + +2012-01-31 Lars Magne Ingebrigtsen + + * gnus.el: Ma Gnus v0.1 is released. + 2012-02-05 Lars Ingebrigtsen * nnimap.el (nnimap-open-server): Allow switching the nnoo server @@ -186,11 +404,11 @@ 2012-01-31 Jim Meyering * gnus-agent.el (gnus-agent-expire-unagentized-dirs): - Correct a comment (insert "not") and hide nominally-doubled "to". + Correct a comment (insert "not") and hide nominally-doubled "to". -2012-01-31 Lars Magne Ingebrigtsen +2012-01-31 Lars Ingebrigtsen - * gnus.el: No Gnus v0.19 is released. + * gnus.el (gnus-version): Change name to "Ma Gnus". 2012-01-30 Philipp Haselwarter (tiny change) diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 5178220af..284a37838 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -242,7 +242,6 @@ NOTES: (defvar gnus-category-group-cache nil) (defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-file-name nil) -(defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-total-fetched-hashtb nil) @@ -683,11 +682,7 @@ This will modify the `gnus-setup-news-hook', and minor mode in all Gnus buffers." (interactive) (gnus-open-agent) - (unless gnus-agent-send-mail-function - (setq gnus-agent-send-mail-function - (or message-send-mail-real-function - (function (lambda () (funcall message-send-mail-function)))) - message-send-mail-real-function 'gnus-agent-send-mail)) + (setq message-send-mail-real-function 'gnus-agent-send-mail) ;; If the servers file doesn't exist, auto-agentize some servers and ;; save the servers file so this auto-agentizing isn't invoked @@ -723,7 +718,7 @@ Optional arg GROUP-NAME allows to specify another group." (defun gnus-agent-send-mail () (if (or (not gnus-agent-queue-mail) (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) - (funcall gnus-agent-send-mail-function) + (message-multi-smtp-send-mail) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 048f89565..32399e158 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -5327,9 +5327,8 @@ Compressed files like .gz and .bz2 are decompressed." (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (mm-read-coding-system "Charset: ")))) - (t - (if (mm-handle-undisplayer handle) - (mm-remove-part handle)))) + ((mm-handle-undisplayer handle) + (mm-remove-part handle))) (forward-line 2) (mm-display-inline handle) (goto-char b))))) @@ -6198,12 +6197,13 @@ Provided for backwards compatibility." (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) -(declare-function shr-put-image "shr" (data alt)) +(declare-function shr-put-image "shr" (data alt &optional flags)) -(defun gnus-shr-put-image (data alt) +(defun gnus-shr-put-image (data alt &optional flags) "Put image DATA with a string ALT. Enable image to be deleted." (let ((image (shr-put-image data (propertize (or alt "*") - 'gnus-image-category 'shr)))) + 'gnus-image-category 'shr) + flags))) (when image (gnus-add-image 'shr image)))) diff --git a/lisp/gnus-compat.el b/lisp/gnus-compat.el new file mode 100644 index 000000000..130748853 --- /dev/null +++ b/lisp/gnus-compat.el @@ -0,0 +1,102 @@ +;;; gnus-compat.el --- Compatability functions for Gnus + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: compat + +;; 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 . + +;;; Commentary: + +;; This package defines and redefines a bunch of functions for Gnus +;; usage. The basic (and somewhat unsound) idea is to make all +;; Emacsen look like the current trunk of Emacs. So it will define +;; functions "missing" in other Emacs instances, and redefine other +;; functions to work like the Emacs trunk versions. + +(eval-when-compile (require 'cl)) + +(ignore-errors + (require 'help-fns)) + +;; XEmacs doesn't have this function. +(when (and (not (fboundp 'help-function-arglist)) + (fboundp 'function-arglist)) + (defun help-function-arglist (def &optional preserve-names) + "Return a formal argument list for the function DEF. +PRESERVE-NAMES is ignored." + (cdr (car (read-from-string (downcase (function-arglist def))))))) + +;; Modify this function on Emacs 23.1 and earlier to always return the +;; right answer. +(when (and (fboundp 'help-function-arglist) + (eq (help-function-arglist 'car) t)) + (defvar gnus-compat-original-help-function-arglist + (symbol-function 'help-function-arglist)) + (defun help-function-arglist (def &optional preserve-names) + "Return a formal argument list for the function DEF. +PRESERVE-NAMES is ignored." + (let ((orig (funcall gnus-compat-original-help-function-arglist def))) + (if (not (eq orig t)) + orig + ;; Built-in subrs have the arglist hidden in the doc string. + (let ((doc (documentation def))) + (when (and doc + (string-match "\n\n\\((fn\\( .*\\)?)\\)\\'" doc)) + (cdr (car (read-from-string (downcase (match-string 1 doc))))))))))) + +(when (= (length (help-function-arglist 'delete-directory)) 1) + (defvar gnus-compat-original-delete-directory + (symbol-function 'delete-directory)) + (defun delete-directory (directory &optional recursive trash) + "Delete the directory named DIRECTORY. Does not follow symlinks. +If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well. +TRASH is ignored." + (interactive "DDirectory: ") + (if (not recursive) + (funcall gnus-compat-original-delete-directory directory) + (dolist (file (directory-files directory t)) + (unless (member (file-name-nondirectory file) '("." "..")) + (if (file-directory-p file) + (delete-directory file t) + (delete-file file)))) + (delete-directory directory)))) + +;; Emacs 24.0.93 +(require 'url) +(when (= (length (help-function-arglist 'url-retrieve)) 5) + (defvar gnus-compat-original-url-retrieve + (symbol-function 'url-retrieve)) + (defun url-retrieve (url callback &optional cbargs silent inhibit-cookies) + "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished." + (funcall gnus-compat-original-url-retrieve + url callback cbargs silent))) + +;; XEmacs +(when (and (not (fboundp 'timer-set-function)) + (fboundp 'set-itimer-function)) + (defun timer-set-function (timer function &optional args) + "Make TIMER call FUNCTION with optional ARGS when triggering." + (lexical-let ((function function) + (args args)) + (set-itimer-function timer + (lambda (process status) + (apply function process status args)))))) + +(provide 'gnus-compat) + +;; gnus-compat.el ends here diff --git a/lisp/gnus-group.el b/lisp/gnus-group.el index 5165e9c53..f75ef37da 100644 --- a/lisp/gnus-group.el +++ b/lisp/gnus-group.el @@ -56,7 +56,7 @@ (autoload 'gnus-group-make-nnir-group "nnir") -(defcustom gnus-no-groups-message "No Gnus is good news" +(defcustom gnus-no-groups-message "No news is good news" "*Message displayed by Gnus when no groups are available." :group 'gnus-start :type 'string) diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index f92dc5e91..ecad92f1b 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -163,6 +163,22 @@ if nil, attach files as normal parts." (const all :tag "Any") (string :tag "Regexp"))) +(defcustom gnus-gcc-self-resent-messages 'no-gcc-self + "Like `gcc-self' group parameter, only for unmodified resent messages. +Applied to messages sent by `gnus-summary-resend-message'. Non-nil +value of this variable takes precedence over any existing Gcc header. + +If this is `none', no Gcc copy will be made. If this is t, messages +resent will be Gcc'd to the current group. If this is a string, it +specifies a group to which resent messages will be Gcc'd. If this is +nil, Gcc will be done according to existing Gcc header(s), if any. +If this is `no-gcc-self', resent messages will be Gcc'd to groups that +existing Gcc header specifies, except for the current group." + :version "24.2" + :group 'gnus-message + :type '(choice (const none) (const t) string (const nil) + (const no-gcc-self))) + (gnus-define-group-parameter posting-charset-alist :type list @@ -1268,6 +1284,43 @@ For the \"inline\" alternatives, also see the variable (set-buffer gnus-original-article-buffer) (message-forward post))))))) +(defun gnus-summary-resend-message-insert-gcc () + "Insert Gcc header according to `gnus-gcc-self-resent-messages'." + (gnus-inews-insert-gcc) + (let ((gcc (mapcar + (lambda (group) + (mm-encode-coding-string + group + (gnus-group-name-charset (gnus-inews-group-method group) + group))) + (message-unquote-tokens + (message-tokenize-header (mail-fetch-field "gcc" nil t) + " ,"))))) + (message-remove-header "gcc") + (when gcc + (goto-char (point-max)) + (cond ((eq gnus-gcc-self-resent-messages 'none)) + ((eq gnus-gcc-self-resent-messages t) + (insert "Gcc: \"" gnus-newsgroup-name "\"\n")) + ((stringp gnus-gcc-self-resent-messages) + (insert "Gcc: " + (mm-encode-coding-string + (if (string-match " " gnus-gcc-self-resent-messages) + (concat "\"" gnus-gcc-self-resent-messages "\"") + gnus-gcc-self-resent-messages) + (gnus-group-name-charset + (gnus-inews-group-method gnus-gcc-self-resent-messages) + gnus-gcc-self-resent-messages)) + "\n")) + ((null gnus-gcc-self-resent-messages) + (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n")) + ((eq gnus-gcc-self-resent-messages 'no-gcc-self) + (when (setq gcc (delete + gnus-newsgroup-name + (delete (concat "\"" gnus-newsgroup-name "\"") + gcc))) + (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n"))))))) + (defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." (interactive @@ -1281,12 +1334,21 @@ For the \"inline\" alternatives, also see the variable (with-current-buffer gnus-original-article-buffer (nnmail-fetch-field "to")))) current-prefix-arg)) - (dolist (article (gnus-summary-work-articles n)) - (gnus-summary-select-article nil nil nil article) - (with-current-buffer gnus-original-article-buffer - (let ((gnus-gcc-externalize-attachments nil)) - (message-resend address))) - (gnus-summary-mark-article-as-forwarded article))) + (let ((message-header-setup-hook (copy-sequence message-header-setup-hook)) + (message-sent-hook (copy-sequence message-sent-hook))) + ;; `gnus-summary-resend-message-insert-gcc' must run last. + (add-hook 'message-header-setup-hook + 'gnus-summary-resend-message-insert-gcc t) + (add-hook 'message-sent-hook (if gnus-agent + 'gnus-agent-possibly-do-gcc + 'gnus-inews-do-gcc)) + (dolist (article (gnus-summary-work-articles n)) + (gnus-summary-select-article nil nil nil article) + (with-current-buffer gnus-original-article-buffer + (let ((gnus-gcc-externalize-attachments nil) + (message-inhibit-body-encoding t)) + (message-resend address))) + (gnus-summary-mark-article-as-forwarded article)))) ;; From: Matthieu Moy (defun gnus-summary-resend-message-edit () @@ -1628,12 +1690,16 @@ this is a reply." (when (and group-art ;; FIXME: Should gcc-mark-as-read work when ;; Gnus is not running? - (gnus-alive-p) - (or gnus-gcc-mark-as-read - (and - (boundp 'gnus-inews-mark-gcc-as-read) - (symbol-value 'gnus-inews-mark-gcc-as-read)))) - (gnus-group-mark-article-read group (cdr group-art))) + (gnus-alive-p)) + (if (or gnus-gcc-mark-as-read + (and (boundp 'gnus-inews-mark-gcc-as-read) + (symbol-value 'gnus-inews-mark-gcc-as-read))) + (gnus-group-mark-article-read group (cdr group-art)) + (with-current-buffer gnus-group-buffer + (let ((gnus-group-marked (list group)) + (gnus-get-new-news-hook nil) + (inhibit-read-only t)) + (gnus-group-get-new-news-this-group nil t))))) (setq options message-options) (with-current-buffer cur (setq message-options options)) (kill-buffer (current-buffer))))))))) diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index f1618b376..4221af663 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -78,12 +78,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (require 'gnus) (require 'gnus-int) (require 'gnus-sum) @@ -267,7 +261,7 @@ the Bit Bucket." (append gnus-registry-track-extra '(mark group keyword))) (when (not (equal old (oref db :tracked))) - (gnus-message 4 "Reindexing the Gnus registry (tracked change)") + (gnus-message 9 "Reindexing the Gnus registry (tracked change)") (registry-reindex db)))) db) @@ -1078,79 +1072,6 @@ only the last one's marks are returned." (gnus-registry-set-id-key id key val)))) (message "Import done, collected %d entries" count)))) -(ert-deftest gnus-registry-misc-test () - (should-error (gnus-registry-extract-addresses '("" ""))) - - (should (equal '("Ted Zlatanov " - "noname " - "noname " - "noname ") - (gnus-registry-extract-addresses - (concat "Ted Zlatanov , " - "ed , " ; "ed" is not a valid name here - "cyd@stupidchicken.com, " - "tzz@lifelogs.com"))))) - -(ert-deftest gnus-registry-usage-test () - (let* ((n 100) - (tempfile (make-temp-file "gnus-registry-persist")) - (db (gnus-registry-make-db tempfile)) - (gnus-registry-db db) - back size) - (message "Adding %d keys to the test Gnus registry" n) - (dotimes (i n) - (let ((id (number-to-string i))) - (gnus-registry-handle-action id - (if (>= 50 i) "fromgroup" nil) - "togroup" - (when (>= 70 i) - (format "subject %d" (mod i 10))) - (when (>= 80 i) - (format "sender %d" (mod i 10)))))) - (message "Testing Gnus registry size is %d" n) - (should (= n (registry-size db))) - (message "Looking up individual keys (registry-lookup)") - (should (equal (loop for e - in (mapcar 'cadr - (registry-lookup db '("20" "83" "72"))) - collect (assq 'subject e) - collect (assq 'sender e) - collect (assq 'group e)) - '((subject "subject 0") (sender "sender 0") (group "togroup") - (subject) (sender) (group "togroup") - (subject) (sender "sender 2") (group "togroup")))) - - (message "Looking up individual keys (gnus-registry-id-key)") - (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup"))) - (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4"))) - (message "Trying to insert a duplicate key") - (should-error (gnus-registry-insert db "55" '())) - (message "Looking up individual keys (gnus-registry-get-or-make-entry)") - (should (gnus-registry-get-or-make-entry "22")) - (message "Saving the Gnus registry to %s" tempfile) - (should (gnus-registry-save tempfile db)) - (setq size (nth 7 (file-attributes tempfile))) - (message "Saving the Gnus registry to %s: size %d" tempfile size) - (should (< 0 size)) - (with-temp-buffer - (insert-file-contents-literally tempfile) - (should (looking-at (concat ";; Object " - "Gnus Registry" - "\n;; EIEIO PERSISTENT OBJECT")))) - (message "Reading Gnus registry back") - (setq back (eieio-persistent-read tempfile)) - (should back) - (message "Read Gnus registry back: %d keys, expected %d==%d" - (registry-size back) n (registry-size db)) - (should (= (registry-size back) n)) - (should (= (registry-size back) (registry-size db))) - (delete-file tempfile) - (message "Pruning Gnus registry to 0 by setting :max-soft") - (oset db :max-soft 0) - (registry-prune db) - (should (= (registry-size db) 0))) - (message "Done with Gnus registry usage testing.")) - ;;;###autoload (defun gnus-registry-initialize () "Initialize the Gnus registry." diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index ad2d71390..c4603b589 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -1504,8 +1504,6 @@ backend check whether the group actually exists." ;; Return the new active info. active))))) -(defvar gnus-propagate-marks) ; gnus-sum - (defun gnus-get-unread-articles-in-group (info active &optional update) (when (and info active) ;; Allow the backend to update the info in the group. @@ -1515,13 +1513,6 @@ backend check whether the group actually exists." (gnus-info-group info))))) (gnus-activate-group (gnus-info-group info) nil t)) - ;; Allow backends to update marks, - (when gnus-propagate-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)) @@ -2303,7 +2294,19 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-message 5 "Reading %s...done" newsrc-file))) ;; Convert old to new. - (gnus-convert-old-newsrc)))) + (gnus-convert-old-newsrc) + (gnus-clean-old-newsrc)))) + +(defun gnus-clean-old-newsrc () + (when gnus-newsrc-file-version + (when (< (gnus-continuum-version gnus-newsrc-file-version) + (gnus-continuum-version "Ma Gnus v0.03")) + ;; Remove old `exist' marks from old nnimap groups. + (dolist (info (cdr gnus-newsrc-alist)) + (let ((exist (assoc 'unexist (gnus-info-marks info)))) + (when exist + (gnus-info-set-marks + info (delete exist (gnus-info-marks info))))))))) (defun gnus-convert-old-newsrc () "Convert old newsrc formats into the current format, if needed." diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 8ae8d0b8a..703357320 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -1243,13 +1243,6 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :type 'boolean :group 'gnus-summary-marks) -(defcustom gnus-propagate-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." - :type 'boolean - :group 'gnus-summary-marks) - (defcustom gnus-alter-articles-to-read-function nil "Function to be called to alter the list of articles to be selected." :type '(choice (const nil) function) @@ -1530,6 +1523,9 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") (defvar gnus-newsgroup-seen nil "Range of seen articles in the current newsgroup.") +(defvar gnus-newsgroup-unexist nil + "Range of unexistent articles in the current newsgroup.") + (defvar gnus-newsgroup-articles nil "List of articles in the current newsgroup.") @@ -1577,6 +1573,7 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") gnus-newsgroup-killed gnus-newsgroup-unseen gnus-newsgroup-seen + gnus-newsgroup-unexist gnus-newsgroup-cached gnus-newsgroup-downloadable gnus-newsgroup-undownloaded @@ -1918,6 +1915,7 @@ increase the score of each group you read." "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article [tab] gnus-summary-widget-forward + [backtab] gnus-summary-widget-backward "t" gnus-summary-toggle-header "g" gnus-summary-show-article "l" gnus-summary-goto-last-article @@ -2082,6 +2080,7 @@ increase the score of each group you read." "g" gnus-summary-show-article "s" gnus-summary-isearch-article [tab] gnus-summary-widget-forward + [backtab] gnus-summary-widget-backward "P" gnus-summary-print-article "S" gnus-sticky-article "M" gnus-mailing-list-insinuate @@ -5673,7 +5672,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq gnus-newsgroup-unselected (gnus-sorted-difference gnus-newsgroup-unreads articles)) (setq articles (gnus-articles-to-read group read-all))) - + (cond ((null articles) ;;(gnus-message 3 "Couldn't select newsgroup -- no articles to display") @@ -5812,6 +5811,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." "Find out what articles the user wants to read." (let* ((only-read-p t) (articles + (gnus-list-range-difference ;; Select all articles if `read-all' is non-nil, or if there ;; are no unread articles. (if (or read-all @@ -5838,7 +5838,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq only-read-p nil) (gnus-sorted-nunion (gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked) - gnus-newsgroup-unreads))) + gnus-newsgroup-unreads)) + (cdr (assq 'unexist (gnus-info-marks (gnus-get-info group)))))) (scored-list (gnus-killed-articles gnus-newsgroup-killed articles)) (scored (length scored-list)) (number (length articles)) @@ -5965,7 +5966,6 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq mark (car marks) mark-type (gnus-article-mark-to-type mark) var (intern (format "gnus-newsgroup-%s" (car (rassq mark types))))) - ;; We set the variable according to the type of the marks list, ;; and then adjust the marks to a subset of the active articles. (cond @@ -6020,7 +6020,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." (and (numberp (car articles)) (> min (car articles))))) (pop articles)) - (set var articles)))))))) + (set var articles)) + ((eq mark 'unexist) + (set var (cdr marks))))))))) (defun gnus-update-missing-marks (missing) "Go through the list of MISSING articles and remove them from the mark lists." @@ -6285,10 +6287,9 @@ The resulting hash table is returned, or nil if no Xrefs were found." (info (nth 2 entry)) (active (gnus-active group)) (set-marks - (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group group) - 'server-marks))) + (gnus-method-option-p + (gnus-find-method-for-group group) + 'server-marks)) range) (if (not entry) ;; Group that Gnus doesn't know exists, but still allow the @@ -9266,6 +9267,17 @@ With optional ARG, move across that many fields." (select-window (gnus-get-buffer-window gnus-article-buffer)) (widget-forward arg)) +(defun gnus-summary-widget-backward (arg) + "Move point to the previous 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)) + (unless (widget-at (point)) + (goto-char (point-max))) + (widget-backward 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." @@ -10076,10 +10088,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." to-group 'expire (list to-article) info)) (when (and to-marks - (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group to-group) - 'server-marks))) + (gnus-method-option-p + (gnus-find-method-for-group to-group) + 'server-marks)) (gnus-request-set-mark to-group (list (list (list to-article) 'add to-marks))))) @@ -12561,10 +12572,9 @@ UNREAD is a sorted list." (save-excursion (let (setmarkundo) ;; Propagate the read marks to the backend. - (when (and (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group group) - 'server-marks)) + (when (and (gnus-method-option-p + (gnus-find-method-for-group group) + 'server-marks) (gnus-check-backend-function 'request-set-mark group)) (let ((del (gnus-remove-from-range (gnus-info-read info) read)) (add (gnus-remove-from-range read (gnus-info-read info)))) diff --git a/lisp/gnus-sync.el b/lisp/gnus-sync.el index 57c834add..6a45c672e 100644 --- a/lisp/gnus-sync.el +++ b/lisp/gnus-sync.el @@ -172,14 +172,11 @@ and `gnus-topic-alist'. Also see `gnus-variable-list'." (defun gnus-sync-lesync-call (url method headers &optional kvdata) "Make an access request to URL using KVDATA and METHOD. KVDATA must be an alist." - ;;(debug (json-encode kvdata)) - ;; (when (string-match-p "gmane.emacs.devel" url) (debug kvdata)) (flet ((json-alist-p (list) (gnus-sync-json-alist-p list))) ; temp patch (let ((url-request-method method) (url-request-extra-headers headers) (url-request-data (if kvdata (json-encode kvdata) nil))) (with-current-buffer (url-retrieve-synchronously url) - ;;(debug (buffer-string)) (let ((data (gnus-sync-lesync-parse))) (gnus-message 12 "gnus-sync-lesync-call: %s URL %s sent %S got %S" method url `((headers . ,headers) (data ,kvdata)) data) diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index da899f4bf..fef67cd52 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1927,6 +1927,19 @@ Sizes are in pixels." image))) image))) +(defun gnus-recursive-directory-files (dir) + "Return all regular files below DIR." + (let (files) + (dolist (file (directory-files dir t)) + (when (and (not (member (file-name-nondirectory file) '("." ".."))) + (file-readable-p file)) + (cond + ((file-regular-p file) + (push file files)) + ((file-directory-p file) + (setq files (append (gnus-recursive-directory-files file) files)))))) + files)) + (defun gnus-list-memq-of-list (elements list) "Return non-nil if any of the members of ELEMENTS are in LIST." (let ((found nil)) diff --git a/lisp/gnus.el b/lisp/gnus.el index f2b2982a5..8548474fd 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -36,6 +36,7 @@ (require 'wid-edit) (require 'mm-util) (require 'nnheader) +(require 'gnus-compat) ;; These are defined afterwards with gnus-define-group-parameter (defvar gnus-ham-process-destinations) @@ -293,10 +294,10 @@ is restarted, and sometimes reloaded." :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "0.20" +(defconst gnus-version-number "0.4" "Version number for this version of Gnus.") -(defconst gnus-version (format "No Gnus v%s" gnus-version-number) +(defconst gnus-version (format "Ma Gnus v%s" gnus-version-number) "Version string for this version of Gnus.") (defcustom gnus-inhibit-startup-message nil @@ -1008,10 +1009,11 @@ be set in `.emacs' instead." (purp "#9999cc" "#666699") (no "#ff0000" "#ffff00") (neutral "#b4b4b4" "#878787") + (ma "#2020e0" "#8080ff") (september "#bf9900" "#ffcc00")) "Color alist used for the Gnus logo.") -(defcustom gnus-logo-color-style 'no +(defcustom gnus-logo-color-style 'ma "*Color styles used for the Gnus logo." :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) gnus-logo-color-alist)) @@ -2618,10 +2620,11 @@ a string, be sure to use a valid format, see RFC 2616." (scored . score) (saved . save) (cached . cache) (downloadable . download) (unsendable . unsend) (forwarded . forward) - (seen . seen))) + (seen . seen) (unexist . unexist))) (defconst gnus-article-special-mark-lists '((seen range) + (unexist range) (killed range) (bookmark tuple) (uid tuple) @@ -2636,7 +2639,7 @@ a string, be sure to use a valid format, see RFC 2616." ;; `score' is not a proper mark ;; `bookmark': don't propagated it, or fix the bug in update-mark. (defconst gnus-article-unpropagated-mark-lists - '(seen cache download unsend score bookmark) + '(seen cache download unsend score bookmark unexist) "Marks that shouldn't be propagated to back ends. Typical marks are those that make no sense in a standalone back end, such as a mark that says whether an article is stored in the cache diff --git a/lisp/imap.el b/lisp/imap.el deleted file mode 100644 index 6a25be736..000000000 --- a/lisp/imap.el +++ /dev/null @@ -1,3056 +0,0 @@ -;;; imap.el --- imap library - -;; Copyright (C) 1998-2012 Free Software Foundation, Inc. - -;; Author: Simon Josefsson -;; Keywords: mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 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 . - -;;; Commentary: - -;; imap.el is an elisp library providing an interface for talking to -;; IMAP servers. -;; -;; imap.el is roughly divided in two parts, one that parses IMAP -;; responses from the server and storing data into buffer-local -;; variables, and one for utility functions which send commands to -;; server, waits for an answer, and return information. The latter -;; part is layered on top of the previous. -;; -;; The imap.el API consist of the following functions, other functions -;; in this file should not be called directly and the result of doing -;; so are at best undefined. -;; -;; Global commands: -;; -;; imap-open, imap-opened, imap-authenticate, imap-close, -;; imap-capability, imap-namespace, imap-error-text -;; -;; Mailbox commands: -;; -;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox, -;; imap-current-mailbox-p, imap-search, imap-mailbox-select, -;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge -;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete -;; imap-mailbox-rename, imap-mailbox-lsub, imap-mailbox-list -;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status -;; imap-mailbox-acl-get, imap-mailbox-acl-set, imap-mailbox-acl-delete -;; -;; Message commands: -;; -;; imap-fetch-asynch, imap-fetch, -;; imap-current-message, imap-list-to-message-set, -;; imap-message-get, imap-message-map -;; imap-message-envelope-date, imap-message-envelope-subject, -;; imap-message-envelope-from, imap-message-envelope-sender, -;; imap-message-envelope-reply-to, imap-message-envelope-to, -;; imap-message-envelope-cc, imap-message-envelope-bcc -;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id -;; imap-message-body, imap-message-flag-permanent-p -;; imap-message-flags-set, imap-message-flags-del -;; imap-message-flags-add, imap-message-copyuid -;; imap-message-copy, imap-message-appenduid -;; imap-message-append, imap-envelope-from -;; imap-body-lines -;; -;; It is my hope that these commands should be pretty self -;; explanatory for someone that know IMAP. All functions have -;; additional documentation on how to invoke them. -;; -;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1). The implemented -;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 -;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS, -;; LOGINDISABLED) (with use of external library starttls.el and -;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731 -;; (with use of external program `imtest'), and RFC2971 (ID). It also -;; takes advantage of the UNSELECT extension in Cyrus IMAPD. -;; -;; Without the work of John McClary Prevost and Jim Radford this library -;; would not have seen the light of day. Many thanks. -;; -;; This is a transcript of a short interactive session for demonstration -;; purposes. -;; -;; (imap-open "my.mail.server") -;; => " *imap* my.mail.server:0" -;; -;; The rest are invoked with current buffer as the buffer returned by -;; `imap-open'. It is possible to do it all without this, but it would -;; look ugly here since `buffer' is always the last argument for all -;; imap.el API functions. -;; -;; (imap-authenticate "myusername" "mypassword") -;; => auth -;; -;; (imap-mailbox-lsub "*") -;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam") -;; -;; (imap-mailbox-list "INBOX.n%") -;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq") -;; -;; (imap-mailbox-select "INBOX.nnimap") -;; => "INBOX.nnimap" -;; -;; (imap-mailbox-get 'exists) -;; => 166 -;; -;; (imap-mailbox-get 'uidvalidity) -;; => "908992622" -;; -;; (imap-search "FLAGGED SINCE 18-DEC-98") -;; => (235 236) -;; -;; (imap-fetch 235 "RFC822.PEEK" 'RFC822) -;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: ^M\r...." -;; -;; Todo: -;; -;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. -;; Use IEEE floats (which are effectively exact)? -- fx -;; o Don't use `read' at all (important places already fixed) -;; o Accept list of articles instead of message set string in most -;; imap-message-* functions. -;; o Send strings as literal if they contain, e.g., ". -;; -;; Revision history: -;; -;; - 19991218 added starttls/digest-md5 patch, -;; by Daiki Ueno -;; NB! you need SLIM for starttls.el and digest-md5.el -;; - 19991023 committed to pgnus -;; - -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (autoload 'starttls-open-stream "starttls") - (autoload 'starttls-negotiate "starttls") - (autoload 'sasl-find-mechanism "sasl") - (autoload 'digest-md5-parse-digest-challenge "digest-md5") - (autoload 'digest-md5-digest-response "digest-md5") - (autoload 'digest-md5-digest-uri "digest-md5") - (autoload 'digest-md5-challenge "digest-md5") - (autoload 'rfc2104-hash "rfc2104") - (autoload 'utf7-encode "utf7") - (autoload 'utf7-decode "utf7") - (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "format-spec") - (autoload 'open-tls-stream "tls")) - -;; User variables. - -(defgroup imap nil - "Low-level IMAP issues." - :version "21.1" - :group 'mail) - -(defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s" - "imtest -kp %s %p") - "List of strings containing commands for Kerberos 4 authentication. -%s is replaced with server hostname, %p with port to connect to, and -%l with the value of `imap-default-user'. The program should accept -IMAP commands on stdin and return responses to stdout. Each entry in -the list is tried until a successful connection is made." - :group 'imap - :type '(repeat string)) - -(defcustom imap-gssapi-program (list - (concat "gsasl %s %p " - "--mechanism GSSAPI " - "--authentication-id %l") - "imtest -m gssapi -u %l -p %p %s") - "List of strings containing commands for GSSAPI (krb5) authentication. -%s is replaced with server hostname, %p with port to connect to, and -%l with the value of `imap-default-user'. The program should accept -IMAP commands on stdin and return responses to stdout. Each entry in -the list is tried until a successful connection is made." - :group 'imap - :type '(repeat string)) - -(defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p" - "openssl s_client -quiet -ssl2 -connect %s:%p" - "s_client -quiet -ssl3 -connect %s:%p" - "s_client -quiet -ssl2 -connect %s:%p") - "A string, or list of strings, 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. Each entry in the list is tried -until a successful connection is made." - :group 'imap - :type '(choice string - (repeat string))) - -(defcustom imap-shell-program '("ssh %s imapd" - "rsh %s imapd" - "ssh %g ssh %s imapd" - "rsh %g rsh %s imapd") - "A list of strings, containing commands for IMAP connection. -Within a string, %s is replaced with the server address, %p with port -number on server, %g with `imap-shell-host', and %l with -`imap-default-user'. The program should read IMAP commands from stdin -and write IMAP response to stdout. Each entry in the list is tried -until a successful connection is made." - :group 'imap - :type '(repeat string)) - -(defcustom imap-process-connection-type nil - "*Value for `process-connection-type' to use for Kerberos4, GSSAPI, shell, and SSL. -The `process-connection-type' variable controls the type of device -used to communicate with subprocesses. Values are nil to use a -pipe, or t or `pty' to use a pty. The value has no effect if the -system has no ptys or if all ptys are busy: then a pipe is used -in any case. The value takes effect when an IMAP server is -opened; changing it after that has no effect." - :version "22.1" - :group 'imap - :type 'boolean) - -(defcustom imap-use-utf7 t - "If non-nil, do utf7 encoding/decoding of mailbox names. -Since the UTF7 decoding currently only decodes into ISO-8859-1 -characters, you may disable this decoding if you need to access UTF7 -encoded mailboxes which doesn't translate into ISO-8859-1." - :group 'imap - :type 'boolean) - -(defcustom imap-log nil - "If non-nil, an imap session trace is placed in `imap-log-buffer'. -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. - -See also `imap-debug'." - :group 'imap - :type 'boolean) - -(defcustom imap-debug nil - "If non-nil, trace imap- functions into `imap-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 `imap' library. -See also `imap-log'." - :group 'imap - :type 'boolean) - -(defcustom imap-shell-host "gateway" - "Hostname of rlogin proxy." - :group 'imap - :type 'string) - -(defcustom imap-default-user (user-login-name) - "Default username to use." - :group 'imap - :type 'string) - -(defcustom imap-read-timeout (if (string-match - "windows-nt\\|os/2\\|cygwin" - (symbol-name system-type)) - 1.0 - 0.1) - "*How long to wait between checking for the end of output. -Shorter values mean quicker response, but is more CPU intensive." - :type 'number - :group 'imap) - -(defcustom imap-store-password nil - "If non-nil, store session password without prompting." - :group 'imap - :type 'boolean) - -;; Various variables. - -(defvar imap-fetch-data-hook nil - "Hooks called after receiving each FETCH response.") - -(defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell) - "Priority of streams to consider when opening connection to server.") - -(defvar imap-stream-alist - '((gssapi imap-gssapi-stream-p imap-gssapi-open) - (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open) - (tls imap-tls-p imap-tls-open) - (ssl imap-ssl-p imap-ssl-open) - (network imap-network-p imap-network-open) - (shell imap-shell-p imap-shell-open) - (starttls imap-starttls-p imap-starttls-open)) - "Definition of network streams. - -\(NAME CHECK OPEN) - -NAME names the stream, CHECK is a function returning non-nil if the -server support the stream and OPEN is a function for opening the -stream.") - -(defvar imap-authenticators '(gssapi - kerberos4 - digest-md5 - cram-md5 - ;;sasl - login - anonymous) - "Priority of authenticators to consider when authenticating to server.") - -(defvar imap-authenticator-alist - '((gssapi imap-gssapi-auth-p imap-gssapi-auth) - (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth) - (sasl imap-sasl-auth-p imap-sasl-auth) - (cram-md5 imap-cram-md5-p imap-cram-md5-auth) - (login imap-login-p imap-login-auth) - (anonymous imap-anonymous-p imap-anonymous-auth) - (digest-md5 imap-digest-md5-p imap-digest-md5-auth)) - "Definition of authenticators. - -\(NAME CHECK AUTHENTICATE) - -NAME names the authenticator. CHECK is a function returning non-nil if -the server support the authenticator and AUTHENTICATE is a function -for doing the actual authentication.") - -(defvar imap-error nil - "Error codes from the last command.") - -(defvar imap-logout-timeout nil - "Close server immediately if it can't logout in this number of seconds. -If it is nil, never close server until logout completes. Normally, -the value of this variable will be bound to a certain value to which -an application program that uses this module specifies on a per-server -basis.") - -;; Internal constants. Change these and die. - -(defconst imap-default-port 143) -(defconst imap-default-ssl-port 993) -(defconst imap-default-tls-port 993) -(defconst imap-default-stream 'network) -(defconst imap-coding-system-for-read 'binary) -(defconst imap-coding-system-for-write 'binary) -(defconst imap-local-variables '(imap-server - imap-port - imap-client-eol - imap-server-eol - imap-auth - imap-stream - imap-username - imap-password - imap-current-mailbox - imap-current-target-mailbox - imap-message-data - imap-capability - imap-id - imap-namespace - imap-state - imap-reached-tag - imap-failed-tags - imap-tag - imap-process - imap-calculate-literal-size-first - imap-mailbox-data)) -(defconst imap-log-buffer "*imap-log*") -(defconst imap-debug-buffer "*imap-debug*") - -;; Internal variables. - -(defvar imap-stream nil) -(defvar imap-auth nil) -(defvar imap-server nil) -(defvar imap-port nil) -(defvar imap-username nil) -(defvar imap-password nil) -(defvar imap-last-authenticator nil) -(defvar imap-calculate-literal-size-first nil) -(defvar imap-state 'closed - "IMAP state. -Valid states are `closed', `initial', `nonauth', `auth', `selected' -and `examine'.") - -(defvar imap-server-eol "\r\n" - "The EOL string sent from the server.") - -(defvar imap-client-eol "\r\n" - "The EOL string we send to the server.") - -(defvar imap-current-mailbox nil - "Current mailbox name.") - -(defvar imap-current-target-mailbox nil - "Current target mailbox for COPY and APPEND commands.") - -(defvar imap-mailbox-data nil - "Obarray with mailbox data.") - -(defvar imap-mailbox-prime 997 - "Length of `imap-mailbox-data'.") - -(defvar imap-current-message nil - "Current message number.") - -(defvar imap-message-data nil - "Obarray with message data.") - -(defvar imap-message-prime 997 - "Length of `imap-message-data'.") - -(defvar imap-capability nil - "Capability for server.") - -(defvar imap-id nil - "Identity of server. -See RFC 2971.") - -(defvar imap-namespace nil - "Namespace for current server.") - -(defvar imap-reached-tag 0 - "Lower limit on command tags that have been parsed.") - -(defvar imap-failed-tags nil - "Alist of tags that failed. -Each element is a list with four elements; tag (a integer), response -state (a symbol, `OK', `NO' or `BAD'), response code (a string), and -human readable response text (a string).") - -(defvar imap-tag 0 - "Command tag number.") - -(defvar imap-process nil - "Process.") - -(defvar imap-continuation nil - "Non-nil indicates that the server emitted a continuation request. -The actual value is really the text on the continuation line.") - -(defvar imap-callbacks nil - "List of response tags and callbacks, on the form `(number . function)'. -The function should take two arguments, the first the IMAP tag and the -second the status (OK, NO, BAD etc) of the command.") - -(defvar imap-enable-exchange-bug-workaround nil - "Send FETCH UID commands as *:* instead of *. - -When non-nil, use an alternative UIDS form. Enabling appears to -be required for some servers (e.g., Microsoft Exchange 2007) -which otherwise would trigger a response 'BAD The specified -message set is invalid.'. We don't unconditionally use this -form, since this is said to be significantly inefficient. - -This variable is set to t automatically per server if the -canonical form fails.") - - -;; Utility functions: - -(defun imap-remassoc (key alist) - "Delete by side effect any elements of ALIST whose car is `equal' to KEY. -The modified ALIST is returned. If the first member -of ALIST has a car that is `equal' to KEY, there is no way to remove it -by side effect; therefore, write `(setq foo (remassoc key foo))' to be -sure of changing the value of `foo'." - (when alist - (if (equal key (caar alist)) - (cdr alist) - (setcdr alist (imap-remassoc key (cdr alist))) - alist))) - -(defmacro imap-disable-multibyte () - "Enable multibyte in the current buffer." - (unless (featurep 'xemacs) - '(set-buffer-multibyte nil))) - -(defsubst imap-utf7-encode (string) - (if imap-use-utf7 - (and string - (condition-case () - (utf7-encode string t) - (error (message - "imap: Could not UTF7 encode `%s', using it unencoded..." - string) - string))) - string)) - -(defsubst imap-utf7-decode (string) - (if imap-use-utf7 - (and string - (condition-case () - (utf7-decode string t) - (error (message - "imap: Could not UTF7 decode `%s', using it undecoded..." - string) - string))) - string)) - -(defsubst imap-ok-p (status) - (if (eq status 'OK) - t - (setq imap-error status) - nil)) - -(defun imap-error-text (&optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (nth 3 (car imap-failed-tags)))) - - -;; Server functions; stream stuff: - -(defun imap-log (string-or-buffer) - (when imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (if (bufferp string-or-buffer) - (insert-buffer-substring string-or-buffer) - (insert string-or-buffer))))) - -(defun imap-kerberos4-stream-p (buffer) - (imap-capability 'AUTH=KERBEROS_V4 buffer)) - -(defun imap-kerberos4-open (name buffer server port) - (let ((cmds imap-kerberos4-program) - cmd done) - (while (and (not done) (setq cmd (pop cmds))) - (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd) - (erase-buffer) - (let* ((port (or port imap-default-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process-connection-type imap-process-connection-type) - (process (start-process - name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) - response) - (when process - (with-current-buffer buffer - (setq imap-client-eol "\n" - imap-calculate-literal-size-first t) - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - ;; Athena IMTEST can output SSL verify errors - (or (while (looking-at "^verify error:num=") - (forward-line)) - t) - (or (while (looking-at "^TLS connection established") - (forward-line)) - t) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities - (or (while (looking-at "^C:") - (forward-line)) - t) - ;; cyrus 1.6 imtest print "S: " before server greeting - (or (not (looking-at "S: ")) - (forward-char 3) - t) - (not (and (imap-parse-greeting) - ;; success in imtest < 1.6: - (or (re-search-forward - "^__\\(.*\\)__\n" nil t) - ;; success in imtest 1.6: - (re-search-forward - "^\\(Authenticat.*\\)" nil t)) - (setq response (match-string 1))))) - (accept-process-output process 1) - (sit-for 1)) - (erase-buffer) - (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd - (if response (concat "done, " response) "failed")) - (if (and response (let ((case-fold-search nil)) - (not (string-match "failed" response)))) - (setq done process) - (if (memq (process-status process) '(open run)) - (imap-logout)) - (delete-process process) - nil))))) - done)) - -(defun imap-gssapi-stream-p (buffer) - (imap-capability 'AUTH=GSSAPI buffer)) - -(defun imap-gssapi-open (name buffer server port) - (let ((cmds imap-gssapi-program) - cmd done) - (while (and (not done) (setq cmd (pop cmds))) - (message "Opening GSSAPI IMAP connection with `%s'..." cmd) - (erase-buffer) - (let* ((port (or port imap-default-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process-connection-type imap-process-connection-type) - (process (start-process - name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) - response) - (when process - (with-current-buffer buffer - (setq imap-client-eol "\n" - imap-calculate-literal-size-first t) - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - ;; Athena IMTEST can output SSL verify errors - (or (while (looking-at "^verify error:num=") - (forward-line)) - t) - (or (while (looking-at "^TLS connection established") - (forward-line)) - t) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities - (or (while (looking-at "^C:") - (forward-line)) - t) - ;; cyrus 1.6 imtest print "S: " before server greeting - (or (not (looking-at "S: ")) - (forward-char 3) - t) - ;; GNU SASL may print 'Trying ...' first. - (or (not (looking-at "Trying ")) - (forward-line) - t) - (not (and (imap-parse-greeting) - ;; success in imtest 1.6: - (re-search-forward - (concat "^\\(\\(Authenticat.*\\)\\|\\(" - "Client authentication " - "finished.*\\)\\)") - nil t) - (setq response (match-string 1))))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log buffer) - (erase-buffer) - (message "GSSAPI IMAP connection: %s" (or response "failed")) - (if (and response (let ((case-fold-search nil)) - (not (string-match "failed" response)))) - (setq done process) - (if (memq (process-status process) '(open run)) - (imap-logout)) - (delete-process process) - nil))))) - done)) - -(defun imap-ssl-p (buffer) - nil) - -(defun imap-ssl-open (name buffer server port) - "Open an SSL connection to SERVER." - (let ((cmds (if (listp imap-ssl-program) imap-ssl-program - (list imap-ssl-program))) - cmd done) - (while (and (not done) (setq cmd (pop cmds))) - (message "imap: Opening SSL connection with `%s'..." cmd) - (erase-buffer) - (let* ((port (or port imap-default-ssl-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process-connection-type imap-process-connection-type) - (set-process-query-on-exit-flag - (if (fboundp 'set-process-query-on-exit-flag) - 'set-process-query-on-exit-flag - 'process-kill-without-query)) - process) - (when (progn - (setq process (start-process - name buffer shell-file-name - shell-command-switch - (format-spec cmd - (format-spec-make - ?s server - ?p (number-to-string port))))) - (funcall set-process-query-on-exit-flag process nil) - process) - (with-current-buffer buffer - (goto-char (point-min)) - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-max)) - (forward-line -1) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log buffer) - (erase-buffer) - (when (memq (process-status process) '(open run)) - (setq done process)))))) - (if done - (progn - (message "imap: Opening SSL connection with `%s'...done" cmd) - done) - (message "imap: Opening SSL connection with `%s'...failed" cmd) - nil))) - -(defun imap-tls-p (buffer) - nil) - -(defun imap-tls-open (name buffer server port) - (let* ((port (or port imap-default-tls-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process (open-tls-stream name buffer server port))) - (when process - (while (and (memq (process-status process) '(open run)) - ;; FIXME: Per the "blue moon" comment, the process/buffer - ;; handling here, and elsewhere in functions which open - ;; streams, looks confused. Obviously we can change buffers - ;; if a different process handler kicks in from - ;; `accept-process-output' or `sit-for' below, and TRT seems - ;; to be to `save-buffer' around those calls. (I wonder why - ;; `sit-for' is used with a non-zero wait.) -- fx - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-max)) - (forward-line -1) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log buffer) - (when (memq (process-status process) '(open run)) - process)))) - -(defun imap-network-p (buffer) - t) - -(defun imap-network-open (name buffer server port) - (let* ((port (or port imap-default-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process (open-network-stream name buffer server port))) - (when process - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log buffer) - (when (memq (process-status process) '(open run)) - process)))) - -(defun imap-shell-p (buffer) - nil) - -(defun imap-shell-open (name buffer server port) - (let ((cmds (if (listp imap-shell-program) imap-shell-program - (list imap-shell-program))) - cmd done) - (while (and (not done) (setq cmd (pop cmds))) - (message "imap: Opening IMAP connection with `%s'..." cmd) - (setq imap-client-eol "\n") - (let* ((port (or port imap-default-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process-connection-type imap-process-connection-type) - (process (start-process - name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?g imap-shell-host - ?p (number-to-string port) - ?l imap-default-user))))) - (when process - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-max)) - (forward-line -1) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log buffer) - (erase-buffer) - (when (memq (process-status process) '(open run)) - (setq done process))))) - (if done - (progn - (message "imap: Opening IMAP connection with `%s'...done" cmd) - done) - (message "imap: Opening IMAP connection with `%s'...failed" cmd) - nil))) - -(defun imap-starttls-p (buffer) - (imap-capability 'STARTTLS buffer)) - -(defun imap-starttls-open (name buffer server port) - (let* ((port (or port imap-default-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process (starttls-open-stream name buffer server port)) - done tls-info) - (message "imap: Connecting with STARTTLS...") - (when process - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-max)) - (forward-line -1) - (not (imap-parse-greeting))) - (accept-process-output process 1) - (sit-for 1)) - (imap-send-command "STARTTLS") - (while (and (memq (process-status process) '(open run)) - (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-max)) - (forward-line -1) - (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) - (accept-process-output process 1) - (sit-for 1)) - (imap-log buffer) - (when (and (setq tls-info (starttls-negotiate process)) - (memq (process-status process) '(open run))) - (setq done process))) - (if (stringp tls-info) - (message "imap: STARTTLS info: %s" tls-info)) - (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) - done)) - -;; Server functions; authenticator stuff: - -(defun imap-interactive-login (buffer loginfunc) - "Login to server in BUFFER. -LOGINFUNC is passed a username and a password, it should return t if -it where successful authenticating itself to the server, nil otherwise. -Returns t if login was successful, nil otherwise." - (with-current-buffer buffer - (make-local-variable 'imap-username) - (make-local-variable 'imap-password) - (let (user passwd ret) - ;; (condition-case () - (while (or (not user) (not passwd)) - (setq user (or imap-username - (read-from-minibuffer - (concat "imap: username for " imap-server - " (using stream `" (symbol-name imap-stream) - "'): ") - (or user imap-default-user)))) - (setq passwd (or imap-password - (read-passwd - (concat "imap: password for " user "@" - imap-server " (using authenticator `" - (symbol-name imap-auth) "'): ")))) - (when (and user passwd) - (if (funcall loginfunc user passwd) - (progn - (message "imap: Login successful...") - (setq ret t - imap-username user) - (when (and (not imap-password) - (or imap-store-password - (y-or-n-p "imap: Store password for this IMAP session? "))) - (setq imap-password passwd))) - (message "imap: Login failed...") - (setq passwd nil) - (setq imap-password nil) - (sit-for 1)))) - ;; (quit (with-current-buffer buffer - ;; (setq user nil - ;; passwd nil))) - ;; (error (with-current-buffer buffer - ;; (setq user nil - ;; passwd nil)))) - ret))) - -(defun imap-gssapi-auth-p (buffer) - (eq imap-stream 'gssapi)) - -(defun imap-gssapi-auth (buffer) - (message "imap: Authenticating using GSSAPI...%s" - (if (eq imap-stream 'gssapi) "done" "failed")) - (eq imap-stream 'gssapi)) - -(defun imap-kerberos4-auth-p (buffer) - (and (imap-capability 'AUTH=KERBEROS_V4 buffer) - (eq imap-stream 'kerberos4))) - -(defun imap-kerberos4-auth (buffer) - (message "imap: Authenticating using Kerberos 4...%s" - (if (eq imap-stream 'kerberos4) "done" "failed")) - (eq imap-stream 'kerberos4)) - -(defun imap-cram-md5-p (buffer) - (imap-capability 'AUTH=CRAM-MD5 buffer)) - -(defun imap-cram-md5-auth (buffer) - "Login to server using the AUTH CRAM-MD5 method." - (message "imap: Authenticating using CRAM-MD5...") - (let ((done (imap-interactive-login - buffer - (lambda (user passwd) - (imap-ok-p - (imap-send-command-wait - (list - "AUTHENTICATE CRAM-MD5" - (lambda (challenge) - (let* ((decoded (base64-decode-string challenge)) - (hash (rfc2104-hash 'md5 64 16 passwd decoded)) - (response (concat user " " hash)) - (encoded (base64-encode-string response))) - encoded))))))))) - (if done - (message "imap: Authenticating using CRAM-MD5...done") - (message "imap: Authenticating using CRAM-MD5...failed")))) - -(defun imap-login-p (buffer) - (and (not (imap-capability 'LOGINDISABLED buffer)) - (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) - -(defun imap-quote-specials (string) - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (re-search-forward "[\\\"]" nil t) - (forward-char -1) - (insert "\\") - (forward-char 1)) - (buffer-string))) - -(defun imap-login-auth (buffer) - "Login to server using the LOGIN command." - (message "imap: Plaintext authentication...") - (imap-interactive-login buffer - (lambda (user passwd) - (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" - (imap-quote-specials user) - "\" \"" - (imap-quote-specials passwd) - "\"")))))) - -(defun imap-anonymous-p (buffer) - t) - -(defun imap-anonymous-auth (buffer) - (message "imap: Logging in anonymously...") - (with-current-buffer buffer - (imap-ok-p (imap-send-command-wait - (concat "LOGIN anonymous \"" (concat (user-login-name) "@" - (system-name)) "\""))))) - -;;; Compiler directives. - -(defvar imap-sasl-client) -(defvar imap-sasl-step) - -(defun imap-sasl-make-mechanisms (buffer) - (let ((mecs '())) - (mapc (lambda (sym) - (let ((name (symbol-name sym))) - (if (and (> (length name) 5) - (string-equal "AUTH=" (substring name 0 5 ))) - (setq mecs (cons (substring name 5) mecs))))) - (imap-capability nil buffer)) - mecs)) - -(declare-function sasl-find-mechanism "sasl" (mechanism)) -(declare-function sasl-mechanism-name "sasl" (mechanism)) -(declare-function sasl-make-client "sasl" (mechanism name service server)) -(declare-function sasl-next-step "sasl" (client step)) -(declare-function sasl-step-data "sasl" (step)) -(declare-function sasl-step-set-data "sasl" (step data)) - -(defun imap-sasl-auth-p (buffer) - (and (condition-case () - (require 'sasl) - (error nil)) - (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))) - -(defun imap-sasl-auth (buffer) - "Login to server using the SASL method." - (message "imap: Authenticating using SASL...") - (with-current-buffer buffer - (make-local-variable 'imap-username) - (make-local-variable 'imap-sasl-client) - (make-local-variable 'imap-sasl-step) - (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))) - logged user) - (while (not logged) - (setq user (or imap-username - (read-from-minibuffer - (concat "IMAP username for " imap-server " using SASL " - (sasl-mechanism-name mechanism) ": ") - (or user imap-default-user)))) - (when user - (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server) - imap-sasl-step (sasl-next-step imap-sasl-client nil)) - (let ((tag (imap-send-command - (if (sasl-step-data imap-sasl-step) - (format "AUTHENTICATE %s %s" - (sasl-mechanism-name mechanism) - (sasl-step-data imap-sasl-step)) - (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism))) - buffer))) - (while (eq (imap-wait-for-tag tag) 'INCOMPLETE) - (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation)) - (setq imap-continuation nil - imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step)) - (imap-send-command-1 (if (sasl-step-data imap-sasl-step) - (base64-encode-string (sasl-step-data imap-sasl-step) t) - ""))) - (if (imap-ok-p (imap-wait-for-tag tag)) - (setq imap-username user - logged t) - (message "Login failed...") - (sit-for 1))))) - logged))) - -(defun imap-digest-md5-p (buffer) - (and (imap-capability 'AUTH=DIGEST-MD5 buffer) - (condition-case () - (require 'digest-md5) - (error nil)))) - -(defun imap-digest-md5-auth (buffer) - "Login to server using the AUTH DIGEST-MD5 method." - (message "imap: Authenticating using DIGEST-MD5...") - (imap-interactive-login - buffer - (lambda (user passwd) - (let ((tag - (imap-send-command - (list - "AUTHENTICATE DIGEST-MD5" - (lambda (challenge) - (digest-md5-parse-digest-challenge - (base64-decode-string challenge)) - (let* ((digest-uri - (digest-md5-digest-uri - "imap" (digest-md5-challenge 'realm))) - (response - (digest-md5-digest-response - user passwd digest-uri))) - (base64-encode-string response 'no-line-break)))) - ))) - (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - nil - (setq imap-continuation nil) - (imap-send-command-1 "") - (imap-ok-p (imap-wait-for-tag tag))))))) - -;; Server functions: - -(defun imap-open-1 (buffer) - (with-current-buffer buffer - (erase-buffer) - (setq imap-current-mailbox nil - imap-current-message nil - imap-state 'initial - imap-process (condition-case () - (funcall (nth 2 (assq imap-stream - imap-stream-alist)) - "imap" buffer imap-server imap-port) - ((error quit) nil))) - (when imap-process - (set-process-filter imap-process 'imap-arrival-filter) - (set-process-sentinel imap-process 'imap-sentinel) - (while (and (eq imap-state 'initial) - (memq (process-status imap-process) '(open run))) - (message "Waiting for response from %s..." imap-server) - (accept-process-output imap-process 1)) - (message "Waiting for response from %s...done" imap-server) - (and (memq (process-status imap-process) '(open run)) - imap-process)))) - -(defun imap-open (server &optional port stream auth buffer) - "Open an IMAP connection to host SERVER at PORT returning a buffer. -If PORT is unspecified, a default value is used (143 except -for SSL which use 993). -STREAM indicates the stream to use, see `imap-streams' for available -streams. If nil, it choices the best stream the server is capable of. -AUTH indicates authenticator to use, see `imap-authenticators' for -available authenticators. If nil, it choices the best stream the -server is capable of. -BUFFER can be a buffer or a name of a buffer, which is created if -necessary. If nil, the buffer name is generated." - (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0)))) - (with-current-buffer (get-buffer-create buffer) - (if (imap-opened buffer) - (imap-close buffer)) - (mapc 'make-local-variable imap-local-variables) - (imap-disable-multibyte) - (buffer-disable-undo) - (setq imap-server (or server imap-server)) - (setq imap-port (or port imap-port)) - (setq imap-auth (or auth imap-auth)) - (setq imap-stream (or stream imap-stream)) - (message "imap: Connecting to %s..." imap-server) - (if (null (let ((imap-stream (or imap-stream imap-default-stream))) - (imap-open-1 buffer))) - (progn - (message "imap: Connecting to %s...failed" imap-server) - nil) - (when (null imap-stream) - ;; Need to choose stream. - (let ((streams imap-streams)) - (while (setq stream (pop streams)) - ;; OK to use this stream? - (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - ;; Stream changed? - (if (not (eq imap-default-stream stream)) - (with-current-buffer (get-buffer-create - (generate-new-buffer-name " *temp*")) - (mapc 'make-local-variable imap-local-variables) - (imap-disable-multibyte) - (buffer-disable-undo) - (setq imap-server (or server imap-server)) - (setq imap-port (or port imap-port)) - (setq imap-auth (or auth imap-auth)) - (message "imap: Reconnecting with stream `%s'..." stream) - (if (null (let ((imap-stream stream)) - (imap-open-1 (current-buffer)))) - (progn - (kill-buffer (current-buffer)) - (message - "imap: Reconnecting with stream `%s'...failed" - stream)) - ;; We're done, kill the first connection - (imap-close buffer) - (let ((name (if (stringp buffer) - buffer - (buffer-name buffer)))) - (kill-buffer buffer) - (rename-buffer name) - ;; set the passed buffer to the current one, - ;; so that (imap-opened buffer) later will work - (setq buffer (current-buffer))) - (message "imap: Reconnecting with stream `%s'...done" - stream) - (setq imap-stream stream) - (setq imap-capability nil) - (setq streams nil))) - ;; We're done - (message "imap: Connecting to %s...done" imap-server) - (setq imap-stream stream) - (setq imap-capability nil) - (setq streams nil)))))) - (when (imap-opened buffer) - (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) - ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer) - (when imap-stream - buffer)))) - -(defcustom imap-ping-server t - "If non-nil, check if IMAP is open. -See the function `imap-ping-server'." - :version "23.1" ;; No Gnus - :group 'imap - :type 'boolean) - -(defun imap-opened (&optional buffer) - "Return non-nil if connection to imap server in BUFFER is open. -If BUFFER is nil then the current buffer is used." - (and (setq buffer (get-buffer (or buffer (current-buffer)))) - (buffer-live-p buffer) - (with-current-buffer buffer - (and imap-process - (memq (process-status imap-process) '(open run)) - (if imap-ping-server - (imap-ping-server) - t))))) - -(defun imap-ping-server (&optional buffer) - "Ping the IMAP server in BUFFER with a \"NOOP\" command. -Return non-nil if the server responds, and nil if it does not -respond. If BUFFER is nil, the current buffer is used." - (condition-case () - (imap-ok-p (imap-send-command-wait "NOOP" buffer)) - (error nil))) - -(defun imap-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 imap-state 'nonauth)) - (or (eq imap-state 'auth) - (eq imap-state 'selected) - (eq imap-state 'examine)) - (make-local-variable 'imap-username) - (make-local-variable 'imap-password) - (make-local-variable 'imap-last-authenticator) - (when user (setq imap-username user)) - (when passwd (setq imap-password passwd)) - (if imap-auth - (and (setq imap-last-authenticator - (assq imap-auth imap-authenticator-alist)) - (funcall (nth 2 imap-last-authenticator) (current-buffer)) - (setq imap-state 'auth)) - ;; Choose authenticator. - (let ((auths imap-authenticators) - auth) - (while (setq auth (pop auths)) - ;; OK to use authenticator? - (setq imap-last-authenticator - (assq auth imap-authenticator-alist)) - (when (funcall (nth 1 imap-last-authenticator) (current-buffer)) - (message "imap: Authenticating to `%s' using `%s'..." - imap-server auth) - (setq imap-auth auth) - (if (funcall (nth 2 imap-last-authenticator) (current-buffer)) - (progn - (message "imap: Authenticating to `%s' using `%s'...done" - imap-server auth) - ;; set imap-state correctly on successful auth attempt - (setq imap-state 'auth) - ;; stop iterating through the authenticator list - (setq auths nil)) - (message "imap: Authenticating to `%s' using `%s'...failed" - imap-server auth))))) - imap-state)))) - -(defun imap-close (&optional buffer) - "Close connection to server in BUFFER. -If BUFFER is nil, the current buffer is used." - (with-current-buffer (or buffer (current-buffer)) - (when (imap-opened) - (condition-case nil - (imap-logout-wait) - (quit nil))) - (when (and imap-process - (memq (process-status imap-process) '(open run))) - (delete-process imap-process)) - (setq imap-current-mailbox nil - imap-current-message nil - imap-process nil) - (erase-buffer) - t)) - -(defun imap-capability (&optional identifier buffer) - "Return a list of identifiers which server in BUFFER support. -If IDENTIFIER, return non-nil if it's among the servers capabilities. -If BUFFER is nil, the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (unless imap-capability - (unless (imap-ok-p (imap-send-command-wait "CAPABILITY")) - (setq imap-capability '(IMAP2)))) - (if identifier - (memq (intern (upcase (symbol-name identifier))) imap-capability) - imap-capability))) - -(defun imap-id (&optional list-of-values buffer) - "Identify client to server in BUFFER, and return server identity. -LIST-OF-VALUES is nil, or a plist with identifier and value -strings to send to the server to identify the client. - -Return a list of identifiers which server in BUFFER support, or -nil if it doesn't support ID or returns no information. - -If BUFFER is nil, the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (when (and (imap-capability 'ID) - (imap-ok-p (imap-send-command-wait - (if (null list-of-values) - "ID NIL" - (concat "ID (" (mapconcat (lambda (el) - (concat "\"" el "\"")) - list-of-values - " ") ")"))))) - imap-id))) - -(defun imap-namespace (&optional buffer) - "Return a namespace hierarchy at server in BUFFER. -If BUFFER is nil, the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (unless imap-namespace - (when (imap-capability 'NAMESPACE) - (imap-send-command-wait "NAMESPACE"))) - imap-namespace)) - -(defun imap-send-command-wait (command &optional buffer) - (imap-wait-for-tag (imap-send-command command buffer) buffer)) - -(defun imap-logout (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (if imap-logout-timeout - (with-timeout (imap-logout-timeout - (condition-case nil - (with-current-buffer buffer - (delete-process imap-process)) - (error))) - (imap-send-command "LOGOUT" buffer)) - (imap-send-command "LOGOUT" buffer))) - -(defun imap-logout-wait (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (if imap-logout-timeout - (with-timeout (imap-logout-timeout - (condition-case nil - (with-current-buffer buffer - (delete-process imap-process)) - (error))) - (imap-send-command-wait "LOGOUT" buffer)) - (imap-send-command-wait "LOGOUT" buffer))) - - -;; Mailbox functions: - -(defun imap-mailbox-put (propname value &optional mailbox buffer) - (with-current-buffer (or buffer (current-buffer)) - (if imap-mailbox-data - (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) - propname value) - (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" - propname value mailbox (current-buffer))) - t)) - -(defsubst imap-mailbox-get-1 (propname &optional mailbox) - (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data) - propname)) - -(defun imap-mailbox-get (propname &optional mailbox buffer) - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox))))) - -(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) - (with-current-buffer (or buffer (current-buffer)) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (if mailbox-decoder - (funcall mailbox-decoder (symbol-name s)) - (symbol-name s))) result)) - imap-mailbox-data) - result))) - -(defun imap-mailbox-map (func &optional buffer) - "Map a function across each mailbox in `imap-mailbox-data', returning a list. -Function should take a mailbox name (a string) as -the only argument." - (imap-mailbox-map-1 func 'imap-utf7-decode buffer)) - -(defun imap-current-mailbox (&optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-utf7-decode imap-current-mailbox))) - -(defun imap-current-mailbox-p-1 (mailbox &optional examine) - (and (string= mailbox imap-current-mailbox) - (or (and examine - (eq imap-state 'examine)) - (and (not examine) - (eq imap-state 'selected))))) - -(defun imap-current-mailbox-p (mailbox &optional examine buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine))) - -(defun imap-mailbox-select-1 (mailbox &optional examine) - "Select MAILBOX on server in BUFFER. -If EXAMINE is non-nil, do a read-only select." - (if (imap-current-mailbox-p-1 mailbox examine) - imap-current-mailbox - (setq imap-current-mailbox mailbox) - (if (imap-ok-p (imap-send-command-wait - (concat (if examine "EXAMINE" "SELECT") " \"" - mailbox "\""))) - (progn - (setq imap-message-data (make-vector imap-message-prime 0) - imap-state (if examine 'examine 'selected)) - imap-current-mailbox) - ;; Failed SELECT/EXAMINE unselects current mailbox - (setq imap-current-mailbox nil)))) - -(defun imap-mailbox-select (mailbox &optional examine buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-utf7-decode - (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine)))) - -(defun imap-mailbox-examine-1 (mailbox &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-select-1 mailbox 'examine))) - -(defun imap-mailbox-examine (mailbox &optional buffer) - "Examine MAILBOX on server in BUFFER." - (imap-mailbox-select mailbox 'examine buffer)) - -(defun imap-mailbox-unselect (&optional buffer) - "Close current folder in BUFFER, without expunging articles." - (with-current-buffer (or buffer (current-buffer)) - (when (or (eq imap-state 'auth) - (and (imap-capability 'UNSELECT) - (imap-ok-p (imap-send-command-wait "UNSELECT"))) - (and (imap-ok-p - (imap-send-command-wait (concat "EXAMINE \"" - imap-current-mailbox - "\""))) - (imap-ok-p (imap-send-command-wait "CLOSE")))) - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth) - t))) - -(defun imap-mailbox-expunge (&optional asynch buffer) - "Expunge articles in current folder in BUFFER. -If ASYNCH, do not wait for successful completion of the command. -If BUFFER is nil the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (when (and imap-current-mailbox (not (eq imap-state 'examine))) - (if asynch - (imap-send-command "EXPUNGE") - (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) - -(defun imap-mailbox-close (&optional asynch buffer) - "Expunge articles and close current folder in BUFFER. -If ASYNCH, do not wait for successful completion of the command. -If BUFFER is nil the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (when imap-current-mailbox - (if asynch - (imap-add-callback (imap-send-command "CLOSE") - `(lambda (tag status) - (message "IMAP mailbox `%s' closed... %s" - imap-current-mailbox status) - (when (eq ,imap-current-mailbox - imap-current-mailbox) - ;; Don't wipe out data if another mailbox - ;; was selected... - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth)))) - (when (imap-ok-p (imap-send-command-wait "CLOSE")) - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth))) - t))) - -(defun imap-mailbox-create-1 (mailbox) - (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\"")))) - -(defun imap-mailbox-create (mailbox &optional buffer) - "Create MAILBOX on server in BUFFER. -If BUFFER is nil the current buffer is assumed." - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-create-1 (imap-utf7-encode mailbox)))) - -(defun imap-mailbox-delete (mailbox &optional buffer) - "Delete MAILBOX on server in BUFFER. -If BUFFER is nil the current buffer is assumed." - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p - (imap-send-command-wait (list "DELETE \"" mailbox "\"")))))) - -(defun imap-mailbox-rename (oldname newname &optional buffer) - "Rename mailbox OLDNAME to NEWNAME on server in BUFFER. -If BUFFER is nil the current buffer is assumed." - (let ((oldname (imap-utf7-encode oldname)) - (newname (imap-utf7-encode newname))) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p - (imap-send-command-wait (list "RENAME \"" oldname "\" " - "\"" newname "\"")))))) - -(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer) - "Return a list of subscribed mailboxes on server in BUFFER. -If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is -non-nil, a hierarchy delimiter is added to root. REFERENCE is a -implementation-specific string that has to be passed to lsub command." - (with-current-buffer (or buffer (current-buffer)) - ;; Make sure we know the hierarchy separator for root's hierarchy - (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root))) - (imap-send-command-wait (concat "LIST \"" reference "\" \"" - (imap-utf7-encode root) "\""))) - ;; clear list data (NB not delimiter and other stuff) - (imap-mailbox-map-1 (lambda (mailbox) - (imap-mailbox-put 'lsub nil mailbox))) - (when (imap-ok-p - (imap-send-command-wait - (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root) - (and add-delimiter (imap-mailbox-get-1 'delimiter root)) - "%\""))) - (let (out) - (imap-mailbox-map-1 (lambda (mailbox) - (when (imap-mailbox-get-1 'lsub mailbox) - (push (imap-utf7-decode mailbox) out)))) - (nreverse out))))) - -(defun imap-mailbox-list (root &optional reference add-delimiter buffer) - "Return a list of mailboxes matching ROOT on server in BUFFER. -If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to -root. REFERENCE is a implementation-specific string that has to be -passed to list command." - (with-current-buffer (or buffer (current-buffer)) - ;; Make sure we know the hierarchy separator for root's hierarchy - (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root))) - (imap-send-command-wait (concat "LIST \"" reference "\" \"" - (imap-utf7-encode root) "\""))) - ;; clear list data (NB not delimiter and other stuff) - (imap-mailbox-map-1 (lambda (mailbox) - (imap-mailbox-put 'list nil mailbox))) - (when (imap-ok-p - (imap-send-command-wait - (concat "LIST \"" reference "\" \"" (imap-utf7-encode root) - (and add-delimiter (imap-mailbox-get-1 'delimiter root)) - "%\""))) - (let (out) - (imap-mailbox-map-1 (lambda (mailbox) - (when (imap-mailbox-get-1 'list mailbox) - (push (imap-utf7-decode mailbox) out)))) - (nreverse out))))) - -(defun imap-mailbox-subscribe (mailbox &optional buffer) - "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER. -Returns non-nil if successful." - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" - (imap-utf7-encode mailbox) - "\""))))) - -(defun imap-mailbox-unsubscribe (mailbox &optional buffer) - "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER. -Returns non-nil if successful." - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " - (imap-utf7-encode mailbox) - "\""))))) - -(defun imap-mailbox-status (mailbox items &optional buffer) - "Get status items ITEM in MAILBOX from server in BUFFER. -ITEMS can be a symbol or a list of symbols, valid symbols are one of -the STATUS data items -- i.e. `messages', `recent', `uidnext', `uidvalidity', -or `unseen'. If ITEMS is a list of symbols, a list of values is -returned, if ITEMS is a symbol only its value is returned." - (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p - (imap-send-command-wait (list "STATUS \"" - (imap-utf7-encode mailbox) - "\" " - (upcase - (format "%s" - (if (listp items) - items - (list items))))))) - (if (listp items) - (mapcar (lambda (item) - (imap-mailbox-get item mailbox)) - items) - (imap-mailbox-get items mailbox))))) - -(defun imap-mailbox-status-asynch (mailbox items &optional buffer) - "Send status item request ITEM on MAILBOX to server in BUFFER. -ITEMS can be a symbol or a list of symbols, valid symbols are one of -the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity -or 'unseen. The IMAP command tag is returned." - (with-current-buffer (or buffer (current-buffer)) - (imap-send-command (list "STATUS \"" - (imap-utf7-encode mailbox) - "\" " - (upcase - (format "%s" - (if (listp items) - items - (list items)))))))) - -(defun imap-mailbox-acl-get (&optional mailbox buffer) - "Get ACL on MAILBOX from server in BUFFER." - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p - (imap-send-command-wait (list "GETACL \"" - (or mailbox imap-current-mailbox) - "\""))) - (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox)))))) - -(defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer) - "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER." - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p - (imap-send-command-wait (list "SETACL \"" - (or mailbox imap-current-mailbox) - "\" " - identifier - " " - rights)))))) - -(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer) - "Remove any pair for IDENTIFIER in MAILBOX from server in BUFFER." - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p - (imap-send-command-wait (list "DELETEACL \"" - (or mailbox imap-current-mailbox) - "\" " - identifier)))))) - - -;; Message functions: - -(defun imap-current-message (&optional buffer) - (with-current-buffer (or buffer (current-buffer)) - imap-current-message)) - -(defun imap-list-to-message-set (list) - (mapconcat (lambda (item) - (number-to-string item)) - (if (listp list) - list - (list list)) - ",")) - -(defun imap-range-to-message-set (range) - (mapconcat - (lambda (item) - (if (consp item) - (format "%d:%d" - (car item) (cdr item)) - (format "%d" item))) - (if (and (listp range) (not (listp (cdr range)))) - (list range) ;; make (1 . 2) into ((1 . 2)) - range) - ",")) - -(defun imap-fetch-asynch (uids props &optional nouidfetch buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ") - (if (listp uids) - (imap-list-to-message-set uids) - uids) - props)))) - -(defun imap-fetch (uids props &optional receive nouidfetch buffer) - "Fetch properties PROPS from message set UIDS from server in BUFFER. -UIDS can be a string, number or a list of numbers. If RECEIVE -is non-nil return these properties." - (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p (imap-send-command-wait - (format "%sFETCH %s %s" (if nouidfetch "" "UID ") - (if (listp uids) - (imap-list-to-message-set uids) - uids) - props))) - (if (or (null receive) (stringp uids)) - t - (if (listp uids) - (mapcar (lambda (uid) - (if (listp receive) - (mapcar (lambda (prop) - (imap-message-get uid prop)) - receive) - (imap-message-get uid receive))) - uids) - (imap-message-get uids receive)))))) - -(defun imap-message-put (uid propname value &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (if imap-message-data - (put (intern (number-to-string uid) imap-message-data) - propname value) - (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" - uid propname value (current-buffer))) - t)) - -(defun imap-message-get (uid propname &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (get (intern-soft (number-to-string uid) imap-message-data) - propname))) - -(defun imap-message-map (func propname &optional buffer) - "Map a function across each message in `imap-message-data', returning a list." - (with-current-buffer (or buffer (current-buffer)) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (get s 'UID) (get s propname)) result)) - imap-message-data) - result))) - -(defmacro imap-message-envelope-date (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 0))) - -(defmacro imap-message-envelope-subject (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 1))) - -(defmacro imap-message-envelope-from (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 2))) - -(defmacro imap-message-envelope-sender (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 3))) - -(defmacro imap-message-envelope-reply-to (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 4))) - -(defmacro imap-message-envelope-to (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 5))) - -(defmacro imap-message-envelope-cc (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 6))) - -(defmacro imap-message-envelope-bcc (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 7))) - -(defmacro imap-message-envelope-in-reply-to (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 8))) - -(defmacro imap-message-envelope-message-id (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (elt (imap-message-get ,uid 'ENVELOPE) 9))) - -(defmacro imap-message-body (uid &optional buffer) - `(with-current-buffer (or ,buffer (current-buffer)) - (imap-message-get ,uid 'BODY))) - -;; FIXME: Should this try to use CHARSET? -- fx -(defun imap-search (predicate &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-put 'search 'dummy) - (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) - (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) - (progn - (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...") - nil) - (imap-mailbox-get-1 'search imap-current-mailbox))))) - -(defun imap-message-flag-permanent-p (flag &optional mailbox buffer) - "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER." - (with-current-buffer (or buffer (current-buffer)) - (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox)) - (member flag (imap-mailbox-get 'permanentflags mailbox))))) - -(defun imap-message-flags-set (articles flags &optional silent buffer) - (when (and articles flags) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait - (concat "UID STORE " articles - " FLAGS" (if silent ".SILENT") " (" flags ")")))))) - -(defun imap-message-flags-del (articles flags &optional silent buffer) - (when (and articles flags) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait - (concat "UID STORE " articles - " -FLAGS" (if silent ".SILENT") " (" flags ")")))))) - -(defun imap-message-flags-add (articles flags &optional silent buffer) - (when (and articles flags) - (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait - (concat "UID STORE " articles - " +FLAGS" (if silent ".SILENT") " (" flags ")")))))) - -;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343 -;; Signal an error if we'd get an integer overflow. -;; -;; FIXME: Identify relevant calls to `string-to-number' and replace them with -;; `imap-string-to-integer'. -(defun imap-string-to-integer (string &optional base) - (let ((number (string-to-number string base))) - (if (> number most-positive-fixnum) - (error - (format "String %s cannot be converted to a Lisp integer" number)) - number))) - -(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) - "Like `imap-fetch', but DTRT with Exchange 2007 bug. -However, UIDS here is a cons, where the car is the canonical form -of the UIDS specification, and the cdr is the one which works with -Exchange 2007 or, potentially, other buggy servers. -See `imap-enable-exchange-bug-workaround'." - ;; The first time we get here for a given, we'll try the canonical - ;; form. If we get the known error from the buggy server, set the - ;; flag buffer-locally (to account for connections to multiple - ;; servers), then re-try with the alternative UIDS spec. We don't - ;; unconditionally use the alternative form, since the - ;; currently-used alternatives are seriously inefficient with some - ;; servers (although they are valid). - ;; - ;; FIXME: Maybe it would be cleaner to have a flag to not signal - ;; the error (which otherwise gives a message), and test - ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of - ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:* - ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not - ;; to do the same? - (condition-case data - ;; Binding `debug-on-error' allows us to get the error from - ;; `imap-parse-response' -- it's normally caught by Emacs around - ;; execution of a process filter. - (let ((debug-on-error t)) - (imap-fetch (if imap-enable-exchange-bug-workaround - (cdr uids) - (car uids)) - props receive nouidfetch buffer)) - (error - (if (and (not imap-enable-exchange-bug-workaround) - ;; This is the Exchange 2007 response. It may be more - ;; robust just to check for a BAD response to the - ;; attempted fetch. - (string-match "The specified message set is invalid" - (cadr data))) - (with-current-buffer (or buffer (current-buffer)) - (set (make-local-variable 'imap-enable-exchange-bug-workaround) - t) - (imap-fetch (cdr uids) props receive nouidfetch)) - (signal (car data) (cdr data)))))) - -(defun imap-message-copyuid-1 (mailbox) - (if (imap-capability 'UIDPLUS) - (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) - (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) - (let ((old-mailbox imap-current-mailbox) - (state imap-state) - (imap-message-data (make-vector 2 0))) - (when (imap-mailbox-examine-1 mailbox) - (prog1 - (and (imap-fetch-safe '("*" . "*:*") "UID") - (list (imap-mailbox-get-1 'uidvalidity mailbox) - (apply 'max (imap-message-map - (lambda (uid prop) uid) 'UID)))) - (if old-mailbox - (imap-mailbox-select old-mailbox (eq state 'examine)) - (imap-mailbox-unselect))))))) - -(defun imap-message-copyuid (mailbox &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-message-copyuid-1 (imap-utf7-decode mailbox)))) - -(defun imap-message-copy (articles mailbox - &optional dont-create no-copyuid buffer) - "Copy ARTICLES to MAILBOX on server in BUFFER. -ARTICLES is a string message set. Create mailbox if it doesn't exist, -unless DONT-CREATE is non-nil. On success, return a list with -the UIDVALIDITY of the mailbox the article(s) was copied to as the -first element. The rest of list contains the saved articles' UIDs." - (when articles - (with-current-buffer (or buffer (current-buffer)) - (let ((mailbox (imap-utf7-encode mailbox))) - (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\"")) - (imap-current-target-mailbox mailbox)) - (if (imap-ok-p (imap-send-command-wait cmd)) - t - (when (and (not dont-create) - ;; removed because of buggy Oracle server - ;; that doesn't send TRYCREATE tags (which - ;; is a MUST according to specifications): - ;;(imap-mailbox-get-1 'trycreate mailbox) - (imap-mailbox-create-1 mailbox)) - (imap-ok-p (imap-send-command-wait cmd))))) - (or no-copyuid - (imap-message-copyuid-1 mailbox))))))) - -;; FIXME: Amalgamate with imap-message-copyuid-1, using an extra arg, since it -;; shares most of the code? -- fx -(defun imap-message-appenduid-1 (mailbox) - (if (imap-capability 'UIDPLUS) - (imap-mailbox-get-1 'appenduid mailbox) - (let ((old-mailbox imap-current-mailbox) - (state imap-state) - (imap-message-data (make-vector 2 0))) - (when (imap-mailbox-examine-1 mailbox) - (prog1 - (and (imap-fetch-safe '("*" . "*:*") "UID") - (list (imap-mailbox-get-1 'uidvalidity mailbox) - (apply 'max (imap-message-map - (lambda (uid prop) uid) 'UID)))) - (if old-mailbox - (imap-mailbox-select old-mailbox (eq state 'examine)) - (imap-mailbox-unselect))))))) - -(defun imap-message-appenduid (mailbox &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (imap-message-appenduid-1 (imap-utf7-encode mailbox)))) - -(defun imap-message-append (mailbox article &optional flags date-time buffer) - "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER. -FLAGS and DATE-TIME is currently not used. Return a cons holding -uidvalidity of MAILBOX and UID the newly created article got, or nil -on failure." - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (and (let ((imap-current-target-mailbox mailbox)) - (imap-ok-p - (imap-send-command-wait - (list "APPEND \"" mailbox "\" " article)))) - (imap-message-appenduid-1 mailbox))))) - -(defun imap-body-lines (body) - "Return number of lines in article by looking at the mime bodystructure BODY." - (if (listp body) - (if (stringp (car body)) - (cond ((and (string= (upcase (car body)) "TEXT") - (numberp (nth 7 body))) - (nth 7 body)) - ((and (string= (upcase (car body)) "MESSAGE") - (numberp (nth 9 body))) - (nth 9 body)) - (t 0)) - (apply '+ (mapcar 'imap-body-lines body))) - 0)) - -(defun imap-envelope-from (from) - "Return a from string line." - (and from - (concat (aref from 0) - (if (aref from 0) " <") - (aref from 2) - "@" - (aref from 3) - (if (aref from 0) ">")))) - - -;; Internal functions. - -(defun imap-add-callback (tag func) - (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) - -(defun imap-send-command-1 (cmdstr) - (setq cmdstr (concat cmdstr imap-client-eol)) - (imap-log cmdstr) - (process-send-string imap-process cmdstr)) - -(defun imap-send-command (command &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (if (not (listp command)) (setq command (list command))) - (let ((tag (setq imap-tag (1+ imap-tag))) - cmd cmdstr) - (setq cmdstr (concat (number-to-string imap-tag) " ")) - (while (setq cmd (pop command)) - (cond ((stringp cmd) - (setq cmdstr (concat cmdstr cmd))) - ((bufferp cmd) - (let ((eol imap-client-eol) - (calcfirst imap-calculate-literal-size-first) - size) - (with-current-buffer cmd - (if calcfirst - (setq size (buffer-size))) - (when (not (equal eol "\r\n")) - ;; XXX modifies buffer! - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match eol))) - (if (not calcfirst) - (setq size (buffer-size)))) - (setq cmdstr - (concat cmdstr (format "{%d}" size)))) - (unwind-protect - (progn - (imap-send-command-1 cmdstr) - (setq cmdstr nil) - (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil) ;; abort command if no cont-req - (let ((process imap-process) - (stream imap-stream) - (eol imap-client-eol)) - (with-current-buffer cmd - (imap-log cmd) - (process-send-region process (point-min) - (point-max))) - (process-send-string process imap-client-eol)))) - (setq imap-continuation nil))) - ((functionp cmd) - (imap-send-command-1 cmdstr) - (setq cmdstr nil) - (unwind-protect - (setq command - (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - nil ;; abort command if no cont-req - (cons (funcall cmd imap-continuation) - command))) - (setq imap-continuation nil))) - (t - (error "Unknown command type")))) - (if cmdstr - (imap-send-command-1 cmdstr)) - tag))) - -(defun imap-wait-for-tag (tag &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (let (imap-have-messaged) - (while (and (null imap-continuation) - (memq (process-status imap-process) '(open run)) - (< imap-reached-tag tag)) - (let ((len (/ (buffer-size) 1024)) - message-log-max) - (unless (< len 10) - (setq imap-have-messaged t) - (message "imap read: %dk" len)) - (accept-process-output imap-process - (truncate imap-read-timeout) - (truncate (* (- imap-read-timeout - (truncate imap-read-timeout)) - 1000))))) - ;; A process can die _before_ we have processed everything it - ;; has to say. Moreover, this can happen in between the call to - ;; accept-process-output and the call to process-status in an - ;; iteration of the loop above. - (when (and (null imap-continuation) - (< imap-reached-tag tag)) - (accept-process-output imap-process 0 0)) - (when imap-have-messaged - (message "")) - (and (memq (process-status imap-process) '(open run)) - (or (assq tag imap-failed-tags) - (if imap-continuation - 'INCOMPLETE - 'OK)))))) - -(defun imap-sentinel (process string) - (delete-process process)) - -(defun imap-find-next-line () - "Return point at end of current line, taking into account literals. -Return nil if no complete line has arrived." - (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}" - imap-server-eol) - nil t) - (if (match-string 1) - (if (< (point-max) (+ (point) (string-to-number (match-string 1)))) - nil - (goto-char (+ (point) (string-to-number (match-string 1)))) - (imap-find-next-line)) - (point)))) - -(defun imap-arrival-filter (proc string) - "IMAP process filter." - ;; Sometimes, we are called even though the process has died. - ;; Better abstain from doing stuff in that case. - (when (buffer-name (process-buffer proc)) - (with-current-buffer (process-buffer proc) - (goto-char (point-max)) - (insert string) - (imap-log string) - (let (end) - (goto-char (point-min)) - (while (setq end (imap-find-next-line)) - (save-restriction - (narrow-to-region (point-min) end) - (delete-char (- (length imap-server-eol))) - (goto-char (point-min)) - (unwind-protect - (cond ((eq imap-state 'initial) - (imap-parse-greeting)) - ((or (eq imap-state 'auth) - (eq imap-state 'nonauth) - (eq imap-state 'selected) - (eq imap-state 'examine)) - (imap-parse-response)) - (t - (message "Unknown state %s in arrival filter" - imap-state))) - (delete-region (point-min) (point-max))))))))) - - -;; Imap parser. - -(defsubst imap-forward () - (or (eobp) (forward-char))) - -;; number = 1*DIGIT -;; ; Unsigned 32-bit integer -;; ; (0 <= n < 4,294,967,296) - -(defsubst imap-parse-number () - (when (looking-at "[0-9]+") - (prog1 - (string-to-number (match-string 0)) - (goto-char (match-end 0))))) - -;; literal = "{" number "}" CRLF *CHAR8 -;; ; Number represents the number of CHAR8s - -(defsubst imap-parse-literal () - (when (looking-at "{\\([0-9]+\\)}\r\n") - (let ((pos (match-end 0)) - (len (string-to-number (match-string 1)))) - (if (< (point-max) (+ pos len)) - nil - (goto-char (+ pos len)) - (buffer-substring pos (+ pos len)))))) - -;; string = quoted / literal -;; -;; quoted = DQUOTE *QUOTED-CHAR DQUOTE -;; -;; QUOTED-CHAR = / -;; "\" quoted-specials -;; -;; quoted-specials = DQUOTE / "\" -;; -;; TEXT-CHAR = - -(defsubst imap-parse-string () - (cond ((eq (char-after) ?\") - (forward-char 1) - (let ((p (point)) (name "")) - (skip-chars-forward "^\"\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^\"\\\\") - (setq name (concat name (buffer-substring p (point))))) - (forward-char 1) - name)) - ((eq (char-after) ?{) - (imap-parse-literal)))) - -;; nil = "NIL" - -(defsubst imap-parse-nil () - (if (looking-at "NIL") - (goto-char (match-end 0)))) - -;; nstring = string / nil - -(defsubst imap-parse-nstring () - (or (imap-parse-string) - (and (imap-parse-nil) - nil))) - -;; astring = atom / string -;; -;; atom = 1*ATOM-CHAR -;; -;; ATOM-CHAR = -;; -;; atom-specials = "(" / ")" / "{" / SP / CTL / list-wildcards / -;; quoted-specials -;; -;; list-wildcards = "%" / "*" -;; -;; quoted-specials = DQUOTE / "\" - -(defsubst imap-parse-astring () - (or (imap-parse-string) - (buffer-substring (point) - (if (re-search-forward "[(){ \r\n%*\"\\]" nil t) - (goto-char (1- (match-end 0))) - (end-of-line) - (point))))) - -;; address = "(" addr-name SP addr-adl SP addr-mailbox SP -;; addr-host ")" -;; -;; addr-adl = nstring -;; ; Holds route from [RFC-822] route-addr if -;; ; non-nil -;; -;; addr-host = nstring -;; ; nil indicates [RFC-822] group syntax. -;; ; Otherwise, holds [RFC-822] domain name -;; -;; addr-mailbox = nstring -;; ; nil indicates end of [RFC-822] group; if -;; ; non-nil and addr-host is nil, holds -;; ; [RFC-822] group name. -;; ; Otherwise, holds [RFC-822] local-part -;; ; after removing [RFC-822] quoting -;; -;; addr-name = nstring -;; ; If non-nil, holds phrase from [RFC-822] -;; ; mailbox after removing [RFC-822] quoting -;; - -(defsubst imap-parse-address () - (let (address) - (when (eq (char-after) ?\() - (imap-forward) - (setq address (vector (prog1 (imap-parse-nstring) - (imap-forward)) - (prog1 (imap-parse-nstring) - (imap-forward)) - (prog1 (imap-parse-nstring) - (imap-forward)) - (imap-parse-nstring))) - (when (eq (char-after) ?\)) - (imap-forward) - address)))) - -;; address-list = "(" 1*address ")" / nil -;; -;; nil = "NIL" - -(defsubst imap-parse-address-list () - (if (eq (char-after) ?\() - (let (address addresses) - (imap-forward) - (while (and (not (eq (char-after) ?\))) - ;; next line for MS Exchange bug - (progn (and (eq (char-after) ? ) (imap-forward)) t) - (setq address (imap-parse-address))) - (setq addresses (cons address addresses))) - (when (eq (char-after) ?\)) - (imap-forward) - (nreverse addresses))) - ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-address-list") - (imap-parse-nil))) - -;; mailbox = "INBOX" / astring -;; ; INBOX is case-insensitive. All case variants of -;; ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX -;; ; not as an astring. An astring which consists of -;; ; the case-insensitive sequence "I" "N" "B" "O" "X" -;; ; is considered to be INBOX and not an astring. -;; ; Refer to section 5.1 for further -;; ; semantic details of mailbox names. - -(defsubst imap-parse-mailbox () - (let ((mailbox (imap-parse-astring))) - (if (string-equal "INBOX" (upcase mailbox)) - "INBOX" - mailbox))) - -;; greeting = "*" SP (resp-cond-auth / resp-cond-bye) CRLF -;; -;; resp-cond-auth = ("OK" / "PREAUTH") SP resp-text -;; ; Authentication condition -;; -;; resp-cond-bye = "BYE" SP resp-text - -(defun imap-parse-greeting () - "Parse an IMAP greeting." - (cond ((looking-at "\\* OK ") - (setq imap-state 'nonauth)) - ((looking-at "\\* PREAUTH ") - (setq imap-state 'auth)) - ((looking-at "\\* BYE ") - (setq imap-state 'closed)))) - -;; response = *(continue-req / response-data) response-done -;; -;; continue-req = "+" SP (resp-text / base64) CRLF -;; -;; response-data = "*" SP (resp-cond-state / resp-cond-bye / -;; mailbox-data / message-data / capability-data) CRLF -;; -;; response-done = response-tagged / response-fatal -;; -;; response-fatal = "*" SP resp-cond-bye CRLF -;; ; Server closes connection immediately -;; -;; response-tagged = tag SP resp-cond-state CRLF -;; -;; resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text -;; ; Status condition -;; -;; resp-cond-bye = "BYE" SP resp-text -;; -;; mailbox-data = "FLAGS" SP flag-list / -;; "LIST" SP mailbox-list / -;; "LSUB" SP mailbox-list / -;; "SEARCH" *(SP nz-number) / -;; "STATUS" SP mailbox SP "(" -;; [status-att SP number *(SP status-att SP number)] ")" / -;; number SP "EXISTS" / -;; number SP "RECENT" -;; -;; message-data = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att)) -;; -;; capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1" -;; *(SP capability) -;; ; IMAP4rev1 servers which offer RFC 1730 -;; ; compatibility MUST list "IMAP4" as the first -;; ; capability. - -(defun imap-parse-response () - "Parse a IMAP command response." - (let (token) - (case (setq token (read (current-buffer))) - (+ (setq imap-continuation - (or (buffer-substring (min (point-max) (1+ (point))) - (point-max)) - t))) - (* (case (prog1 (setq token (read (current-buffer))) - (imap-forward)) - (OK (imap-parse-resp-text)) - (NO (imap-parse-resp-text)) - (BAD (imap-parse-resp-text)) - (BYE (imap-parse-resp-text)) - (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) - (LIST (imap-parse-data-list 'list)) - (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search - (read (concat "(" (buffer-substring (point) (point-max)) ")")))) - (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability - (read (concat "(" (upcase (buffer-substring - (point) (point-max))) - ")")))) - (ID (setq imap-id (read (buffer-substring (point) - (point-max))))) - (ACL (imap-parse-acl)) - (t (case (prog1 (read (current-buffer)) - (imap-forward)) - (EXISTS (imap-mailbox-put 'exists token)) - (RECENT (imap-mailbox-put 'recent token)) - (EXPUNGE t) - (FETCH (imap-parse-fetch token)) - (t (message "Garbage: %s" (buffer-string))))))) - (t (let (status) - (if (not (integerp token)) - (message "Garbage: %s" (buffer-string)) - (case (prog1 (setq status (read (current-buffer))) - (imap-forward)) - (OK (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (imap-parse-resp-text))) - (NO (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) - imap-failed-tags)))) - (BAD (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) imap-failed-tags) - (error "Internal error, tag %s status %s code %s text %s" - token status code text)))) - (t (message "Garbage: %s" (buffer-string)))) - (when (assq token imap-callbacks) - (funcall (cdr (assq token imap-callbacks)) token status) - (setq imap-callbacks - (imap-remassoc token imap-callbacks))))))))) - -;; resp-text = ["[" resp-text-code "]" SP] text -;; -;; text = 1*TEXT-CHAR -;; -;; TEXT-CHAR = - -(defun imap-parse-resp-text () - (imap-parse-resp-text-code)) - -;; resp-text-code = "ALERT" / -;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] / -;; "NEWNAME" SP string SP string / -;; "PARSE" / -;; "PERMANENTFLAGS" SP "(" -;; [flag-perm *(SP flag-perm)] ")" / -;; "READ-ONLY" / -;; "READ-WRITE" / -;; "TRYCREATE" / -;; "UIDNEXT" SP nz-number / -;; "UIDVALIDITY" SP nz-number / -;; "UNSEEN" SP nz-number / -;; resp-text-atom [SP 1*] -;; -;; resp_code_apnd = "APPENDUID" SPACE nz_number SPACE uniqueid -;; -;; resp_code_copy = "COPYUID" SPACE nz_number SPACE set SPACE set -;; -;; set = sequence-num / (sequence-num ":" sequence-num) / -;; (set "," set) -;; ; Identifies a set of messages. For message -;; ; sequence numbers, these are consecutive -;; ; numbers from 1 to the number of messages in -;; ; the mailbox -;; ; Comma delimits individual numbers, colon -;; ; delimits between two numbers inclusive. -;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13, -;; ; 14,15 for a mailbox with 15 messages. -;; -;; sequence-num = nz-number / "*" -;; ; * is the largest number in use. For message -;; ; sequence numbers, it is the number of messages -;; ; in the mailbox. For unique identifiers, it is -;; ; the unique identifier of the last message in -;; ; the mailbox. -;; -;; flag-perm = flag / "\*" -;; -;; flag = "\Answered" / "\Flagged" / "\Deleted" / -;; "\Seen" / "\Draft" / flag-keyword / flag-extension -;; ; Does not include "\Recent" -;; -;; flag-extension = "\" atom -;; ; Future expansion. Client implementations -;; ; MUST accept flag-extension flags. Server -;; ; implementations MUST NOT generate -;; ; flag-extension flags except as defined by -;; ; future standard or standards-track -;; ; revisions of this specification. -;; -;; flag-keyword = atom -;; -;; resp-text-atom = 1* - -(defun imap-parse-resp-text-code () - ;; xxx next line for stalker communigate pro 3.3.1 bug - (when (looking-at " \\[") - (imap-forward)) - (when (eq (char-after) ?\[) - (imap-forward) - (cond ((search-forward "PERMANENTFLAGS " nil t) - (imap-mailbox-put 'permanentflags (imap-parse-flag-list))) - ((search-forward "UIDNEXT \\([0-9]+\\)" nil t) - (imap-mailbox-put 'uidnext (match-string 1))) - ((search-forward "UNSEEN " nil t) - (imap-mailbox-put 'first-unseen (read (current-buffer)))) - ((looking-at "UIDVALIDITY \\([0-9]+\\)") - (imap-mailbox-put 'uidvalidity (match-string 1))) - ((search-forward "READ-ONLY" nil t) - (imap-mailbox-put 'read-only t)) - ((search-forward "NEWNAME " nil t) - (let (oldname newname) - (setq oldname (imap-parse-string)) - (imap-forward) - (setq newname (imap-parse-string)) - (imap-mailbox-put 'newname newname oldname))) - ((search-forward "TRYCREATE" nil t) - (imap-mailbox-put 'trycreate t imap-current-target-mailbox)) - ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)") - (imap-mailbox-put 'appenduid - (list (match-string 1) - (string-to-number (match-string 2))) - imap-current-target-mailbox)) - ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)") - (imap-mailbox-put 'copyuid (list (match-string 1) - (match-string 2) - (match-string 3)) - imap-current-target-mailbox)) - ((search-forward "ALERT] " nil t) - (message "Imap server %s information: %s" imap-server - (buffer-substring (point) (point-max))))))) - -;; mailbox-list = "(" [mbx-list-flags] ")" SP -;; (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox -;; -;; mbx-list-flags = *(mbx-list-oflag SP) mbx-list-sflag -;; *(SP mbx-list-oflag) / -;; mbx-list-oflag *(SP mbx-list-oflag) -;; -;; mbx-list-oflag = "\Noinferiors" / flag-extension -;; ; Other flags; multiple possible per LIST response -;; -;; mbx-list-sflag = "\Noselect" / "\Marked" / "\Unmarked" -;; ; Selectability flags; only one per LIST response -;; -;; QUOTED-CHAR = / -;; "\" quoted-specials -;; -;; quoted-specials = DQUOTE / "\" - -(defun imap-parse-data-list (type) - (let (flags delimiter mailbox) - (setq flags (imap-parse-flag-list)) - (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"") - (setq delimiter (match-string 1)) - (goto-char (1+ (match-end 0))) - (when (setq mailbox (imap-parse-mailbox)) - (imap-mailbox-put type t mailbox) - (imap-mailbox-put 'list-flags flags mailbox) - (imap-mailbox-put 'delimiter delimiter mailbox))))) - -;; msg_att ::= "(" 1#("ENVELOPE" SPACE envelope / -;; "FLAGS" SPACE "(" #(flag / "\Recent") ")" / -;; "INTERNALDATE" SPACE date_time / -;; "RFC822" [".HEADER" / ".TEXT"] SPACE nstring / -;; "RFC822.SIZE" SPACE number / -;; "BODY" ["STRUCTURE"] SPACE body / -;; "BODY" section ["<" number ">"] SPACE nstring / -;; "UID" SPACE uniqueid) ")" -;; -;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year -;; SPACE time SPACE zone <"> -;; -;; section ::= "[" [section_text / (nz_number *["." nz_number] -;; ["." (section_text / "MIME")])] "]" -;; -;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"] -;; SPACE header_list / "TEXT" -;; -;; header_fld_name ::= astring -;; -;; header_list ::= "(" 1#header_fld_name ")" - -(defsubst imap-parse-header-list () - (when (eq (char-after) ?\() - (let (strlist) - (while (not (eq (char-after) ?\))) - (imap-forward) - (push (imap-parse-astring) strlist)) - (imap-forward) - (nreverse strlist)))) - -(defsubst imap-parse-fetch-body-section () - (let ((section - (buffer-substring (point) (1- (re-search-forward "[] ]" nil t))))) - (if (eq (char-before) ? ) - (prog1 - (mapconcat 'identity (cons section (imap-parse-header-list)) " ") - (search-forward "]" nil t)) - section))) - -(defun imap-parse-fetch (response) - (when (eq (char-after) ?\() - (let (uid flags envelope internaldate rfc822 rfc822header rfc822text - rfc822size body bodydetail bodystructure flags-empty) - ;; Courier can insert spurious blank characters which will - ;; confuse `read', so skip past them. - (while (let ((moved (skip-chars-forward " \t"))) - (prog1 (not (eq (char-after) ?\))) - (unless (= moved 0) (backward-char)))) - (imap-forward) - (let ((token (read (current-buffer)))) - (imap-forward) - (cond ((eq token 'UID) - (setq uid (condition-case () - (read (current-buffer)) - (error)))) - ((eq token 'FLAGS) - (setq flags (imap-parse-flag-list)) - (if (not flags) - (setq flags-empty 't))) - ((eq token 'ENVELOPE) - (setq envelope (imap-parse-envelope))) - ((eq token 'INTERNALDATE) - (setq internaldate (imap-parse-string))) - ((eq token 'RFC822) - (setq rfc822 (imap-parse-nstring))) - ((eq token 'RFC822.HEADER) - (setq rfc822header (imap-parse-nstring))) - ((eq token 'RFC822.TEXT) - (setq rfc822text (imap-parse-nstring))) - ((eq token 'RFC822.SIZE) - (setq rfc822size (read (current-buffer)))) - ((eq token 'BODY) - (if (eq (char-before) ?\[) - (push (list - (upcase (imap-parse-fetch-body-section)) - (and (eq (char-after) ?<) - (buffer-substring (1+ (point)) - (search-forward ">" nil t))) - (progn (imap-forward) - (imap-parse-nstring))) - bodydetail) - (setq body (imap-parse-body)))) - ((eq token 'BODYSTRUCTURE) - (setq bodystructure (imap-parse-body)))))) - (when uid - (setq imap-current-message uid) - (imap-message-put uid 'UID uid) - (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags)) - (and envelope (imap-message-put uid 'ENVELOPE envelope)) - (and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) - (and rfc822 (imap-message-put uid 'RFC822 rfc822)) - (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header)) - (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text)) - (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size)) - (and body (imap-message-put uid 'BODY body)) - (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail)) - (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure)) - (run-hooks 'imap-fetch-data-hook))))) - -;; mailbox-data = ... -;; "STATUS" SP mailbox SP "(" -;; [status-att SP number -;; *(SP status-att SP number)] ")" -;; ... -;; -;; status-att = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" / -;; "UNSEEN" - -(defun imap-parse-status () - (let ((mailbox (imap-parse-mailbox))) - (if (eq (char-after) ? ) - (forward-char)) - (when (and mailbox (eq (char-after) ?\()) - (while (and (not (eq (char-after) ?\))) - (or (forward-char) t) - (looking-at "\\([A-Za-z]+\\) ")) - (let ((token (upcase (match-string 1)))) - (goto-char (match-end 0)) - (cond ((string= token "MESSAGES") - (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) - ((string= token "RECENT") - (imap-mailbox-put 'recent (read (current-buffer)) mailbox)) - ((string= token "UIDNEXT") - (and (looking-at "[0-9]+") - (imap-mailbox-put 'uidnext (match-string 0) mailbox) - (goto-char (match-end 0)))) - ((string= token "UIDVALIDITY") - (and (looking-at "[0-9]+") - (imap-mailbox-put 'uidvalidity (match-string 0) mailbox) - (goto-char (match-end 0)))) - ((string= token "UNSEEN") - (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) - (t - (message "Unknown status data %s in mailbox %s ignored" - token mailbox) - (read (current-buffer))))))))) - -;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE -;; rights) -;; -;; identifier ::= astring -;; -;; rights ::= astring - -(defun imap-parse-acl () - (let ((mailbox (imap-parse-mailbox)) - identifier rights acl) - (while (eq (char-after) ?\ ) - (imap-forward) - (setq identifier (imap-parse-astring)) - (imap-forward) - (setq rights (imap-parse-astring)) - (setq acl (append acl (list (cons identifier rights))))) - (imap-mailbox-put 'acl acl mailbox))) - -;; flag-list = "(" [flag *(SP flag)] ")" -;; -;; flag = "\Answered" / "\Flagged" / "\Deleted" / -;; "\Seen" / "\Draft" / flag-keyword / flag-extension -;; ; Does not include "\Recent" -;; -;; flag-keyword = atom -;; -;; flag-extension = "\" atom -;; ; Future expansion. Client implementations -;; ; MUST accept flag-extension flags. Server -;; ; implementations MUST NOT generate -;; ; flag-extension flags except as defined by -;; ; future standard or standards-track -;; ; revisions of this specification. - -(defun imap-parse-flag-list () - (let (flag-list start) - (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") - (while (and (not (eq (char-after) ?\))) - (setq start (progn - (imap-forward) - ;; next line for Courier IMAP bug. - (skip-chars-forward " ") - (point))) - (> (skip-chars-forward "^ )" (point-at-eol)) 0)) - (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") - (imap-forward) - (nreverse flag-list))) - -;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP -;; env-reply-to SP env-to SP env-cc SP env-bcc SP -;; env-in-reply-to SP env-message-id ")" -;; -;; env-bcc = "(" 1*address ")" / nil -;; -;; env-cc = "(" 1*address ")" / nil -;; -;; env-date = nstring -;; -;; env-from = "(" 1*address ")" / nil -;; -;; env-in-reply-to = nstring -;; -;; env-message-id = nstring -;; -;; env-reply-to = "(" 1*address ")" / nil -;; -;; env-sender = "(" 1*address ")" / nil -;; -;; env-subject = nstring -;; -;; env-to = "(" 1*address ")" / nil - -(defun imap-parse-envelope () - (when (eq (char-after) ?\() - (imap-forward) - (vector (prog1 (imap-parse-nstring) ;; date - (imap-forward)) - (prog1 (imap-parse-nstring) ;; subject - (imap-forward)) - (prog1 (imap-parse-address-list) ;; from - (imap-forward)) - (prog1 (imap-parse-address-list) ;; sender - (imap-forward)) - (prog1 (imap-parse-address-list) ;; reply-to - (imap-forward)) - (prog1 (imap-parse-address-list) ;; to - (imap-forward)) - (prog1 (imap-parse-address-list) ;; cc - (imap-forward)) - (prog1 (imap-parse-address-list) ;; bcc - (imap-forward)) - (prog1 (imap-parse-nstring) ;; in-reply-to - (imap-forward)) - (prog1 (imap-parse-nstring) ;; message-id - (imap-forward))))) - -;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil - -(defsubst imap-parse-string-list () - (cond ((eq (char-after) ?\() ;; body-fld-param - (let (strlist str) - (imap-forward) - (while (setq str (imap-parse-string)) - (push str strlist) - ;; buggy stalker communigate pro 3.0 doesn't print SPC - ;; between body-fld-param's sometimes - (or (eq (char-after) ?\") - (imap-forward))) - (nreverse strlist))) - ((imap-parse-nil) - nil))) - -;; body-extension = nstring / number / -;; "(" body-extension *(SP body-extension) ")" -;; ; Future expansion. Client implementations -;; ; MUST accept body-extension fields. Server -;; ; implementations MUST NOT generate -;; ; body-extension fields except as defined by -;; ; future standard or standards-track -;; ; revisions of this specification. - -(defun imap-parse-body-extension () - (if (eq (char-after) ?\() - (let (b-e) - (imap-forward) - (push (imap-parse-body-extension) b-e) - (while (eq (char-after) ?\ ) - (imap-forward) - (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") - (imap-forward) - (nreverse b-e)) - (or (imap-parse-number) - (imap-parse-nstring)))) - -;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang -;; *(SP body-extension)]] -;; ; MUST NOT be returned on non-extensible -;; ; "BODY" fetch -;; -;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang -;; *(SP body-extension)]] -;; ; MUST NOT be returned on non-extensible -;; ; "BODY" fetch - -(defsubst imap-parse-body-ext () - (let (ext) - (when (eq (char-after) ?\ ) ;; body-fld-dsp - (imap-forward) - (let (dsp) - (if (eq (char-after) ?\() - (progn - (imap-forward) - (push (imap-parse-string) dsp) - (imap-forward) - (push (imap-parse-string-list) dsp) - (imap-forward)) - ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") - (imap-parse-nil)) - (push (nreverse dsp) ext)) - (when (eq (char-after) ?\ ) ;; body-fld-lang - (imap-forward) - (if (eq (char-after) ?\() - (push (imap-parse-string-list) ext) - (push (imap-parse-nstring) ext)) - (while (eq (char-after) ?\ ) ;; body-extension - (imap-forward) - (setq ext (append (imap-parse-body-extension) ext))))) - ext)) - -;; body = "(" body-type-1part / body-type-mpart ")" -;; -;; body-ext-1part = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang -;; *(SP body-extension)]] -;; ; MUST NOT be returned on non-extensible -;; ; "BODY" fetch -;; -;; body-ext-mpart = body-fld-param [SP body-fld-dsp [SP body-fld-lang -;; *(SP body-extension)]] -;; ; MUST NOT be returned on non-extensible -;; ; "BODY" fetch -;; -;; body-fields = body-fld-param SP body-fld-id SP body-fld-desc SP -;; body-fld-enc SP body-fld-octets -;; -;; body-fld-desc = nstring -;; -;; body-fld-dsp = "(" string SP body-fld-param ")" / nil -;; -;; body-fld-enc = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/ -;; "QUOTED-PRINTABLE") DQUOTE) / string -;; -;; body-fld-id = nstring -;; -;; body-fld-lang = nstring / "(" string *(SP string) ")" -;; -;; body-fld-lines = number -;; -;; body-fld-md5 = nstring -;; -;; body-fld-octets = number -;; -;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil -;; -;; body-type-1part = (body-type-basic / body-type-msg / body-type-text) -;; [SP body-ext-1part] -;; -;; body-type-basic = media-basic SP body-fields -;; ; MESSAGE subtype MUST NOT be "RFC822" -;; -;; body-type-msg = media-message SP body-fields SP envelope -;; SP body SP body-fld-lines -;; -;; body-type-text = media-text SP body-fields SP body-fld-lines -;; -;; body-type-mpart = 1*body SP media-subtype -;; [SP body-ext-mpart] -;; -;; media-basic = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" / -;; "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype -;; ; Defined in [MIME-IMT] -;; -;; media-message = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE -;; ; Defined in [MIME-IMT] -;; -;; media-subtype = string -;; ; Defined in [MIME-IMT] -;; -;; media-text = DQUOTE "TEXT" DQUOTE SP media-subtype -;; ; Defined in [MIME-IMT] - -(defun imap-parse-body () - (let (body) - (when (eq (char-after) ?\() - (imap-forward) - (if (eq (char-after) ?\() - (let (subbody) - (while (and (eq (char-after) ?\() - (setq subbody (imap-parse-body))) - ;; buggy stalker communigate pro 3.0 inserts a SPC between - ;; parts in multiparts - (when (and (eq (char-after) ?\ ) - (eq (char-after (1+ (point))) ?\()) - (imap-forward)) - (push subbody body)) - (imap-forward) - (push (imap-parse-string) body) ;; media-subtype - (when (eq (char-after) ?\ ) ;; body-ext-mpart: - (imap-forward) - (if (eq (char-after) ?\() ;; body-fld-param - (push (imap-parse-string-list) body) - (push (and (imap-parse-nil) nil) body)) - (setq body - (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) nil "In imap-parse-body") - (imap-forward) - (nreverse body)) - - (push (imap-parse-string) body) ;; media-type - (imap-forward) - (push (imap-parse-string) body) ;; media-subtype - (imap-forward) - ;; next line for Sun SIMS bug - (and (eq (char-after) ? ) (imap-forward)) - (if (eq (char-after) ?\() ;; body-fld-param - (push (imap-parse-string-list) body) - (push (and (imap-parse-nil) nil) body)) - (imap-forward) - (push (imap-parse-nstring) body) ;; body-fld-id - (imap-forward) - (push (imap-parse-nstring) body) ;; body-fld-desc - (imap-forward) - ;; Next `or' for Sun SIMS bug. It regards body-fld-enc as a - ;; nstring and returns nil instead of defaulting back to 7BIT - ;; as the standard says. - ;; Exchange (2007, at least) does this as well. - (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc - (imap-forward) - ;; Exchange 2007 can return -1, contrary to the spec... - (if (eq (char-after) ?-) - (progn - (skip-chars-forward "-0-9") - (push nil body)) - (push (imap-parse-number) body)) ;; body-fld-octets - - ;; Ok, we're done parsing the required parts, what comes now is one of - ;; three things: - ;; - ;; envelope (then we're parsing body-type-msg) - ;; body-fld-lines (then we're parsing body-type-text) - ;; body-ext-1part (then we're parsing body-type-basic) - ;; - ;; The problem is that the two first are in turn optionally followed - ;; by the third. So we parse the first two here (if there are any)... - - (when (eq (char-after) ?\ ) - (imap-forward) - (let (lines) - (cond ((eq (char-after) ?\() ;; body-type-msg: - (push (imap-parse-envelope) body) ;; envelope - (imap-forward) - (push (imap-parse-body) body) ;; body - ;; buggy stalker communigate pro 3.0 doesn't print - ;; number of lines in message/rfc822 attachment - (if (eq (char-after) ?\)) - (push 0 body) - (imap-forward) - (push (imap-parse-number) body))) ;; body-fld-lines - ((setq lines (imap-parse-number)) ;; body-type-text: - (push lines body)) ;; body-fld-lines - (t - (backward-char))))) ;; no match... - - ;; ...and then parse the third one here... - - (when (eq (char-after) ?\ ) ;; body-ext-1part: - (imap-forward) - (push (imap-parse-nstring) body) ;; body-fld-md5 - (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - - (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") - (imap-forward) - (nreverse body))))) - -(when imap-debug ; (untrace-all) - (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) - '( - imap-utf7-encode - imap-utf7-decode - imap-error-text - imap-kerberos4s-p - imap-kerberos4-open - imap-ssl-p - imap-ssl-open - imap-network-p - imap-network-open - imap-interactive-login - imap-kerberos4a-p - imap-kerberos4-auth - imap-cram-md5-p - imap-cram-md5-auth - imap-login-p - imap-login-auth - imap-anonymous-p - imap-anonymous-auth - imap-open-1 - imap-open - imap-opened - imap-ping-server - imap-authenticate - imap-close - imap-capability - imap-namespace - imap-send-command-wait - imap-mailbox-put - imap-mailbox-get - imap-mailbox-map-1 - imap-mailbox-map - imap-current-mailbox - imap-current-mailbox-p-1 - imap-current-mailbox-p - imap-mailbox-select-1 - imap-mailbox-select - imap-mailbox-examine-1 - imap-mailbox-examine - imap-mailbox-unselect - imap-mailbox-expunge - imap-mailbox-close - imap-mailbox-create-1 - imap-mailbox-create - imap-mailbox-delete - imap-mailbox-rename - imap-mailbox-lsub - imap-mailbox-list - imap-mailbox-subscribe - imap-mailbox-unsubscribe - imap-mailbox-status - imap-mailbox-acl-get - imap-mailbox-acl-set - imap-mailbox-acl-delete - imap-current-message - imap-list-to-message-set - imap-fetch-asynch - imap-fetch - imap-fetch-safe - imap-message-put - imap-message-get - imap-message-map - imap-search - imap-message-flag-permanent-p - imap-message-flags-set - imap-message-flags-del - imap-message-flags-add - imap-message-copyuid-1 - imap-message-copyuid - imap-message-copy - imap-message-appenduid-1 - imap-message-appenduid - imap-message-append - imap-body-lines - imap-envelope-from - imap-send-command-1 - imap-send-command - imap-wait-for-tag - imap-sentinel - imap-find-next-line - imap-arrival-filter - imap-parse-greeting - imap-parse-response - imap-parse-resp-text - imap-parse-resp-text-code - imap-parse-data-list - imap-parse-fetch - imap-parse-status - imap-parse-acl - imap-parse-flag-list - imap-parse-envelope - imap-parse-body-extension - imap-parse-body - ))) - -(provide 'imap) - -;;; imap.el ends here diff --git a/lisp/lpath.el b/lisp/lpath.el index 857a53602..91613a221 100644 --- a/lisp/lpath.el +++ b/lisp/lpath.el @@ -26,7 +26,7 @@ (defun netrc-machine-user-or-password (mode authinfo-file-or-list machines ports defaults)) (defun netrc-parse (file)) - (defun shr-put-image (data alt)) + (defun shr-put-image (data alt &optional flags)) (maybe-fbind '(Info-index Info-index-next Info-menu bbdb-complete-name bookmark-default-handler @@ -52,7 +52,7 @@ ports defaults)) (defun netrc-parse (file)) (defun split-line (&optional arg)) - (defun shr-put-image (data alt)) + (defun shr-put-image (data alt &optional flags)) (eval-after-load "rmail" '(defun rmail-toggle-header (&optional arg))) (maybe-fbind diff --git a/lisp/message.el b/lisp/message.el index 416a4c8c3..f32981fba 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -3101,66 +3101,79 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (defun message-goto-to () "Move point to the To header." (interactive) + (push-mark) (message-position-on-field "To")) (defun message-goto-from () "Move point to the From header." (interactive) + (push-mark) (message-position-on-field "From")) (defun message-goto-subject () "Move point to the Subject header." (interactive) + (push-mark) (message-position-on-field "Subject")) (defun message-goto-cc () "Move point to the Cc header." (interactive) + (push-mark) (message-position-on-field "Cc" "To")) (defun message-goto-bcc () "Move point to the Bcc header." (interactive) + (push-mark) (message-position-on-field "Bcc" "Cc" "To")) (defun message-goto-fcc () "Move point to the Fcc header." (interactive) + (push-mark) (message-position-on-field "Fcc" "To" "Newsgroups")) (defun message-goto-reply-to () "Move point to the Reply-To header." (interactive) + (push-mark) (message-position-on-field "Reply-To" "Subject")) (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) + (push-mark) (message-position-on-field "Newsgroups")) (defun message-goto-distribution () "Move point to the Distribution header." (interactive) + (push-mark) (message-position-on-field "Distribution")) (defun message-goto-followup-to () "Move point to the Followup-To header." (interactive) + (push-mark) (message-position-on-field "Followup-To" "Newsgroups")) (defun message-goto-mail-followup-to () "Move point to the Mail-Followup-To header." (interactive) + (push-mark) (message-position-on-field "Mail-Followup-To" "To")) (defun message-goto-keywords () "Move point to the Keywords header." (interactive) + (push-mark) (message-position-on-field "Keywords" "Subject")) (defun message-goto-summary () "Move point to the Summary header." (interactive) + (push-mark) (message-position-on-field "Summary" "Subject")) (eval-when-compile @@ -3181,6 +3194,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (when (and (message-called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) + (push-mark) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) @@ -3201,6 +3215,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." If there is no signature in the article, go to the end and return nil." (interactive) + (push-mark) (goto-char (point-min)) (if (re-search-forward message-signature-separator nil t) (forward-line 1) @@ -4523,8 +4538,9 @@ This function could be useful in `message-setup-hook'." (end-of-line) (insert (format " (%d/%d)" n total)) (widen) - (funcall (or message-send-mail-real-function - message-send-mail-function))) + (if message-send-mail-real-function + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) @@ -4678,8 +4694,9 @@ If you always want Gnus to send messages in one piece, set "))) (progn (message "Sending via mail...") - (funcall (or message-send-mail-real-function - message-send-mail-function))) + (if message-send-mail-real-function + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) (message-send-mail-partially)) (setq options message-options)) (kill-buffer tembuf)) @@ -4688,6 +4705,28 @@ If you always want Gnus to send messages in one piece, set (push 'mail message-sent-message-via))) (defvar sendmail-program) +(defvar smtpmail-smtp-user) + +(defun message-multi-smtp-send-mail () + "Send the current buffer to `message-send-mail-function'. +Or, if there's a header that specifies a different method, use +that instead." + (let ((method (message-field-value "X-Message-SMTP-Method"))) + (if (not method) + (funcall message-send-mail-function) + (message-remove-header "X-Message-SMTP-Method") + (setq method (split-string method)) + (cond + ((equal (car method) "sendmail") + (message-send-mail-with-sendmail)) + ((equal (car method) "smtp") + (require 'smtpmail) + (let ((smtpmail-smtp-server (nth 1 method)) + (smtpmail-smtp-service (nth 2 method)) + (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) + (message-smtpmail-send-it))) + (t + (error "Unknown method %s" method)))))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." @@ -7574,7 +7613,7 @@ is for the internal use." (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) - beg) + gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) (set-buffer (get-buffer-create " *message resend*")) @@ -7587,6 +7626,8 @@ is for the internal use." ;; Insert our usual headers. (message-generate-headers '(From Date To Message-ID)) (message-narrow-to-headers) + (when (setq gcc (mail-fetch-field "gcc" nil t)) + (message-remove-header "gcc")) ;; Remove X-Draft-From header etc. (message-remove-header message-ignored-mail-headers t) ;; Rename them all to "Resent-*". @@ -7628,6 +7669,10 @@ is for the internal use." message-generate-hashcash rfc2047-encode-encoded-words) (message-send-mail)) + (when gcc + (message-goto-eoh) + (insert "Gcc: " gcc "\n")) + (run-hooks 'message-sent-hook) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) diff --git a/lisp/mm-archive.el b/lisp/mm-archive.el new file mode 100644 index 000000000..5ca6616ab --- /dev/null +++ b/lisp/mm-archive.el @@ -0,0 +1,100 @@ +;;; mm-archive.el --- Functions for parsing archive files as MIME + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 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 . + +;;; Commentary: + +;;; Code: + +(defvar mm-archive-decoders + '(("application/ms-tnef" t "tnef" "-f" "-" "-C") + ("application/zip" nil "unzip" "-j" "-x" "%f" "-d") + ("application/x-gtar-compressed" nil "tar" "xzf" "-" "-C") + ("application/x-tar" nil "tar" "xf" "-" "-C"))) + +(defun mm-dissect-archive (handle) + (let ((decoder (cddr (assoc (car (mm-handle-type handle)) + mm-archive-decoders))) + (dir (mm-make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) + (set-file-modes dir #o700) + (unwind-protect + (progn + (mm-with-unibyte-buffer + (mm-insert-part handle) + (if (member "%f" decoder) + (let ((file (expand-file-name "mail.zip" dir))) + (write-region (point-min) (point-max) file nil 'silent) + (setq decoder (copy-sequence decoder)) + (setcar (member "%f" decoder) file) + (apply 'call-process (car decoder) nil nil nil + (append (cdr decoder) (list dir))) + (delete-file file)) + (apply 'call-process-region (point-min) (point-max) (car decoder) + nil (get-buffer-create "*tnef*") + nil (append (cdr decoder) (list dir))))) + `("multipart/mixed" + ,handle + ,@(mm-archive-list-files (gnus-recursive-directory-files dir)))) + (delete-directory dir t)))) + +(defun mm-archive-list-files (files) + (let ((handles nil) + type disposition) + (dolist (file files) + (with-temp-buffer + (when (string-match "\\.\\([^.]+\\)$" file) + (setq type (mailcap-extension-to-mime (match-string 1 file)))) + (unless type + (setq type "application/octet-stream")) + (setq disposition + (if (string-match "^image/\\|^text/" type) + "inline" + "attachment")) + (insert (format "Content-type: %s\n" type)) + (insert "Content-Transfer-Encoding: 8bit\n\n") + (insert-file-contents file) + (push + (mm-make-handle (mm-copy-to-buffer) + (list type) + '8bit nil + `(,disposition (filename . ,file)) + nil nil nil) + handles))) + handles)) + +(defun mm-archive-dissect-and-inline (handle) + (let ((start (point-marker))) + (save-restriction + (narrow-to-region (point) (point)) + (dolist (handle (cddr (mm-dissect-archive handle))) + (goto-char (point-max)) + (mm-display-inline handle)) + (goto-char (point-max)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t) + (end ,(point-marker))) + (remove-images ,start end) + (delete-region ,start end))))))) + +(provide 'mm-archive) + +;; mm-archive.el ends here diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index dd3eb6c9d..5f5d06d4d 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -29,6 +29,7 @@ (require 'mail-parse) (require 'mm-bodies) +(require 'mm-archive) (eval-when-compile (require 'cl) (require 'term)) @@ -248,6 +249,8 @@ before the external MIME handler is invoked." ("message/partial" mm-inline-partial identity) ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) + ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity) + ("application/zip" mm-archive-dissect-and-inline identity) ("audio/wav" mm-inline-audio (lambda (handle) (and (or (featurep 'nas-sound) (featurep 'native-sound)) @@ -297,6 +300,9 @@ before the external MIME handler is invoked." "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" + "application/x-gtar-compressed" + "application/x-tar" + "application/zip" ;; Mutt still uses this even though it has already been withdrawn. "application/pgp") "List of media types that are to be displayed inline. @@ -653,8 +659,25 @@ Postpone undisplaying of viewers for types in (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) + ;; Guess what the type of application/octet-stream parts should + ;; really be. + (let ((filename (cdr (assq 'filename (cdr cdl))))) + (when (and (equal (car ctl) "application/octet-stream") + filename + (string-match "\\.\\([^.]+\\)$" filename)) + (let ((new-type (mailcap-extension-to-mime (match-string 1 filename)))) + (when new-type + (setcar ctl new-type))))) + (let ((handle + (mm-make-handle + (mm-copy-to-buffer) ctl cte nil cdl description nil id)) + (decoder (assoc (car ctl) mm-archive-decoders))) + (if (and decoder + ;; Do automatic decoding + (cadr decoder) + (executable-find (caddr decoder))) + (mm-dissect-archive handle) + handle)))) (defun mm-dissect-multipart (ctl from) (goto-char (point-min)) @@ -918,46 +941,38 @@ external if displayed external." shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) - (lexical-let ;; Don't use `let'. - ;; Function used to remove temp file and directory. - ((fn `(lambda nil - ;; Don't use `ignore-errors'. - (condition-case nil - (delete-file ,file) - (error)) - (condition-case nil - (delete-directory - ,(file-name-directory file)) - (error)))) - ;; Form uses to kill the process buffer and - ;; remove the undisplayer. - (fm `(progn - (kill-buffer ,buffer) - ,(macroexpand - (list 'mm-handle-set-undisplayer - (list 'quote handle) - nil)))) - ;; Message to be issued when the process exits. - (done (format "Displaying %s...done" command)) - ;; In particular, the timer object (which is - ;; a vector in Emacs but is a list in XEmacs) - ;; requires that it is lexically scoped. - (timer (run-at-time 30.0 nil 'ignore))) - (if (featurep 'xemacs) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer itimer-list) - (set-itimer-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer timer-list) - (timer-set-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))))))) + (lexical-let ((outbuf outbuf) + (file file) + (buffer buffer) + (command command) + (handle handle)) + (run-at-time + 30.0 nil + (lambda () + (ignore-errors + (delete-file file)) + (ignore-errors + (delete-directory (file-name-directory file))))) + (lambda (process state) + (when (eq (process-status process) 'exit) + (condition-case nil + (delete-file file) + (error)) + (condition-case nil + (delete-directory (file-name-directory file)) + (error)) + (when (buffer-live-p outbuf) + (with-current-buffer outbuf + (let ((buffer-read-only nil) + (point (point))) + (forward-line 2) + (mm-insert-inline + handle (with-current-buffer buffer + (buffer-string))) + (goto-char point)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))) + (message "Displaying %s...done" command))))) (mm-handle-set-external-undisplayer handle (cons file buffer))) (message "Displaying %s..." command)) @@ -1758,6 +1773,8 @@ If RECURSIVE, search recursively." mm-extra-numeric-entities))) (replace-match (char-to-string char)))) (libxml-parse-html-region (point-min) (point-max)))) + (unless (bobp) + (insert "\n")) (mm-handle-set-undisplayer handle `(lambda () diff --git a/lisp/mm-util.el b/lisp/mm-util.el index e9119284a..4fb5ea704 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -1592,7 +1592,7 @@ gzip, bzip2, etc. are allowed." (unless filename (setq filename buffer-file-name)) (save-excursion - (let ((decomp (unless ;; No worth to examine charset of tar files. + (let ((decomp (unless ;; Not worth it to examine charset of tar files. (and filename (string-match "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'" diff --git a/lisp/nnfolder.el b/lisp/nnfolder.el index 89961dc7d..0245ff844 100644 --- a/lisp/nnfolder.el +++ b/lisp/nnfolder.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1995-2012 Free Software Foundation, Inc. -;; Author: Simon Josefsson (adding MARKS) +;; Author: Simon Josefsson ;; ShengHuo Zhu (adding NOV) ;; Scott Byer ;; Lars Magne Ingebrigtsen @@ -53,10 +53,6 @@ "The name of the nnfolder NOV directory. If nil, `nnfolder-directory' is used.") -(defvoo nnfolder-marks-directory nil - "The name of the nnfolder MARKS directory. -If nil, `nnfolder-directory' is used.") - (defvoo nnfolder-active-file (nnheader-concat nnfolder-directory "active") "The name of the active file.") @@ -134,21 +130,6 @@ all. This may very well take some time.") (defvar nnfolder-nov-buffer-file-name nil) -(defvoo nnfolder-marks-is-evil nil - "If non-nil, Gnus will never generate and use marks file for mail groups. -Using marks files makes it possible to backup and restore mail groups -separately from `.newsrc.eld'. If you have, for some reason, set -this to t, and want to set it to nil again, you should always remove -the corresponding marks file (usually base nnfolder file name -concatenated with `.mrk', but see `nnfolder-marks-file-suffix') for -the group. Then the marks file will be regenerated properly by Gnus.") - -(defvoo nnfolder-marks nil) - -(defvoo nnfolder-marks-file-suffix ".mrk") - -(defvar nnfolder-marks-modtime (gnus-make-hashtable)) - ;;; Interface functions @@ -231,9 +212,6 @@ the group. Then the marks file will be regenerated properly by Gnus.") (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) (and nnfolder-nov-directory (gnus-make-directory nnfolder-nov-directory))) - (unless nnfolder-marks-is-evil - (and nnfolder-marks-directory - (gnus-make-directory nnfolder-marks-directory))) (cond ((not (file-exists-p nnfolder-directory)) (nnfolder-close-server) @@ -607,11 +585,9 @@ the group. Then the marks file will be regenerated properly by Gnus.") () ; Don't delete the articles. ;; Delete the file that holds the group. (let ((data (nnfolder-group-pathname group)) - (nov (nnfolder-group-nov-pathname group)) - (mrk (nnfolder-group-marks-pathname group))) + (nov (nnfolder-group-nov-pathname group))) (ignore-errors (delete-file data)) - (ignore-errors (delete-file nov)) - (ignore-errors (delete-file mrk)))) + (ignore-errors (delete-file nov)))) ;; Remove the group from all structures. (setq nnfolder-group-alist (delq (assoc group nnfolder-group-alist) nnfolder-group-alist) @@ -632,11 +608,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (when (file-exists-p (nnfolder-group-nov-pathname group)) (setq new-file (nnfolder-group-nov-pathname new-name)) (gnus-make-directory (file-name-directory new-file)) - (rename-file (nnfolder-group-nov-pathname group) new-file)) - (when (file-exists-p (nnfolder-group-marks-pathname group)) - (setq new-file (nnfolder-group-marks-pathname new-name)) - (gnus-make-directory (file-name-directory new-file)) - (rename-file (nnfolder-group-marks-pathname group) new-file))) + (rename-file (nnfolder-group-nov-pathname group) new-file))) t) ;; That went ok, so we change the internal structures. (let ((entry (assoc group nnfolder-group-alist))) @@ -1182,100 +1154,6 @@ This command does not work if you use short group names." (mail-header-set-number headers article) (nnheader-insert-nov headers))) -(deffoo nnfolder-request-set-mark (group actions &optional server) - (when (and server - (not (nnfolder-server-opened server))) - (nnfolder-open-server server)) - (unless nnfolder-marks-is-evil - (nnfolder-open-marks group server) - (setq nnfolder-marks (nnheader-update-marks-actions nnfolder-marks actions)) - (nnfolder-save-marks group server)) - nil) - -(deffoo nnfolder-request-marks (group info &optional server) - ;; Change servers. - (when (and server - (not (nnfolder-server-opened server))) - (nnfolder-open-server server)) - (when (and (not nnfolder-marks-is-evil) (nnfolder-marks-changed-p group)) - (nnheader-message 8 "Updating marks for %s..." group) - (nnfolder-open-marks group server) - ;; Update info using `nnfolder-marks'. - (mapc (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnfolder-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) - (let ((seen (cdr (assq 'read nnfolder-marks)))) - (gnus-info-set-read info - (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen))) - (nnheader-message 8 "Updating marks for %s...done" group)) - info) - -(defun nnfolder-group-marks-pathname (group) - "Make pathname for GROUP NOV." - (let ((nnfolder-directory (or nnfolder-marks-directory nnfolder-directory))) - (concat (nnfolder-group-pathname group) nnfolder-marks-file-suffix))) - -(defun nnfolder-marks-changed-p (group) - (let ((file (nnfolder-group-marks-pathname group))) - (if (null (gnus-gethash file nnfolder-marks-modtime)) - t ;; never looked at marks file, assume it has changed - (not (equal (gnus-gethash file nnfolder-marks-modtime) - (nth 5 (file-attributes file))))))) - -(defun nnfolder-save-marks (group server) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (nnfolder-group-marks-pathname group))) - (condition-case err - (progn - (with-temp-file file - (erase-buffer) - (gnus-prin1 nnfolder-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nnfolder-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nnfolder-open-marks (group server) - (let ((file (nnfolder-group-marks-pathname group))) - (if (file-exists-p file) - (condition-case err - (with-temp-buffer - (gnus-sethash file (nth 5 (file-attributes file)) - nnfolder-marks-modtime) - (nnheader-insert-file-contents file) - (setq nnfolder-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnfolder-marks (gnus-remassoc el nnfolder-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nnfolder marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nnfolder marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - group - (gnus-server-to-method (format "nnfolder:%s" server)))))) - (nnheader-message 7 "Bootstrapping marks for %s..." group) - (setq nnfolder-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nnfolder-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnfolder-marks (gnus-remassoc el nnfolder-marks))) - (nnfolder-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) - (provide 'nnfolder) ;;; nnfolder.el ends here diff --git a/lisp/nnimap.el b/lisp/nnimap.el index b02edf59b..eaf0f5ccf 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1233,7 +1233,8 @@ textual parts.") (setf (nnimap-group nnimap-object) nil) (setf (nnimap-initial-resync nnimap-object) 0) (let ((qresyncp (nnimap-capability "QRESYNC")) - params groups sequences active uidvalidity modseq group) + params groups sequences active uidvalidity modseq group + unexist) ;; Go through the infos and gather the data needed to know ;; what and how to request the data. (dolist (info infos) @@ -1241,13 +1242,15 @@ textual parts.") group (nnimap-decode-gnus-group (gnus-group-real-name (gnus-info-group info))) active (cdr (assq 'active params)) + unexist (assq 'unexist (gnus-info-marks info)) uidvalidity (cdr (assq 'uidvalidity params)) modseq (cdr (assq 'modseq params))) (setf (nnimap-examined nnimap-object) group) (if (and qresyncp uidvalidity active - modseq) + modseq + unexist) (push (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" (utf7-encode group t) @@ -1266,11 +1269,10 @@ textual parts.") ;; is read-only or not. "SELECT")) start) - (if (and active uidvalidity) + (if (and active uidvalidity unexist) ;; Fetch the last 100 flags. (setq start (max 1 (- (cdr active) 100))) - (setf (nnimap-initial-resync nnimap-object) - (1+ (nnimap-initial-resync nnimap-object))) + (incf (nnimap-initial-resync nnimap-object)) (setq start 1)) (push (list (nnimap-send-command "%s %S" command (utf7-encode group t)) @@ -1447,6 +1449,20 @@ textual parts.") (setq new-marks (gnus-range-nconcat old-marks new-marks))) (when new-marks (push (cons (car type) new-marks) marks))))) + ;; Keep track of non-existing articles. + (let* ((old-unexists (assq 'unexist marks)) + (unexists + (if completep + (gnus-range-difference + (gnus-active group) + (gnus-compress-sequence existing)) + (gnus-add-to-range + (cdr old-unexists) + (gnus-list-range-difference + existing (gnus-active group)))))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) ;; Tell Gnus whether there are any \Recent messages in any of ;; the groups. @@ -1490,6 +1506,14 @@ textual parts.") (gnus-sorted-complement existing new-marks)))) (when ticks (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)) + ;; Add vanished to the list of unexisting articles. + (when vanished + (let* ((old-unexists (assq 'unexist marks)) + (unexists (gnus-range-add (cdr old-unexists) vanished))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) (defun nnimap-imap-ranges-to-gnus-ranges (irange) diff --git a/lisp/nnmail.el b/lisp/nnmail.el index 9c3a814d3..988e1cdc1 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -553,11 +553,11 @@ parameter. It should return nil, `warn' or `delete'." (const warn) (const delete))) -(defcustom nnmail-extra-headers '(To Newsgroups) +(defcustom nnmail-extra-headers '(To Newsgroups Cc) "Extra headers to parse. In addition to the standard headers, these extra headers will be included in NOV headers (and the like) when backends parse headers." - :version "21.1" + :version "24.2" :group 'nnmail :type '(repeat symbol)) diff --git a/lisp/nnml.el b/lisp/nnml.el index b8652600a..600a0d21e 100644 --- a/lisp/nnml.el +++ b/lisp/nnml.el @@ -4,7 +4,7 @@ ;; Foundation, Inc. ;; Authors: Didier Verna (adding compaction) -;; Simon Josefsson (adding MARKS) +;; Simon Josefsson ;; Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news, mail @@ -67,15 +67,6 @@ the `nnml-generate-nov-databases' command. The function will go through all nnml directories and generate nov databases for them all. This may very well take some time.") -(defvoo nnml-marks-is-evil nil - "If non-nil, Gnus will never generate and use marks file for mail spools. -Using marks files makes it possible to backup and restore mail groups -separately from `.newsrc.eld'. If you have, for some reason, set this -to t, and want to set it to nil again, you should always remove the -corresponding marks file (usually named `.marks' in the nnml group -directory, but see `nnml-marks-file-name') for the group. Then the -marks file will be regenerated properly by Gnus.") - (defvoo nnml-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") @@ -102,7 +93,6 @@ non-nil.") "nnml version.") (defvoo nnml-nov-file-name ".overview") -(defvoo nnml-marks-file-name ".marks") (defvoo nnml-current-directory nil) (defvoo nnml-current-group nil) @@ -118,10 +108,6 @@ non-nil.") (defvoo nnml-file-coding-system nnmail-file-coding-system) -(defvoo nnml-marks nil) - -(defvar nnml-marks-modtime (gnus-make-hashtable)) - ;;; Interface functions. @@ -513,8 +499,7 @@ non-nil.") nnml-current-directory t (concat nnheader-numerical-short-files - "\\|" (regexp-quote nnml-nov-file-name) "$" - "\\|" (regexp-quote nnml-marks-file-name) "$"))) + "\\|" (regexp-quote nnml-nov-file-name) "$"))) (decoded (nnml-decoded-group-name group server))) (dolist (article articles) (when (file-writable-p article) @@ -554,10 +539,6 @@ non-nil.") (let ((overview (concat old-dir nnml-nov-file-name))) (when (file-exists-p overview) (rename-file overview (concat new-dir nnml-nov-file-name)))) - ;; Move .marks file. - (let ((marks (concat old-dir nnml-marks-file-name))) - (when (file-exists-p marks) - (rename-file marks (concat new-dir nnml-marks-file-name)))) (when (<= (length (directory-files old-dir)) 2) (ignore-errors (delete-directory old-dir))) ;; That went ok, so we change the internal structures. @@ -1033,99 +1014,6 @@ Use the nov database for the current group if available." (forward-line 1)) alist)))) -(deffoo nnml-request-set-mark (group actions &optional server) - (nnml-possibly-change-directory group server) - (unless nnml-marks-is-evil - (nnml-open-marks group server) - (setq nnml-marks (nnheader-update-marks-actions nnml-marks actions)) - (nnml-save-marks group server)) - nil) - -(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) - (nnml-open-marks group server) - ;; Update info using `nnml-marks'. - (mapc (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnml-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) - (let ((seen (cdr (assq 'read nnml-marks)))) - (gnus-info-set-read info - (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen))) - (nnheader-message 8 "Updating marks for %s...done" group)) - info) - -(defun nnml-marks-changed-p (group server) - (let ((file (nnml-group-pathname group nnml-marks-file-name server))) - (if (null (gnus-gethash file nnml-marks-modtime)) - t ;; never looked at marks file, assume it has changed - (not (equal (gnus-gethash file nnml-marks-modtime) - (nth 5 (file-attributes file))))))) - -(defun nnml-save-marks (group server) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (nnml-group-pathname group nnml-marks-file-name server))) - (condition-case err - (progn - (nnml-possibly-create-directory group server) - (with-temp-file file - (erase-buffer) - (gnus-prin1 nnml-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nnml-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nnml-open-marks (group server) - (let* ((decoded (nnml-decoded-group-name group server)) - (file (nnmail-group-pathname decoded nnml-directory - nnml-marks-file-name)) - (file-name-coding-system nnmail-pathname-coding-system)) - (if (file-exists-p file) - (condition-case err - (with-temp-buffer - (gnus-sethash file (nth 5 (file-attributes file)) - nnml-marks-modtime) - (nnheader-insert-file-contents file) - (setq nnml-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnml-marks (gnus-remassoc el nnml-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nnml marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nnml marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - group - (gnus-server-to-method - (format "nnml:%s" (or server ""))))))) - (setq decoded (if (member server '(nil "")) - (concat "nnml:" decoded) - (format "nnml+%s:%s" server decoded))) - (nnheader-message 7 "Bootstrapping marks for %s..." decoded) - (setq nnml-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nnml-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnml-marks (gnus-remassoc el nnml-marks))) - (nnml-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" decoded))))) - - ;;; ;;; Group and server compaction. -- dvl ;;; @@ -1275,19 +1163,11 @@ Use the nov database for the current group if available." (gnus-set-active group-full-name active)) ;; 1 bis/ ;; #### NOTE: normally, we should save the overview (NOV) file - ;; #### here, just like we save the marks file. However, there is no - ;; #### such function as nnml-save-nov for a single group. Only for - ;; #### all groups. Gnus inconsistency is getting worse every day... - ;; 2/ Rebuild marks file: - (unless nnml-marks-is-evil - ;; #### NOTE: this constant use of global variables everywhere is - ;; #### truly disgusting. Gnus really needs a *major* cleanup. - (setq nnml-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nnml-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnml-marks (gnus-remassoc el nnml-marks))) - (nnml-save-marks group server)) - ;; 3/ Save everything if this was not part of a bigger operation: + ;; #### here. However, there is no such function as + ;; #### nnml-save-nov for a single group. Only for all + ;; #### groups. Gnus inconsistency is getting worse every + ;; #### day... ;; 3/ Save everything if this was not part of + ;; #### a bigger operation: (if (not save) ;; Nothing to save (yet): t @@ -1298,9 +1178,6 @@ Use the nov database for the current group if available." (nnml-save-nov) ;; b/ Save the active file: (nnmail-save-active nnml-group-alist nnml-active-file) - (let ((marks (nnml-group-pathname group nnml-marks-file-name server))) - (when (file-exists-p marks) - (delete-file marks))) t))))) (defun nnml-request-compact (&optional server) diff --git a/lisp/nntp.el b/lisp/nntp.el index 98393a617..a9839a014 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -222,27 +222,6 @@ then use this hook to rsh to the remote machine and start a proxy NNTP server there that you can connect to. See also `nntp-open-connection-function'") -(defvoo nntp-coding-system-for-read 'binary - "*Coding system to read from NNTP.") - -(defvoo nntp-coding-system-for-write 'binary - "*Coding system to write to NNTP.") - -;; Marks -(defvoo nntp-marks-is-evil nil - "*If non-nil, Gnus will never generate and use marks file for nntp groups. -See `nnml-marks-is-evil' for more information.") - -(defvoo nntp-marks-file-name ".marks") -(defvoo nntp-marks nil) -(defvar nntp-marks-modtime (gnus-make-hashtable)) - -(defcustom nntp-marks-directory - (nnheader-concat gnus-directory "marks/") - "*The directory where marks for nntp groups will be stored." - :group 'nntp - :type 'directory) - (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :group 'nntp @@ -1188,43 +1167,6 @@ command whose response triggered the error." (deffoo nntp-asynchronous-p () t) -(deffoo nntp-request-set-mark (group actions &optional server) - (when (and (not nntp-marks-is-evil) - nntp-marks-file-name) - (nntp-possibly-create-directory group server) - (nntp-open-marks group server) - (setq nntp-marks (nnheader-update-marks-actions nntp-marks actions)) - (nntp-save-marks group server)) - nil) - -(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) - (nntp-open-marks group server) - ;; Update info using `nntp-marks'. - (mapc (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nntp-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) - (let ((seen (cdr (assq 'read nntp-marks)))) - (gnus-info-set-read info - (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen))) - (nnheader-message 8 "Updating marks for %s...done" group))) - nil) - - ;;; Hooky functions. @@ -1354,8 +1296,8 @@ password contained in '~/.nntp-authinfo'." (nntp-kill-buffer ,pbuffer))))) (process (condition-case err - (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write) + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) (map '((nntp-open-network-stream network) (network-only plain) ; compat (nntp-open-plain-stream plain) @@ -2164,95 +2106,6 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc))) -;; Marks handling - -(defun nntp-marks-directory (server) - (expand-file-name server nntp-marks-directory)) - -(defvar nntp-server-to-method-cache nil - "Alist of servers and select methods.") - -(defun nntp-group-pathname (server group &optional file) - "Return an absolute file name of FILE for GROUP on SERVER." - (let ((method (cdr (assoc server nntp-server-to-method-cache)))) - (unless method - (push (cons server (setq method (or (gnus-server-to-method server) - (gnus-find-method-for-group group)))) - nntp-server-to-method-cache)) - (nnmail-group-pathname - (mm-decode-coding-string group - (inline (gnus-group-name-charset method group))) - (nntp-marks-directory server) - file))) - -(defun nntp-possibly-create-directory (group server) - (let ((dir (nntp-group-pathname server group)) - (file-name-coding-system nnmail-pathname-coding-system)) - (unless (file-exists-p dir) - (make-directory (directory-file-name dir) t) - (nnheader-message 5 "Creating nntp marks directory %s" dir)))) - -(autoload 'time-less-p "time-date") - -(defun nntp-marks-changed-p (group server) - (let ((file (nntp-group-pathname server group nntp-marks-file-name)) - (file-name-coding-system nnmail-pathname-coding-system)) - (if (null (gnus-gethash file nntp-marks-modtime)) - t ;; never looked at marks file, assume it has changed - (time-less-p (gnus-gethash file nntp-marks-modtime) - (nth 5 (file-attributes file)))))) - -(defun nntp-save-marks (group server) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (nntp-group-pathname server group nntp-marks-file-name))) - (condition-case err - (progn - (nntp-possibly-create-directory group server) - (with-temp-file file - (erase-buffer) - (gnus-prin1 nntp-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nntp-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nntp-open-marks (group server) - (let ((file (nntp-group-pathname server group nntp-marks-file-name)) - (file-name-coding-system nnmail-pathname-coding-system)) - (if (file-exists-p file) - (condition-case err - (with-temp-buffer - (gnus-sethash file (nth 5 (file-attributes file)) - nntp-marks-modtime) - (nnheader-insert-file-contents file) - (setq nntp-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nntp-marks (gnus-remassoc el nntp-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nntp marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nntp marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - group - (gnus-server-to-method (format "nntp:%s" server))))) - (decoded-name (mm-decode-coding-string - group - (gnus-group-name-charset - (gnus-server-to-method server) group)))) - (nnheader-message 7 "Bootstrapping marks for %s..." decoded-name) - (setq nntp-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nntp-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nntp-marks (gnus-remassoc el nntp-marks))) - (nntp-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" - decoded-name))))) - (provide 'nntp) ;;; nntp.el ends here diff --git a/lisp/registry.el b/lisp/registry.el index c54fe3e3d..b2130d56e 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -79,12 +79,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (eval-and-compile (or (ignore-errors (progn (require 'eieio) @@ -373,111 +367,5 @@ Proposes any entries over the max-hard limit minus size * prune-factor." collect k))) (list limit candidates)))) -(ert-deftest registry-instantiation-test () - (should (registry-db "Testing"))) - -(ert-deftest registry-match-test () - (let ((entry '((hello "goodbye" "bye") (blank)))) - - (message "Testing :regex matching") - (should (registry--match :regex entry '((hello "nye" "bye")))) - (should (registry--match :regex entry '((hello "good")))) - (should-not (registry--match :regex entry '((hello "nye")))) - (should-not (registry--match :regex entry '((hello)))) - - (message "Testing :member matching") - (should (registry--match :member entry '((hello "bye")))) - (should (registry--match :member entry '((hello "goodbye")))) - (should-not (registry--match :member entry '((hello "good")))) - (should-not (registry--match :member entry '((hello "nye")))) - (should-not (registry--match :member entry '((hello))))) - (message "Done with matching testing.")) - -(defun registry-make-testable-db (n &optional name file) - (let* ((db (registry-db - (or name "Testing") - :file (or file "unused") - :max-hard n - :max-soft 0 ; keep nothing not precious - :precious '(extra more-extra) - :tracked '(sender subject groups)))) - (dotimes (i n) - (registry-insert db i `((sender "me") - (subject "about you") - (more-extra) ; empty data key should be pruned - ;; first 5 entries will NOT have this extra data - ,@(when (< 5 i) (list (list 'extra "more data"))) - (groups ,(number-to-string i))))) - db)) - -(ert-deftest registry-usage-test () - (let* ((n 100) - (db (registry-make-testable-db n))) - (message "size %d" n) - (should (= n (registry-size db))) - (message "max-hard test") - (should-error (registry-insert db "new" '())) - (message "Individual lookup") - (should (= 58 (caadr (registry-lookup db '(1 58 99))))) - (message "Grouped individual lookup") - (should (= 3 (length (registry-lookup db '(1 58 99))))) - (when (boundp 'lexical-binding) - (message "Individual lookup (breaks before lexbind)") - (should (= 58 - (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99))))) - (message "Grouped individual lookup (breaks before lexbind)") - (should (= 3 - (length (registry-lookup-breaks-before-lexbind db - '(1 58 99)))))) - (message "Search") - (should (= n (length (registry-search db :all t)))) - (should (= n (length (registry-search db :member '((sender "me")))))) - (message "Secondary index search") - (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) - (should (equal '(74) (registry-lookup-secondary-value db 'groups "74"))) - (message "Delete") - (should (registry-delete db '(1) t)) - (decf n) - (message "Search after delete") - (should (= n (length (registry-search db :all t)))) - (message "Secondary search after delete") - (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) - ;; (message "Pruning") - ;; (let* ((tokeep (registry-search db :member '((extra "more data")))) - ;; (count (- n (length tokeep))) - ;; (pruned (registry-prune db)) - ;; (prune-count (length pruned))) - ;; (message "Expecting to prune %d entries and pruned %d" - ;; count prune-count) - ;; (should (and (= count 5) - ;; (= count prune-count)))) - (message "Done with usage testing."))) - -(ert-deftest registry-persistence-test () - (let* ((n 100) - (tempfile (make-temp-file "registry-persistence-")) - (name "persistence tester") - (db (registry-make-testable-db n name tempfile)) - size back) - (message "Saving to %s" tempfile) - (eieio-persistent-save db) - (setq size (nth 7 (file-attributes tempfile))) - (message "Saved to %s: size %d" tempfile size) - (should (< 0 size)) - (with-temp-buffer - (insert-file-contents-literally tempfile) - (should (looking-at (concat ";; Object " - name - "\n;; EIEIO PERSISTENT OBJECT")))) - (message "Reading object back") - (setq back (eieio-persistent-read tempfile)) - (should back) - (message "Read object back: %d keys, expected %d==%d" - (registry-size back) n (registry-size db)) - (should (= (registry-size back) n)) - (should (= (registry-size back) (registry-size db))) - (delete-file tempfile)) - (message "Done with persistence testing.")) - (provide 'registry) ;;; registry.el ends here diff --git a/lisp/shr.el b/lisp/shr.el index dd0f1599c..954e97426 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -119,6 +119,7 @@ cid: URL as the argument.") (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) (define-key map "i" 'shr-browse-image) + (define-key map "z" 'shr-zoom-image) (define-key map "I" 'shr-insert-image) (define-key map "u" 'shr-copy-url) (define-key map "v" 'shr-browse-url) @@ -235,6 +236,40 @@ the URL of the image to the kill buffer instead." (list (current-buffer) (1- (point)) (point-marker)) t t)))) +(defun shr-zoom-image () + "Toggle the image size. +The size will be rotated between the default size, the original +size, and full-buffer size." + (interactive) + (let ((url (get-text-property (point) 'image-url)) + (size (get-text-property (point) 'image-size)) + (buffer-read-only nil)) + (if (not url) + (message "No image under point") + ;; Delete the old picture. + (while (get-text-property (point) 'image-url) + (forward-char -1)) + (forward-char 1) + (let ((start (point))) + (while (get-text-property (point) 'image-url) + (forward-char 1)) + (forward-char -1) + (put-text-property start (point) 'display nil) + (when (> (- (point) start) 2) + (delete-region start (1- (point))))) + (message "Inserting %s..." url) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) (1- (point)) (point-marker) + (list (cons 'size + (cond ((or (eq size 'default) + (null size)) + 'original) + ((eq size 'original) + 'full) + ((eq size 'full) + 'default))))) + t)))) + ;;; Utility functions. (defun shr-transform-dom (dom) @@ -523,7 +558,7 @@ the URL of the image to the kill buffer instead." (expand-file-name (file-name-nondirectory url) directory))))) -(defun shr-image-fetched (status buffer start end) +(defun shr-image-fetched (status buffer start end &optional flags) (let ((image-buffer (current-buffer))) (when (and (buffer-name buffer) (not (plist-get status :error))) @@ -534,30 +569,53 @@ the URL of the image to the kill buffer instead." (with-current-buffer buffer (save-excursion (let ((alt (buffer-substring start end)) + (properties (text-properties-at start)) (inhibit-read-only t)) (delete-region start end) (goto-char start) - (funcall shr-put-image-function data alt))))))) + (funcall shr-put-image-function data alt flags) + (while properties + (let ((type (pop properties)) + (value (pop properties))) + (unless (memq type '(display image-size)) + (put-text-property start (point) type value)))))))))) (kill-buffer image-buffer))) -(defun shr-put-image (data alt) +(defun shr-put-image (data alt &optional flags) "Put image DATA with a string ALT. Return image." (if (display-graphic-p) - (let ((image (ignore-errors - (shr-rescale-image data)))) + (let* ((size (cdr (assq 'size flags))) + (start (point)) + (image (cond + ((eq size 'original) + (create-image data nil t :ascent 100)) + ((eq size 'full) + (ignore-errors + (shr-rescale-image data t))) + (t + (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 "*")) + (if (eq size 'original) + (let ((overlays (overlays-at (point)))) + (insert-sliced-image image (or alt "*") nil 20 1) + (dolist (overlay overlays) + (overlay-put overlay 'face 'default))) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) (when (image-animated-p image) (image-animate image nil 60))) image) (insert alt))) -(defun shr-rescale-image (data) +(defun shr-rescale-image (data &optional force) + "Rescale DATA, if too big, to fit the current buffer. +If FORCE, rescale the image anyway." (let ((image (create-image data nil t :ascent 100))) (if (or (not (fboundp 'imagemagick-types)) (not (get-buffer-window (current-buffer)))) @@ -572,7 +630,8 @@ the URL of the image to the kill buffer instead." (window-height (truncate (* shr-max-image-proportion (- (nth 3 edges) (nth 1 edges))))) scaled-image) - (when (> height window-height) + (when (or force + (> height window-height)) (setq image (or (create-image data 'imagemagick t :height window-height :ascent 100) diff --git a/lisp/tests/gnustest-registry.el b/lisp/tests/gnustest-registry.el new file mode 100644 index 000000000..512fab499 --- /dev/null +++ b/lisp/tests/gnustest-registry.el @@ -0,0 +1,216 @@ +;;; gnustest-registry.el --- Registry and Gnus registry testing for Gnus +;; Copyright (C) 2011-2012 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov + +;; This file is not part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (when (null (ignore-errors (require 'ert))) + (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) + +(ignore-errors + (require 'ert)) + +(require 'registry) +(require 'gnus-registry) + +(ert-deftest gnustest-registry-instantiation-test () + (should (registry-db "Testing"))) + +(ert-deftest gnustest-registry-match-test () + (let ((entry '((hello "goodbye" "bye") (blank)))) + + (message "Testing :regex matching") + (should (registry--match :regex entry '((hello "nye" "bye")))) + (should (registry--match :regex entry '((hello "good")))) + (should-not (registry--match :regex entry '((hello "nye")))) + (should-not (registry--match :regex entry '((hello)))) + + (message "Testing :member matching") + (should (registry--match :member entry '((hello "bye")))) + (should (registry--match :member entry '((hello "goodbye")))) + (should-not (registry--match :member entry '((hello "good")))) + (should-not (registry--match :member entry '((hello "nye")))) + (should-not (registry--match :member entry '((hello))))) + (message "Done with matching testing.")) + +(defun gnustest-registry-make-testable-db (n &optional name file) + (let* ((db (registry-db + (or name "Testing") + :file (or file "unused") + :max-hard n + :max-soft 0 ; keep nothing not precious + :precious '(extra more-extra) + :tracked '(sender subject groups)))) + (dotimes (i n) + (registry-insert db i `((sender "me") + (subject "about you") + (more-extra) ; empty data key should be pruned + ;; first 5 entries will NOT have this extra data + ,@(when (< 5 i) (list (list 'extra "more data"))) + (groups ,(number-to-string i))))) + db)) + +(ert-deftest gnustest-registry-usage-test () + (let* ((n 100) + (db (gnustest-registry-make-testable-db n))) + (message "size %d" n) + (should (= n (registry-size db))) + (message "max-hard test") + (should-error (registry-insert db "new" '())) + (message "Individual lookup") + (should (= 58 (caadr (registry-lookup db '(1 58 99))))) + (message "Grouped individual lookup") + (should (= 3 (length (registry-lookup db '(1 58 99))))) + (when (boundp 'lexical-binding) + (message "Individual lookup (breaks before lexbind)") + (should (= 58 + (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99))))) + (message "Grouped individual lookup (breaks before lexbind)") + (should (= 3 + (length (registry-lookup-breaks-before-lexbind db + '(1 58 99)))))) + (message "Search") + (should (= n (length (registry-search db :all t)))) + (should (= n (length (registry-search db :member '((sender "me")))))) + (message "Secondary index search") + (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) + (should (equal '(74) (registry-lookup-secondary-value db 'groups "74"))) + (message "Delete") + (should (registry-delete db '(1) t)) + (decf n) + (message "Search after delete") + (should (= n (length (registry-search db :all t)))) + (message "Secondary search after delete") + (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) + ;; (message "Pruning") + ;; (let* ((tokeep (registry-search db :member '((extra "more data")))) + ;; (count (- n (length tokeep))) + ;; (pruned (registry-prune db)) + ;; (prune-count (length pruned))) + ;; (message "Expecting to prune %d entries and pruned %d" + ;; count prune-count) + ;; (should (and (= count 5) + ;; (= count prune-count)))) + (message "Done with usage testing."))) + +(ert-deftest gnustest-registry-persistence-test () + (let* ((n 100) + (tempfile (make-temp-file "registry-persistence-")) + (name "persistence tester") + (db (gnustest-registry-make-testable-db n name tempfile)) + size back) + (message "Saving to %s" tempfile) + (eieio-persistent-save db) + (setq size (nth 7 (file-attributes tempfile))) + (message "Saved to %s: size %d" tempfile size) + (should (< 0 size)) + (with-temp-buffer + (insert-file-contents-literally tempfile) + (should (looking-at (concat ";; Object " + name + "\n;; EIEIO PERSISTENT OBJECT")))) + (message "Reading object back") + (setq back (eieio-persistent-read tempfile)) + (should back) + (message "Read object back: %d keys, expected %d==%d" + (registry-size back) n (registry-size db)) + (should (= (registry-size back) n)) + (should (= (registry-size back) (registry-size db))) + (delete-file tempfile)) + (message "Done with persistence testing.")) + +(ert-deftest gnustest-gnus-registry-misc-test () + (should-error (gnus-registry-extract-addresses '("" ""))) + + (should (equal '("Ted Zlatanov " + "noname " + "noname " + "noname ") + (gnus-registry-extract-addresses + (concat "Ted Zlatanov , " + "ed , " ; "ed" is not a valid name here + "cyd@stupidchicken.com, " + "tzz@lifelogs.com"))))) + +(ert-deftest gnustest-gnus-registry-usage-test () + (let* ((n 100) + (tempfile (make-temp-file "gnus-registry-persist")) + (db (gnus-registry-make-db tempfile)) + (gnus-registry-db db) + back size) + (message "Adding %d keys to the test Gnus registry" n) + (dotimes (i n) + (let ((id (number-to-string i))) + (gnus-registry-handle-action id + (if (>= 50 i) "fromgroup" nil) + "togroup" + (when (>= 70 i) + (format "subject %d" (mod i 10))) + (when (>= 80 i) + (format "sender %d" (mod i 10)))))) + (message "Testing Gnus registry size is %d" n) + (should (= n (registry-size db))) + (message "Looking up individual keys (registry-lookup)") + (should (equal (loop for e + in (mapcar 'cadr + (registry-lookup db '("20" "83" "72"))) + collect (assq 'subject e) + collect (assq 'sender e) + collect (assq 'group e)) + '((subject "subject 0") (sender "sender 0") (group "togroup") + (subject) (sender) (group "togroup") + (subject) (sender "sender 2") (group "togroup")))) + + (message "Looking up individual keys (gnus-registry-id-key)") + (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup"))) + (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4"))) + (message "Trying to insert a duplicate key") + (should-error (gnus-registry-insert db "55" '())) + (message "Looking up individual keys (gnus-registry-get-or-make-entry)") + (should (gnus-registry-get-or-make-entry "22")) + (message "Saving the Gnus registry to %s" tempfile) + (should (gnus-registry-save tempfile db)) + (setq size (nth 7 (file-attributes tempfile))) + (message "Saving the Gnus registry to %s: size %d" tempfile size) + (should (< 0 size)) + (with-temp-buffer + (insert-file-contents-literally tempfile) + (should (looking-at (concat ";; Object " + "Gnus Registry" + "\n;; EIEIO PERSISTENT OBJECT")))) + (message "Reading Gnus registry back") + (setq back (eieio-persistent-read tempfile)) + (should back) + (message "Read Gnus registry back: %d keys, expected %d==%d" + (registry-size back) n (registry-size db)) + (should (= (registry-size back) n)) + (should (= (registry-size back) (registry-size db))) + (delete-file tempfile) + (message "Pruning Gnus registry to 0 by setting :max-soft") + (oset db :max-soft 0) + (registry-prune db) + (should (= (registry-size db) 0))) + (message "Done with Gnus registry usage testing.")) + +(provide 'gnustest-registry) diff --git a/makepub b/makepub index 4159d0f18..58c51cba8 100755 --- a/makepub +++ b/makepub @@ -1,5 +1,5 @@ #!/bin/bash -name="No Gnus" +name="Ma Gnus" if [ `whoami` != "larsi" ]; then echo "This script is for larsi only" diff --git a/texi/ChangeLog b/texi/ChangeLog index 69ecc39e6..c0f7e1fd2 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -2,16 +2,45 @@ * gnus.texi (Posting Styles): Fix cross-refs to other manual. +2012-02-16 Lars Ingebrigtsen + + * gnus.texi (Various Summary Stuff): Remove mention of + `gnus-propagate-marks'. + +2012-02-15 Lars Ingebrigtsen + + * gnus.texi: Remove mentions of nnml/nnfolder/nntp backend marks, which + no longer exist. + 2012-02-13 Lars Ingebrigtsen * gnus.texi (Customizing the IMAP Connection): Mention nnimap-record-commands. +2012-02-08 Katsumi Yamaoka + + * gnus.texi (Archived Messages): Document gnus-gcc-self-resent-messages. + 2012-02-07 Lars Ingebrigtsen * gnus.texi (Mail Source Specifiers): Add a pop3 via an SSH tunnel example (modified from an example by Michael Albinus). +2012-02-06 Lars Ingebrigtsen + + * message.texi (Mail Variables): Mention the optional user parameter + for X-Message-SMTP-Method. + +2012-02-02 Lars Ingebrigtsen + + * gnus.texi (Posting Styles): Mention X-Message-SMTP-Method. + + * message.texi (Mail Variables): Document X-Message-SMTP-Method. + +2012-01-31 Lars Ingebrigtsen + + * gnus.texi (Key Index): Change encoding to utf-8. + 2012-01-30 Philipp Haselwarter (tiny change) * gnus.texi (Agent Basics): Fix outdated description of diff --git a/texi/gnus.texi b/texi/gnus.texi index 754af15f0..9194753dd 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -8,7 +8,7 @@ @syncodeindex vr cp @syncodeindex pg cp -@documentencoding ISO-8859-1 +@documentencoding UTF-8 @copying Copyright @copyright{} 1995-2012 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ developing GNU and promoting software freedom.'' \begin{document} % Adjust ../Makefile.in if you change the following line: -\newcommand{\gnusversionname}{No Gnus v0.20} +\newcommand{\gnusversionname}{Ma Gnus v0.4} \newcommand{\gnuschaptername}{} \newcommand{\gnussectionname}{} @@ -358,7 +358,7 @@ spool or your mbox file. All at the same time, if you want to push your luck. @c Adjust ../Makefile.in if you change the following line: -This manual corresponds to No Gnus v0.20 +This manual corresponds to Ma Gnus v0.4 @ifnottex @insertcopying @@ -392,7 +392,7 @@ people should be empowered to do what they want by using (or abusing) the program. @c Adjust ../Makefile.in if you change the following line: -This manual corresponds to No Gnus v0.20 +This manual corresponds to Ma Gnus v0.4 @heading Other related manuals @itemize @@ -663,7 +663,6 @@ Getting News * Direct Functions:: Connecting directly to the server. * Indirect Functions:: Connecting indirectly to the server. * Common Variables:: Understood by several connection functions. -* NNTP marks:: Storing marks for @acronym{NNTP} servers. Getting Mail @@ -907,7 +906,8 @@ New Features * Quassia Gnus:: Two times two is four, or Gnus 5.6/5.7. * Pterodactyl Gnus:: Pentad also starts with P, AKA Gnus 5.8/5.9. * Oort Gnus:: It's big. It's far out. Gnus 5.10/5.11. -* No Gnus:: Very punny. +* No Gnus:: Very punny. Gnus 5.12/5.13 +* Ma Gnus:: Celebrating 25 years of Gnus. Customization @@ -1066,10 +1066,6 @@ you would typically set this variable to (setq gnus-secondary-select-methods '((nnmbox ""))) @end lisp -Note: the @acronym{NNTP} back end stores marks in marks files -(@pxref{NNTP marks}). This feature makes it easy to share marks between -several Gnus installations, but may slow down things a bit when fetching -new articles. @xref{NNTP marks}, for more information. @node The Server is Down @@ -2884,7 +2880,7 @@ composed messages will be @code{Gcc}'d to the current group. If generated, if @code{(gcc-self . "string")} is present, this string will be inserted literally as a @code{gcc} header. This parameter takes precedence over any default @code{Gcc} rules as described later -(@pxref{Archived Messages}). +(@pxref{Archived Messages}), with the exception for messages to resend. @strong{Caveat}: Adding @code{(gcc-self . t)} to the parameter list of @code{nntp} groups (or the like) isn't valid. An @code{nntp} server @@ -3027,6 +3023,7 @@ like this in the group parameters: @example (posting-style (name "Funky Name") + ("X-Message-SMTP-Method" "smtp smtp.example.org 587") ("X-My-Header" "Funky Value") (signature "Funky Signature")) @end example @@ -4293,12 +4290,11 @@ default is @code{nil} in Emacs, or is the aliasee of the coding system named @code{file-name} (a certain coding system of which an alias is @code{file-name}) in XEmacs. -The @code{nnml} back end, the @code{nnrss} back end, the @acronym{NNTP} -marks feature (@pxref{NNTP marks}), the agent, and the cache use -non-@acronym{ASCII} group names in those files and directories. This -variable overrides the value of @code{file-name-coding-system} which -specifies the coding system used when encoding and decoding those file -names and directory names. +The @code{nnml} back end, the @code{nnrss} back end, the agent, and +the cache use non-@acronym{ASCII} group names in those files and +directories. This variable overrides the value of +@code{file-name-coding-system} which specifies the coding system used +when encoding and decoding those file names and directory names. In XEmacs (with the @code{mule} feature), @code{file-name-coding-system} is the only means to specify the coding system used to encode and decode @@ -8981,7 +8977,7 @@ Translate many non-@acronym{ASCII} characters into their @acronym{ASCII} equivalents (@code{gnus-article-treat-non-ascii}). This is mostly useful if you're on a terminal that has a limited font and doesn't show accented characters, ``advanced'' punctuation, and the -like. For instance, @samp{»} is translated into @samp{>>}, and so on. +like. For instance, @samp{»} is translated into @samp{>>}, and so on. @item W Y f @kindex W Y f (Summary) @@ -10814,12 +10810,6 @@ buffers. For example: Also @pxref{Group Parameters}. -@vindex gnus-propagate-marks -@item gnus-propagate-marks -If non-@code{nil}, propagate marks to the backends for possible -storing. @xref{NNTP marks}, and friends, for a more fine-grained -sieve. - @end table @@ -12669,6 +12659,22 @@ and matches the Gcc group name, attach files as external parts; if it is non-@code{nil}, the behavior is the same as @code{all}, but it may be changed in the future. +@item gnus-gcc-self-resent-messages +@vindex gnus-gcc-self-resent-messages +Like the @code{gcc-self} group parameter, applied only for unmodified +messages that @code{gnus-summary-resend-message} (@pxref{Summary Mail +Commands}) resends. Non-@code{nil} value of this variable takes +precedence over any existing @code{Gcc} header. + +If this is @code{none}, no @code{Gcc} copy will be made. If this is +@code{t}, messages resent will be @code{Gcc} copied to the current +group. If this is a string, it specifies a group to which resent +messages will be @code{Gcc} copied. If this is @code{nil}, @code{Gcc} +will be done according to existing @code{Gcc} header(s), if any. If +this is @code{no-gcc-self}, that is the default, resent messages will be +@code{Gcc} copied to groups that existing @code{Gcc} header specifies, +except for the current group. + @end table @@ -12800,6 +12806,7 @@ So here's a new example: (signature-file "~/.work-signature") (address "user@@bar.foo") (body "You are fired.\n\nSincerely, your boss.") + ("X-Message-SMTP-Method" "smtp smtp.example.org 587") (organization "Important Work, Inc")) ("nnml:.*" (From (with-current-buffer gnus-article-buffer @@ -12814,6 +12821,13 @@ if you fill many roles. You may also use @code{message-alternative-emails} instead. @xref{Message Headers, ,Message Headers, message, Message Manual}. +Of particular interest in the ``work-mail'' style is the +@samp{X-Message-SMTP-Method} header. It specifies how to send the +outgoing email. You may want to sent certain emails through certain +@acronym{SMTP} servers due to company policies, for instance. +@xref{Mail Variables, ,Message Variables, message, Message Manual}. + + @node Drafts @section Drafts @cindex drafts @@ -13739,7 +13753,6 @@ don't update their active files often, this can help. * Direct Functions:: Connecting directly to the server. * Indirect Functions:: Connecting indirectly to the server. * Common Variables:: Understood by several connection functions. -* NNTP marks:: Storing marks for @acronym{NNTP} servers. @end menu @@ -14010,53 +14023,6 @@ is @samp{()}. @end table -@node NNTP marks -@subsubsection NNTP marks -@cindex storing NNTP marks - -Gnus stores marks (@pxref{Marking Articles}) for @acronym{NNTP} -servers in marks files. A marks file records what marks you have set -in a group and each file is specific to the corresponding server. -Marks files are stored in @file{~/News/marks} -(@code{nntp-marks-directory}) under a classic hierarchy resembling -that of a news server, for example marks for the group -@samp{gmane.discuss} on the news.gmane.org server will be stored in -the file @file{~/News/marks/news.gmane.org/gmane/discuss/.marks}. - -Marks files are useful because you can copy the @file{~/News/marks} -directory (using rsync, scp or whatever) to another Gnus installation, -and it will realize what articles you have read and marked. The data -in @file{~/News/marks} has priority over the same data in -@file{~/.newsrc.eld}. - -Note that marks files are very much server-specific: Gnus remembers -the article numbers so if you don't use the same servers on both -installations things are most likely to break (most @acronym{NNTP} -servers do not use the same article numbers as any other server). -However, if you use servers A, B, C on one installation and servers A, -D, E on the other, you can sync the marks files for A and then you'll -get synchronization for that server between the two installations. - -Using @acronym{NNTP} marks can possibly incur a performance penalty so -if Gnus feels sluggish, try setting the @code{nntp-marks-is-evil} -variable to @code{t}. Marks will then be stored in @file{~/.newsrc.eld}. - -Related variables: - -@table @code - -@item nntp-marks-is-evil -@vindex nntp-marks-is-evil -If non-@code{nil}, this back end will ignore any marks files. The -default is @code{nil}. - -@item nntp-marks-directory -@vindex nntp-marks-directory -The directory where marks for nntp groups will be stored. - -@end table - - @node News Spool @subsection News Spool @cindex nnspool @@ -16147,22 +16113,6 @@ splitting. It has to create lots of files, and it also generates @acronym{NOV} databases for the incoming mails. This makes it possibly the fastest back end when it comes to reading mail. -@cindex self contained nnml servers -@cindex marks -When the marks file is used (which it is by default), @code{nnml} -servers have the property that you may backup them using @code{tar} or -similar, and later be able to restore them into Gnus (by adding the -proper @code{nnml} server) and have all your marks be preserved. Marks -for a group are usually stored in the @code{.marks} file (but see -@code{nnml-marks-file-name}) within each @code{nnml} group's directory. -Individual @code{nnml} groups are also possible to backup, use @kbd{G m} -to restore the group (after restoring the backup into the nnml -directory). - -If for some reason you believe your @file{.marks} files are screwed -up, you can just delete them all. Gnus will then correctly regenerate -them next time it starts. - Virtual server settings: @table @code @@ -16200,15 +16150,6 @@ The name of the @acronym{NOV} files. The default is @file{.overview}. @vindex nnml-prepare-save-mail-hook Hook run narrowed to an article before saving. -@item nnml-marks-is-evil -@vindex nnml-marks-is-evil -If non-@code{nil}, this back end will ignore any @sc{marks} files. The -default is @code{nil}. - -@item nnml-marks-file-name -@vindex nnml-marks-file-name -The name of the @dfn{marks} files. The default is @file{.marks}. - @item nnml-use-compressed-files @vindex nnml-use-compressed-files If non-@code{nil}, @code{nnml} will allow using compressed message @@ -16549,19 +16490,6 @@ separate file. Each file is in the standard Un*x mbox format. @code{nnfolder} will add extra headers to keep track of article numbers and arrival dates. -@cindex self contained nnfolder servers -@cindex marks -When the marks file is used (which it is by default), @code{nnfolder} -servers have the property that you may backup them using @code{tar} or -similar, and later be able to restore them into Gnus (by adding the -proper @code{nnfolder} server) and have all your marks be preserved. -Marks for a group are usually stored in a file named as the mbox file -with @code{.mrk} concatenated to it (but see -@code{nnfolder-marks-file-suffix}) within the @code{nnfolder} -directory. Individual @code{nnfolder} groups are also possible to -backup, use @kbd{G m} to restore the group (after restoring the backup -into the @code{nnfolder} directory). - Virtual server settings: @table @code @@ -16620,20 +16548,6 @@ The extension for @acronym{NOV} files. The default is @file{.nov}. The directory where the @acronym{NOV} files should be stored. If @code{nil}, @code{nnfolder-directory} is used. -@item nnfolder-marks-is-evil -@vindex nnfolder-marks-is-evil -If non-@code{nil}, this back end will ignore any @sc{marks} files. The -default is @code{nil}. - -@item nnfolder-marks-file-suffix -@vindex nnfolder-marks-file-suffix -The extension for @sc{marks} files. The default is @file{.mrk}. - -@item nnfolder-marks-directory -@vindex nnfolder-marks-directory -The directory where the @sc{marks} files should be stored. If -@code{nil}, @code{nnfolder-directory} is used. - @end table @@ -16794,9 +16708,7 @@ undergo treatment such as duplicate checking. @code{nnmaildir} stores article marks for a given group in the corresponding maildir, in a way designed so that it's easy to manipulate them from outside Gnus. You can tar up a maildir, unpack it somewhere -else, and still have your marks. @code{nnml} also stores marks, but -it's not as easy to work with them from outside Gnus as with -@code{nnmaildir}. +else, and still have your marks. @code{nnmaildir} uses a significant amount of memory to speed things up. (It keeps in memory some of the things that @code{nnml} stores in files @@ -16888,16 +16800,6 @@ adding a server definition pointing to that directory in Gnus. The might interfere with overwriting data, so you may want to shut down Gnus before you restore the data. -It is also possible to archive individual @code{nnml}, -@code{nnfolder}, or @code{nnmaildir} groups, while preserving marks. -For @code{nnml} or @code{nnmaildir}, you copy all files in the group's -directory. For @code{nnfolder} you need to copy both the base folder -file itself (@file{FOO}, say), and the marks file (@file{FOO.mrk} in -this example). Restoring the group is done with @kbd{G m} from the Group -buffer. The last step makes Gnus notice the new directory. -@code{nnmaildir} notices the new directory automatically, so @kbd{G m} -is unnecessary in that case. - @node Web Searches @subsection Web Searches @cindex nnweb @@ -20870,7 +20772,7 @@ then this operator will return @code{false}. @item ! @itemx not -@itemx ¬ +@itemx ¬ This logical operator only takes a single argument. It returns the logical negation of the value of its argument. @@ -22510,7 +22412,7 @@ and so on. Create as many faces as you wish. The same goes for the @samp{hello} mouse-highlighted with @code{gnus-mouse-face-3}. @cindex %<<, %>>, guillemets -@c @cindex %<<, %>>, %«, %», guillemets +@c @cindex %<<, %>>, %«, %», guillemets @vindex gnus-balloon-face-0 Text inside the @samp{%<<} and @samp{%>>} specifiers will get the special @code{balloon-help} property set to @@ -26404,6 +26306,7 @@ renamed it back again to ``Gnus''. But in mixed case. ``Gnus'' vs. @cindex Pterodactyl Gnus @cindex Oort Gnus @cindex No Gnus +@cindex Ma Gnus @cindex Gnus versions The first ``proper'' release of Gnus 5 was done in November 1995 when it @@ -26432,12 +26335,15 @@ On April 19, 2010 Gnus development was moved to Git. See http://git.gnus.org for details (http://www.gnus.org will be updated with the information when possible). +On the January 31th 2012, Ma Gnus was begun. + If you happen upon a version of Gnus that has a prefixed name -- ``(ding) Gnus'', ``September Gnus'', ``Red Gnus'', ``Quassia Gnus'', -``Pterodactyl Gnus'', ``Oort Gnus'', ``No Gnus'' -- don't panic. -Don't let it know that you're frightened. Back away. Slowly. Whatever -you do, don't run. Walk away, calmly, until you're out of its reach. -Find a proper released version of Gnus and snuggle up to that instead. +``Pterodactyl Gnus'', ``Oort Gnus'', ``No Gnus'', ``Ma Gnus'' -- don't +panic. Don't let it know that you're frightened. Back away. Slowly. +Whatever you do, don't run. Walk away, calmly, until you're out of +its reach. Find a proper released version of Gnus and snuggle up to +that instead. @node Why? @@ -27040,7 +26946,8 @@ actually are people who are using Gnus. Who'd'a thunk it! * Quassia Gnus:: Two times two is four, or Gnus 5.6/5.7. * Pterodactyl Gnus:: Pentad also starts with P, AKA Gnus 5.8/5.9. * Oort Gnus:: It's big. It's far out. Gnus 5.10/5.11. -* No Gnus:: Very punny. +* No Gnus:: Very punny. Gnus 5.12/5.13. +* Ma Gnus:: Celebrating 25 years of Gnus. @end menu These lists are, of course, just @emph{short} overviews of the @@ -28415,6 +28322,13 @@ New features in No Gnus: @include gnus-news.texi +@node Ma Gnus +@subsubsection Ma Gnus +@cindex Ma Gnus + +I'm sure there will be lots of text here. It's really spelled 真 +Gnus. + @iftex @page @@ -28918,7 +28832,7 @@ Gnus will work. @item Try doing an @kbd{M-x gnus-version}. If you get something that looks like @c -@samp{No Gnus v0.20} @c Adjust ../Makefile.in if you change this line! +@samp{Ma Gnus v0.4} @c Adjust ../Makefile.in if you change this line! @c you have the right files loaded. Otherwise you have some old @file{.el} files lying around. Delete these. @@ -30637,5 +30551,5 @@ former). The manual is unambiguous, but it can be confusing. @c Local Variables: @c mode: texinfo -@c coding: iso-8859-1 +@c coding: utf-8 @c End: diff --git a/texi/message.texi b/texi/message.texi index bc5efe119..cdffb0407 100644 --- a/texi/message.texi +++ b/texi/message.texi @@ -77,7 +77,7 @@ Message mode buffers. @c Adjust ../Makefile.in if you change the following lines: Message is distributed with Gnus. The Gnus distribution @c -corresponding to this manual is No Gnus v0.20 +corresponding to this manual is Ma Gnus v0.4 @node Interface @@ -1641,6 +1641,40 @@ To the thing similar to this, there is requires the @acronym{POP}-before-@acronym{SMTP} authentication. @xref{POP before SMTP, , POP before SMTP, gnus, The Gnus Manual}. +@cindex X-Message-SMTP-Method +If you have a complex @acronym{SMTP} setup, and want some messages to +go via one mail server, and other messages to go through another, you +can use the @samp{X-Message-SMTP-Method} header. These are the +supported values: + +@table @samp +@item smtpmail + +@example +X-Message-SMTP-Method: smtp smtp.fsf.org 587 +@end example + +This will send the message via @samp{smtp.fsf.org}, using port 587. + +@example +X-Message-SMTP-Method: smtp smtp.fsf.org 587 other-user +@end example + +This is the same as the above, but uses @samp{other-user} as the user +name when authenticating. This is handy if you have several +@acronym{SMTP} accounts on the same server. + +@item sendmail + +@example +X-Message-SMTP-Method: sendmail +@end example + +This will send the message via the locally installed sendmail/exim/etc +installation. + +@end table + @item message-mh-deletable-headers @vindex message-mh-deletable-headers Most versions of MH doesn't like being fed messages that contain the