contrib/on-loginfo
contrib/request-assign.future
etc/Makefile
+.gitattributes
lisp/.gitattributes
lisp/*.elc
lisp/*.rej
lisp/old
lisp/semantic.cache
lisp/version
+texi/.gitattributes
texi/Makefile
texi/auth
texi/emacs-mime
For older news, see Gnus info node "New Features".
\f
-* 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.
-
-\f
-* 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.
-
-\f
-* 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)
-
-
-\f
-* 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
-\f
-* 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.
-
-\f
-* 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).
-
-
-\f
-* 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'.
-
-
-\f
-* 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::.
-
-
-\f
+** 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".
----------------------------------------------------------------------
+2012-03-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-expire-articles-1): Don't try to expire
+ messages that don't exist.
+
+ * gnus-sum.el (gnus-summary-expire-articles): Ditto.
+
2012-03-10 David Edmondson <dme@dme.org>
* mm-uu.el (mm-uu-forward-extract): Allow for blank lines between the
* nntp.el (nntp-send-authinfo): Work for secure nntp entry in authinfo.
+2012-02-20 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-clean-old-newsrc): Allow a FORCE parameter.
+
2012-02-20 Lars Ingebrigtsen <larsi@gnus.org>
* mm-decode.el (mm-shr): Remove "soft hyphens".
* gnus-start.el (gnus-1): Avoid duplicate entries.
+2012-02-16 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * 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 Lars Ingebrigtsen <larsi@gnus.org>
- * 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-15 Paul Eggert <eggert@cs.ucla.edu>
* shr.el (shr-rescale-image): Undo previous change; see
<http://lists.gnu.org/archive/html/emacs-devel/2012-02/msg00540.html>.
+2012-02-15 Lars Magne Ingebrigtsen <lars@ingebrigtsen.no>
+
+ * gnus.el: Ma Gnus v0.3 is released.
+
+2012-02-15 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-local-variables): Make
+ `gnus-newsgroup-unexist' into a local variable.
+
+2012-02-14 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * 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 <yamaoka@jpl.org>
+
+ * 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 <larsi@gnus.org>
+
+ * 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 <larsi@gnus.org>
+
+ * shr.el (shr-remove-trailing-whitespace): Really delete the padding on
+ too-wide lines.
+
2012-02-13 Lars Ingebrigtsen <larsi@gnus.org>
* nnimap.el (nnimap-record-commands): New variable.
* auth-source.el (auth-source-cache-expiry):
Add missing :version tags to new defcustoms and defgroups.
+2012-02-11 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * 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 <larsi@gnus.org>
* message.el (message-default-send-mail-function): Made into own
* 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 <larsi@gnus.org>
+
+ * 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 <larsi@gnus.org>
+
+ * gnus-compat.el: Add a compat for the old `url-retrieve'.
+
+2012-02-07 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-compat.el: Make `help-function-arglist' be compatible on Emacs
+ 23.1.
+
+2012-02-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-show-thread): Revert last two changes.
+
+2012-02-07 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (smtpmail-smtp-user): Silence compiler warning.
+
+2012-02-06 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-multi-smtp-send-mail): Also allow specifying the
+ SMTP user name.
+
+2012-02-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * 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 <larsi@gnus.org>
* gnus-msg.el (gnus-msg-mail): Use `message-mail' if Gnus isn't
lines that are narrower than the window width. Otherwise background
"blocks" will look less readable.
-2012-02-07 Katsumi Yamaoka <yamaoka@jpl.org>
-
- * gnus-sum.el (gnus-summary-show-thread): Revert last two changes.
-
2012-02-07 Lars Ingebrigtsen <larsi@gnus.org>
* nnimap.el (nnimap-transform-headers): Remove unused variable.
* 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 <yamaoka@jpl.org>
-
- * gnus-sum.el (gnus-summary-show-thread):
- next-single-char-property-change may return nil in XEmacs.
-
2012-02-06 Lars Ingebrigtsen <larsi@gnus.org>
* gnus-sum.el (gnus-handle-ephemeral-exit): Allow exiting from Gnus
* gnus-sum.el (gnus-summary-show-thread):
next-single-char-property-change never returns nil (Bug#8657).
+2012-02-02 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * 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 <yamaoka@jpl.org>
+
+ * 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 <larsi@gnus.org>
+
+ * 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 <larsi@gnus.org>
+
+ * 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 <lars@ingebrigtsen.no>
+
+ * gnus.el: Ma Gnus v0.1 is released.
+
2012-02-05 Lars Ingebrigtsen <larsi@gnus.org>
* nnimap.el (nnimap-open-server): Allow switching the nnoo server
2012-01-31 Jim Meyering <jim@meyering.net>
* 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 <lars@ingebrigtsen.no>
+2012-01-31 Lars Ingebrigtsen <larsi@gnus.org>
- * gnus.el: No Gnus v0.19 is released.
+ * gnus.el (gnus-version): Change name to "Ma Gnus".
2012-01-30 Philipp Haselwarter <philipp.haselwarter@gmx.de> (tiny change)
(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)
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
(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"))
(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)))))
(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))))
--- /dev/null
+;;; gnus-compat.el --- Compatability functions for Gnus
+
+;; Copyright (C) 2012 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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
(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)
(expirable (if (gnus-group-total-expirable-p group)
(cons nil (gnus-list-of-read-articles group))
(assq 'expire (gnus-info-marks info))))
+ (articles-to-expire
+ (gnus-list-range-difference
+ (gnus-uncompress-sequence (cdr expirable))
+ (cdr (assq 'unexist (gnus-info-marks info)))))
(expiry-wait (gnus-group-find-parameter group 'expiry-wait))
(nnmail-expiry-target
(or (gnus-group-find-parameter group 'expiry-target)
;; parameter.
(let ((nnmail-expiry-wait-function nil)
(nnmail-expiry-wait expiry-wait))
- (gnus-request-expire-articles
- (gnus-uncompress-sequence (cdr expirable)) group))
+ (gnus-request-expire-articles articles-to-expire group))
;; Just expire using the normal expiry values.
- (gnus-request-expire-articles
- (gnus-uncompress-sequence (cdr expirable)) group))))
+ (gnus-request-expire-articles articles-to-expire group))))
(gnus-close-group group))
(gnus-message 6 "Expiring articles in %s...done"
(gnus-group-decoded-name group))
(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
(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
(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 <Matthieu.Moy@imag.fr>
(defun gnus-summary-resend-message-edit ()
(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)))))))))
(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)
(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)
(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 <tzz@lifelogs.com>"
- "noname <ed@you.me>"
- "noname <cyd@stupidchicken.com>"
- "noname <tzz@lifelogs.com>")
- (gnus-registry-extract-addresses
- (concat "Ted Zlatanov <tzz@lifelogs.com>, "
- "ed <ed@you.me>, " ; "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."
;; 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.
(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))
(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 (&optional force)
+ (when gnus-newsrc-file-version
+ (when (or force
+ (< (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."
: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)
(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.")
gnus-newsgroup-killed
gnus-newsgroup-unseen
gnus-newsgroup-seen
+ gnus-newsgroup-unexist
gnus-newsgroup-cached
gnus-newsgroup-downloadable
gnus-newsgroup-undownloaded
"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
"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
(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")
"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
(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))
(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
(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."
(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
(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."
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)))))
'request-expire-articles gnus-newsgroup-name))
;; This backend supports expiry.
(let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name))
- (expirable (if total
- (progn
- ;; We need to update the info for
- ;; this group for `gnus-list-of-read-articles'
- ;; to give us the right answer.
- (gnus-run-hooks 'gnus-exit-group-hook)
- (gnus-summary-update-info)
- (gnus-list-of-read-articles gnus-newsgroup-name))
- (setq gnus-newsgroup-expirable
- (sort gnus-newsgroup-expirable '<))))
+ (expirable
+ (gnus-list-range-difference
+ (if total
+ (progn
+ ;; We need to update the info for
+ ;; this group for `gnus-list-of-read-articles'
+ ;; to give us the right answer.
+ (gnus-run-hooks 'gnus-exit-group-hook)
+ (gnus-summary-update-info)
+ (gnus-list-of-read-articles gnus-newsgroup-name))
+ (setq gnus-newsgroup-expirable
+ (sort gnus-newsgroup-expirable '<)))
+ gnus-newsgroup-unexist))
(expiry-wait (if now 'immediate
(gnus-group-find-parameter
gnus-newsgroup-name 'expiry-wait)))
(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))))
(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)
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))
(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)
: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
(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))
(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)
;; `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
+++ /dev/null
-;;; imap.el --- imap library
-
-;; Copyright (C) 1998-2012 Free Software Foundation, Inc.
-
-;; Author: Simon Josefsson <simon@josefsson.org>
-;; Keywords: mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; 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: <jas@pdc.kth.se>^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 <ueno@ueda.info.waseda.ac.jp>
-;; 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.")
-
-\f
-;; 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))))
-
-\f
-;; 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)))
-
-\f
-;; 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 <identifier,rights> 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))))))
-
-\f
-;; 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) ">"))))
-
-\f
-;; 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)))))))))
-
-\f
-;; 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 = <any TEXT-CHAR except quoted-specials> /
-;; "\" quoted-specials
-;;
-;; quoted-specials = DQUOTE / "\"
-;;
-;; TEXT-CHAR = <any CHAR except CR and LF>
-
-(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 = <any CHAR except atom-specials>
-;;
-;; 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 = <any CHAR except CR and LF>
-
-(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*<any TEXT-CHAR except "]">]
-;;
-;; 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*<any ATOM-CHAR except "]">
-
-(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 = <any TEXT-CHAR except quoted-specials> /
-;; "\" 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
(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
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
(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
(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)))
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)
(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)))
")))
(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))
(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."
(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*"))
;; 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-*".
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)))
--- /dev/null
+;;; mm-archive.el --- Functions for parsing archive files as MIME
+
+;; Copyright (C) 2012 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(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
(require 'mail-parse)
(require 'mm-bodies)
+(require 'mm-archive)
(eval-when-compile (require 'cl)
(require 'term))
("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))
"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.
(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))
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))
(while (search-forward "" nil t)
(replace-match "" t t))
(libxml-parse-html-region (point-min) (point-max))))
+ (unless (bobp)
+ (insert "\n"))
(mm-handle-set-undisplayer
handle
`(lambda ()
(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\\)\\'"
;; Copyright (C) 1995-2012 Free Software Foundation, Inc.
-;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS)
+;; Author: Simon Josefsson <simon@josefsson.org>
;; ShengHuo Zhu <zsh@cs.rochester.edu> (adding NOV)
;; Scott Byer <byer@mv.us.adobe.com>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
"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.")
(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))
-
\f
;;; Interface functions
(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)
() ; 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)
(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)))
(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
(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)
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)
;; 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))
(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.
(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)
(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))
;; Foundation, Inc.
;; Authors: Didier Verna <didier@xemacs.org> (adding compaction)
-;; Simon Josefsson <simon@josefsson.org> (adding MARKS)
+;; Simon Josefsson <simon@josefsson.org>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
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.")
"nnml version.")
(defvoo nnml-nov-file-name ".overview")
-(defvoo nnml-marks-file-name ".marks")
(defvoo nnml-current-directory nil)
(defvoo nnml-current-group nil)
(defvoo nnml-file-coding-system nnmail-file-coding-system)
-(defvoo nnml-marks nil)
-
-(defvar nnml-marks-modtime (gnus-make-hashtable))
-
\f
;;; Interface functions.
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)
(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.
(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
;;;
(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
(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)
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
(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.
(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)
(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
(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)
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
(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)
(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)
(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)))
(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))))
(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)
--- /dev/null
+;;; gnustest-registry.el --- Registry and Gnus registry testing for Gnus
+;; Copyright (C) 2011-2012 Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+
+;; 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 <tzz@lifelogs.com>"
+ "noname <ed@you.me>"
+ "noname <cyd@stupidchicken.com>"
+ "noname <tzz@lifelogs.com>")
+ (gnus-registry-extract-addresses
+ (concat "Ted Zlatanov <tzz@lifelogs.com>, "
+ "ed <ed@you.me>, " ; "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)
#!/bin/bash
-name="No Gnus"
+name="Ma Gnus"
if [ `whoami` != "larsi" ]; then
echo "This script is for larsi only"
* gnus.texi (Posting Styles): Fix cross-refs to other manual.
+2012-02-16 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Various Summary Stuff): Remove mention of
+ `gnus-propagate-marks'.
+
+2012-02-15 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi: Remove mentions of nnml/nnfolder/nntp backend marks, which
+ no longer exist.
+
2012-02-13 Lars Ingebrigtsen <larsi@gnus.org>
* gnus.texi (Customizing the IMAP Connection): Mention
nnimap-record-commands.
+2012-02-08 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus.texi (Archived Messages): Document gnus-gcc-self-resent-messages.
+
2012-02-07 Lars Ingebrigtsen <larsi@gnus.org>
* 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 <larsi@gnus.org>
+
+ * message.texi (Mail Variables): Mention the optional user parameter
+ for X-Message-SMTP-Method.
+
+2012-02-02 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Posting Styles): Mention X-Message-SMTP-Method.
+
+ * message.texi (Mail Variables): Document X-Message-SMTP-Method.
+
+2012-01-31 Lars Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Key Index): Change encoding to utf-8.
+
2012-01-30 Philipp Haselwarter <philipp.haselwarter@gmx.de> (tiny change)
* gnus.texi (Agent Basics): Fix outdated description of
@syncodeindex vr cp
@syncodeindex pg cp
-@documentencoding ISO-8859-1
+@documentencoding UTF-8
@copying
Copyright @copyright{} 1995-2012 Free Software Foundation, Inc.
\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}{}
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
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
* 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
* 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
(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
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
@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
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
@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{Ã\82»} is translated into @samp{>>}, and so on.
@item W Y f
@kindex W Y f (Summary)
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
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
(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
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
* 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
@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
@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
@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
@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
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
@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
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
@item !
@itemx not
-@itemx ¬
+@itemx Ã\82¬
This logical operator only takes a single argument. It returns the
logical negation of the value of its argument.
@samp{hello} mouse-highlighted with @code{gnus-mouse-face-3}.
@cindex %<<, %>>, guillemets
-@c @cindex %<<, %>>, %«, %», guillemets
+@c @cindex %<<, %>>, %Ã\82«, %Ã\82», guillemets
@vindex gnus-balloon-face-0
Text inside the @samp{%<<} and @samp{%>>} specifiers will get the
special @code{balloon-help} property set to
@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
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?
* 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
@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
@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.
@c Local Variables:
@c mode: texinfo
-@c coding: iso-8859-1
+@c coding: utf-8
@c End:
@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
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
projects / gnus / commitdiff