diff options
Diffstat (limited to 'lisp/gnus')
38 files changed, 2476 insertions, 1261 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 9c406f75bf3..649b5a74fb8 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,29 +1,534 @@ -2012-06-10 Toke Høiland-Jørgensen <toke@toke.dk> (tiny change) +2012-06-29 Katsumi Yamaoka <yamaoka@jpl.org> + + * tests/gnustest-nntp.el, tests/gnustest-registry.el, tests/: Remove. + +2012-06-27 Stefan Monnier <monnier@iro.umontreal.ca> + + * shr.el (shr-render-buffer): New command. + (shr-visit-file): Use it. + +2012-06-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * tests/gnustest-nntp.el, tests/gnustest-registry.el: + Set no-byte-compile and no-update-autoloads. + +2012-06-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-decode.el: Add coding cookie for a soft hyphen that mm-shr uses. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-article-read-summary-keys): Protect against the key + being bound to a lambda form. + +2012-06-26 Wolfgang Jenkner <wjenkner@inode.at> + + * gnus-picon.el (gnus-picon-properties): New defcustom. + (gnus-picon-create-glyph): Use it. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el: Add a iso-8859-1 cookie to make stuff work under other + locales. + + * mm-decode.el (mm-display-part): Dissect archives when hitting `RET' + on a handle. + + * gnus-sum.el (gnus-summary-limit-to-author): Use the current From + address as the default. + + * nnfolder.el (nnfolder-save-buffer): Delete old versions silently. + It makes no sense to query the user about internal files. + + * gnus-spec.el: Remove all the byte-compilation stuff, since + benchmarking shows that it doesn't help when entering large summary + buffers. + + * gnus-util.el (gnus-byte-code): Remove. + + * gnus-spec.el (gnus-update-format-specifications): Remove outdated + grouplens stuff. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-msg-mail): Warn the user about Gnus not running + (bug#11514). + +2012-06-26 Stephen Eglen <S.J.Eglen@damtp.cam.ac.uk> + + * message.el (message-buffers): Return all buffers derived from Message + to make `gnus-dired-attach' work with mu4e. + +2012-06-26 Daiki Ueno <ueno@unixuser.org> + + * mm-decode.el (mm-inhibit-auto-detect-attachment): New variable. + (mm-dissect-singlepart): Don't guess the MIME type of + application/octet-stream parts if mm-inhibit-auto-detect-attachment is + set. + (mm-dissect-multipart): Bind mm-inhibit-auto-detect-attachment if the + toplevel MIME type is multipart/encrypted. + +2012-06-26 Wolfgang Jenkner <wjenkner@inode.at> + + * gnus-agent.el (gnus-agent-save-active): Deal with the "groups" format. + In particular, add an optional argument and a docstring. + + * gnus-start.el (gnus-groups-to-gnus-format): Use it. + + * nntp.el (nntp-finish-retrieve-group-infos): Make `nntp-server-buffer' + current before calling `gnus-groups-to-gnus-format'. + Note that this was already the case for `gnus-active-to-gnus-format'. + +2012-06-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * pop3.el (pop3-wait-for-messages): Fix retrieved data size calculation. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mm-decode.el (mm-dissect-buffer): Doc fix. + + * gnus-sum.el (gnus-handle-ephemeral-exit): + Avoid creating the group buffer if it doesn't exist. + + * gnus-group.el (gnus-group-read-ephemeral-group): If no quit-config + is given, mark the group as ephemeral with the current window conf. + + * gnus-sum.el (gnus-set-global-variables): Don't assume that the group + buffer exists, which it doesn't if we haven't started Gnus. + (gnus-summary-exit): Allow quitting when we don't have a group buffer. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mml.el (mml-generate-mime): + Allow specifying what the top-level part type is. + + * gnus-sum.el (gnus-auto-center-summary): + `scroll-margin' isn't defined on XEmacs. + +2012-06-26 Philipp Haselwarter <philipp.haselwarter@gmx.de> (tiny change) + + * gnus-sum.el (gnus-auto-center-summary): + Set default to respect `scroll-margin'. + +2012-06-26 Elias Oltmanns <eo@nebensachen.de> (tiny change) + + * gnus-cite.el (gnus-dissect-cited-text): A single line without + citation prefix within a block of cited text should be considered + part of that block *only* if it is a blank line. + +2012-06-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * shr.el (shr-find-fill-point): Remove unused code; don't break a line + before kinsoku-bol characters nor within kinsoku-eol characters. + +2012-06-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sync.el (gnus-topic-alist, gnus-group-topic) + (gnus-topic-create-topic, gnus-topic-enter-dribble): + Silence compiler. + (gnus-sync-read): Use mapc instead of mapcar. + + * mm-archive.el: Require mm-decode for some macros. + (gnus-recursive-directory-files, mailcap-extension-to-mime): + Silence the byte compiler. + (mm-archive-decoders): New function that returns the value of + the mm-archive-decoders variable. + + * mm-decode.el: + Don't require mm-archive; autoload mm-archive functions instead. + (mm-dissect-singlepart): Use the function mm-archive-decoders. + + * nnmail.el (mail-send-and-exit): Silence the byte compiler. + +2012-06-26 Peter Munster <pmrb@free.fr> + + * gnus-demon.el (gnus-demon-timers): Now a plist (function -> timer). + (gnus-demon-cancel): Ditto. + (gnus-demon-run-callback): When function cannot be called due to low + idleness, call it when idleness reaches the expected value, instead + of waiting another timer period. + (gnus-demon-init): Add `time' to arguments of call-back. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el: Register gnus-registry functions. + + * gnus-registry.el (gnus-try-warping-via-registry): + Moved here and indent. + + * gnus-int.el (gnus-warp-to-article): + Check whether the registry is enabled before warping. + +2012-06-26 Dave Abrahams <dave@boostpro.com> + + * gnus-sum.el (gnus-summary-insert-subject): Record information + in the registry about each article retrieved. + + * gnus-int.el (gnus-select-group-with-message-id): New function. + (gnus-try-warping-via-registry): Ditto. + (gnus-warp-to-article): Fall back on the registry. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-fetch-partial-articles): Minor doc string fixup. + +2012-06-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-msg.el (gnus-summary-resend-message-insert-gcc): Assume that + gnus-gcc-self-resent-messages may be a group parameter. + (gnus-summary-resend-message): + Don't encode encoded words in header when Gcc'ing resent message. + +2012-06-26 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-insert): Treat non-breaking space just like normal + space. This seems to produce more pleasing results. + (shr-insert): + Only insert a blank line if we're starting from an image. + (shr-tag-br): + Allow <br> to end lines or to make a single blank line. + (shr-ensure-paragraph): Consider lines with white space to be blank. + +2012-06-26 Christopher Schmidt <christopher@ch.ristopher.com> + + * gnus-msg.el (gnus-inews-do-gcc): Add gnus-gcc-pre-body-encode-hook + and gnus-gcc-post-body-encode-hook. + +2012-06-26 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-06-26 Lars Ingebrigtsen <larsi@gnus.org> + + * nntp.el (nntp-coding-system-for-read): Remove. + (nntp-coding-system-for-write): Ditto. + (nntp-open-connection): Just use `binary' directly. + +2012-06-26 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-06-26 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-06-26 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-06-26 Lars Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-remove-trailing-whitespace): + Really delete the padding on too-wide lines. + +2012-06-26 Lars Ingebrigtsen <larsi@gnus.org> + + * mm-archive.el (mm-archive-dissect-and-inline): New function. + (mm-archive-dissect-and-inline): Fix up the undisplayer. + + * 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-06-26 Lars Ingebrigtsen <larsi@gnus.org> + + * message.el (smtpmail-smtp-user): Silence compiler warning. + +2012-06-26 Lars Ingebrigtsen <larsi@gnus.org> + + * message.el (message-multi-smtp-send-mail): Also allow specifying + the SMTP user name. + +2012-06-26 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-article-map): Fix typo. + +2012-06-26 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. + + * shr.el (shr-put-image): Remove underlines from sliced images. + (shr-zoom-image): Compute the region to be replaced more correctly. + +2012-06-26 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-06-26 Lars Ingebrigtsen <larsi@gnus.org> + + * 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. + + * 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-06-26 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-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el (gnus-sync-newsrc-groups): Quote normally. + (gnus-sync-lesync-pre-save-group-entry): Remove invalid invlists. + (gnus-sync-lesync-normalize-group-entry): Ignore a few more keys. + +2012-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * spam.el: Move BBDB autoloads. + (spam-exists-in-BBDB-p): + New function to do the BBDB search directly in BBDB 2 and 3. + (spam-check-BBDB): Use it. + (spam-enter-ham-BBDB): Use it. + +2012-06-26 Peter Munster <pmrb@free.fr> (tiny change) + + * gnus-group.el (gnus-group-get-new-news): + New parameter `one-level' for scanning exactly one level. + + * gnus-start.el (gnus-get-unread-articles): Ditto. + +2012-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el: More commentary about setup. + +2012-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el: More commentary about `gnus-sync-read' issues. + +2012-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el: Improve docs about CouchDB admins. + +2012-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el (gnus-sync-lesync-setup): Fix salt when user setup is + not needed. Provide xmlplistread list function to produce XML plist + output for non-Gnus LeSync clients. + +2012-06-26 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-sync.el: Add LeSync synchronization backend and logic to read + and save against it. Group subscriptions, read marks, other marks, + subscription levels, topic names, and topic offsets (the group's + position within the topic) are saved. This is an experimental + backend and may change significantly. Load json.el from + the gnus-fallback-lib if it's not available otherwise. + (gnus-sync-save): Don't use `apply-partially' because of XEmacs. + +2012-06-26 David Engster <dengste@eml.cc> + + * tests/gnustest-nntp.el: New file for simple NNTP testing. + +2012-06-18 Nelson Ferreira <nelson.ferreira@ieee.org> (tiny change) + + * gnus-win.el (gnus-configure-frame): Pass an arg to window-dedicated-p. + +2012-06-17 Toke Høiland-Jørgensen <toke@toke.dk> (tiny change) * nnmaildir.el (nnmaildir-request-expire-articles): Ensure that `time' is an integer to avoid later problems. -2012-06-10 Lars Magne Ingebrigtsen <larsi@gnus.org> +2012-06-17 Lars Magne Ingebrigtsen <larsi@gnus.org> * shr.el: Add a iso-8859-1 cookie to make stuff work under other locales. -2012-05-21 Katsumi Yamaoka <yamaoka@jpl.org> +2012-04-14 Wolfgang Jenkner <wjenkner@inode.at> + + * gnus-agent.el (gnus-agent-retrieve-headers): Recalculate the range of + articles when fetch-old is non-nil (bug#11370). + +2012-06-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-get-new-news): Respect + `gnus-group-use-permanent-levels', as documented (bug#11638). + +2012-06-10 Dave Abrahams <dave@boostpro.com> + + * gnus-int.el (gnus-warp-to-article): Limit registry warping to real + groups (bug#11641). + +2012-06-07 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-msg-mail): Warn the user about Gnus not running + (bug#11514). + +2012-06-01 Stefan Monnier <monnier@iro.umontreal.ca> + + * nntp.el: Stop the `letf' madness. + (nntp--report-1): New var. + (nntp-report): Merge nntp-report-1 into it. + (nntp-with-open-group-function): Set nntp--report-1 instead of modifying + the nntp-report function. + + * auth-source.el: Fix comment-style to follow the convention. + +2012-05-27 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-msg.el (gnus-msg-mail): Ensure that gnus-newsgroup-name is a string so that Gcc works (bug#11514). -2012-04-21 Andreas Schwab <schwab@linux-m68k.org> +2012-05-26 Stefan Monnier <monnier@iro.umontreal.ca> + + * legacy-gnus-agent.el (gnus-agent-unhook-expire-days): + * gnus-demon.el (gnus-demon-init): Don't bother with type-of. + +2012-05-25 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-win.el (gnus-configure-frame): Don't signal an error when + jumping to *Server* from a dedicated *Group* window. + (gnus-configure-frame): CSE. + + * gnus-registry.el: Minor style cleanup. + (gnus-registry--set/remove-mark): New function, extracted from + gnus-registry-install-shortcuts. + (gnus-registry-install-shortcuts): Use it. + +2012-05-25 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnspool.el (news-path): Use eval-and-compile. + +2012-05-24 Glenn Morris <rgm@gnu.org> + + * nnspool.el (news-directory, news-path, news-inews-program): + Move here from paths.el. Don't see a need for these to be autoloaded. + + * gnus.el (gnus-default-nntp-server): Make it a defcustom. + Merge in doc from paths.el version. Don't see any need for this to be + autoloaded, or for the warning about users not setting it. + +2012-05-04 Paul Eggert <eggert@cs.ucla.edu> + + Fix minor Y10k bug. + * nnweb.el (nnweb-google-parse-1): Don't assume years have 4 digits. + +2012-05-01 Stefan Monnier <monnier@iro.umontreal.ca> + + * nnimap.el (nnimap-open-connection-1): Don't leave an "opening..." + message once it's actually open. + +2012-04-28 Stefan Monnier <monnier@iro.umontreal.ca> + + * auth-source.el (auth-source--aput-1, auth-source--aput) + (auth-source--aget): New functions and macros. + Use them instead of aput/aget. + +2012-04-27 Andreas Schwab <schwab@linux-m68k.org> * gnus.el (debbugs-gnu): Don't override existing autoload definition. -2012-04-12 Lars Magne Ingebrigtsen <larsi@gnus.org> +2012-04-26 Daiki Ueno <ueno@unixuser.org> + + * plstore.el (plstore-called-interactively-p): New compat macro copied + from message.el. + (plstore-mode): Use it. + +2012-04-26 Daiki Ueno <ueno@unixuser.org> + + * plstore.el: Revive the editing feature. + (plstore-mode): New mode to edit plstore file. + (plstore-mode-toggle-display, plstore-mode-original) + (plstore-mode-decoded): New command. + (plstore--encode, plstore--decode, plstore--write-contents-functions) + (plstore--insert-buffer, plstore--make): New function. + (plstore-open, plstore-save): Simplify by using them. + +2012-04-16 Glenn Morris <rgm@gnu.org> + + * nndraft.el (nndraft-request-list): Fix declaration. + +2012-04-14 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus-msg.el (gnus-inews-insert-gcc): Don't do the alist stuff when we don't have a current group. -2012-04-10 Lars Magne Ingebrigtsen <larsi@gnus.org> - * gnus-msg.el (gnus-inews-insert-gcc): Protect against when we don't have a group name. @@ -35,6 +540,12 @@ * gnus-start.el (gnus-read-newsrc-el-file): Protect against broken .newsrc.el files. +2012-04-10 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-msg.el (gnus-summary-cancel-article): See what From header we + would have gotten if we posted to the group, and use that to compare + against the message we want to cancel (bug#10808). + 2012-03-22 Lars Magne Ingebrigtsen <larsi@gnus.org> * auth-source.el (auth-source-netrc-create): Quote tokens that contain @@ -22636,7 +23147,7 @@ See ChangeLog.2 for earlier changes. - Copyright (C) 2004-2012 Free Software Foundation, Inc. + Copyright (C) 2004-2012 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1 index f3ba7bca4d4..f223bd77085 100644 --- a/lisp/gnus/ChangeLog.1 +++ b/lisp/gnus/ChangeLog.1 @@ -2966,7 +2966,7 @@ 1997-11-25 Lars Magne Ingebrigtsen <larsi@ifi.uio.no> - * gnus-move.el (gnus-move-group-to-server): Protect agains + * gnus-move.el (gnus-move-group-to-server): Protect against nil-ness. 1997-11-25 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no> diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index 34fe5afe7af..47359500dc4 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -42,7 +42,6 @@ (require 'password-cache) (require 'mm-util) (require 'gnus-util) -(require 'assoc) (eval-when-compile (require 'cl)) (require 'eieio) @@ -92,9 +91,9 @@ let-binding." (const :tag "30 Minutes" 1800) (integer :tag "Seconds"))) -;;; The slots below correspond with the `auth-source-search' spec, -;;; so a backend with :host set, for instance, would match only -;;; searches for that host. Normally they are nil. +;; The slots below correspond with the `auth-source-search' spec, +;; so a backend with :host set, for instance, would match only +;; searches for that host. Normally they are nil. (defclass auth-source-backend () ((type :initarg :type :initform 'netrc @@ -149,8 +148,8 @@ let-binding." (repeat :tag "Names" (string :tag "Name"))))) -;;; generate all the protocols in a format Customize can use -;;; TODO: generate on the fly from auth-source-protocols +;; Generate all the protocols in a format Customize can use. +;; TODO: generate on the fly from auth-source-protocols (defconst auth-source-protocols-customize (mapcar (lambda (a) (let ((p (car-safe a))) @@ -339,7 +338,7 @@ If the value is not a list, symmetric encryption will be used." msg)) -;;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q)) +;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q)) (defun auth-source-read-char-choice (prompt choices) "Read one of CHOICES by `read-char-choice', or `read-char'. `dropdown-list' support is disabled because it doesn't work reliably. @@ -711,10 +710,10 @@ must call it to obtain the actual value." (setq matches (append matches bmatches)))))) matches)) -;;; (auth-source-search :max 1) -;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret)) -;;; (auth-source-search :host "nonesuch" :type 'netrc :K 1) -;;; (auth-source-search :host "nonesuch" :type 'secrets) +;; (auth-source-search :max 1) +;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret)) +;; (auth-source-search :host "nonesuch" :type 'netrc :K 1) +;; (auth-source-search :host "nonesuch" :type 'secrets) (defun* auth-source-delete (&rest spec &key delete @@ -776,16 +775,16 @@ This is the same SPEC you passed to `auth-source-search'. Returns t or nil for forgotten or not found." (password-cache-remove (auth-source-format-cache-entry spec))) -;;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym)) +;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym)) -;;; (auth-source-remember '(:host "wedd") '(4 5 6)) -;;; (auth-source-remembered-p '(:host "wedd")) -;;; (auth-source-remember '(:host "xedd") '(1 2 3)) -;;; (auth-source-remembered-p '(:host "xedd")) -;;; (auth-source-remembered-p '(:host "zedd")) -;;; (auth-source-recall '(:host "xedd")) -;;; (auth-source-recall '(:host t)) -;;; (auth-source-forget+ :host t) +;; (auth-source-remember '(:host "wedd") '(4 5 6)) +;; (auth-source-remembered-p '(:host "wedd")) +;; (auth-source-remember '(:host "xedd") '(1 2 3)) +;; (auth-source-remembered-p '(:host "xedd")) +;; (auth-source-remembered-p '(:host "zedd")) +;; (auth-source-recall '(:host "xedd")) +;; (auth-source-recall '(:host t)) +;; (auth-source-forget+ :host t) (defun* auth-source-forget+ (&rest spec &allow-other-keys) "Forget any cached data matching SPEC. Returns forgotten count. @@ -819,8 +818,8 @@ while \(:host t) would find all host entries." (return 'no))) 'no)))) -;;; (auth-source-pick-first-password :host "z.lifelogs.com") -;;; (auth-source-pick-first-password :port "imap") +;; (auth-source-pick-first-password :host "z.lifelogs.com") +;; (auth-source-pick-first-password :port "imap") (defun auth-source-pick-first-password (&rest spec) "Pick the first secret found from applying SPEC to `auth-source-search'." (let* ((result (nth 0 (apply 'auth-source-search (plist-put spec :max 1)))) @@ -853,7 +852,22 @@ while \(:host t) would find all host entries." ;;; Backend specific parsing: netrc/authinfo backend -;;; (auth-source-netrc-parse "~/.authinfo.gpg") +(defun auth-source--aput-1 (alist key val) + (let ((seen ()) + (rest alist)) + (while (and (consp rest) (not (equal key (caar rest)))) + (push (pop rest) seen)) + (cons (cons key val) + (if (null rest) alist + (nconc (nreverse seen) + (if (equal key (caar rest)) (cdr rest) rest)))))) +(defmacro auth-source--aput (var key val) + `(setq ,var (auth-source--aput-1 ,var ,key ,val))) + +(defun auth-source--aget (alist key) + (cdr (assoc key alist))) + +;; (auth-source-netrc-parse "~/.authinfo.gpg") (defun* auth-source-netrc-parse (&rest spec &key file max host user port delete require @@ -888,10 +902,11 @@ Note that the MAX parameter is used so we can exit the parse early." ;; cache all netrc files (used to be just .gpg files) ;; Store the contents of the file heavily encrypted in memory. ;; (note for the irony-impaired: they are just obfuscated) - (aput 'auth-source-netrc-cache file - (list :mtime (nth 5 (file-attributes file)) - :secret (lexical-let ((v (mapcar '1+ (buffer-string)))) - (lambda () (apply 'string (mapcar '1- v))))))) + (auth-source--aput + auth-source-netrc-cache file + (list :mtime (nth 5 (file-attributes file)) + :secret (lexical-let ((v (mapcar '1+ (buffer-string)))) + (lambda () (apply 'string (mapcar '1- v))))))) (goto-char (point-min)) ;; Go through the file, line by line. (while (and (not (eobp)) @@ -937,21 +952,21 @@ Note that the MAX parameter is used so we can exit the parse early." (auth-source-search-collection host (or - (aget alist "machine") - (aget alist "host") + (auth-source--aget alist "machine") + (auth-source--aget alist "host") t)) (auth-source-search-collection user (or - (aget alist "login") - (aget alist "account") - (aget alist "user") + (auth-source--aget alist "login") + (auth-source--aget alist "account") + (auth-source--aget alist "user") t)) (auth-source-search-collection port (or - (aget alist "port") - (aget alist "protocol") + (auth-source--aget alist "port") + (auth-source--aget alist "protocol") t)) (or ;; the required list of keys is nil, or @@ -1086,8 +1101,8 @@ FILE is the file from which we obtained this token." ret)) alist)) -;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret)) -;;; (funcall secret) +;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret)) +;; (funcall secret) (defun* auth-source-netrc-search (&rest spec @@ -1133,8 +1148,8 @@ See `auth-source-search' for details on SPEC." (nth 0 v) v)) -;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) -;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B))) +;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) +;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B))) (defun* auth-source-netrc-create (&rest spec &key backend @@ -1166,7 +1181,7 @@ See `auth-source-search' for details on SPEC." ;; just the value otherwise (t (symbol-value br))))) (when br-choice - (aput 'valist br br-choice))))) + (auth-source--aput valist br br-choice))))) ;; for extra required elements, see if the spec includes a value for them (dolist (er create-extra) @@ -1175,17 +1190,18 @@ See `auth-source-search' for details on SPEC." collect (nth i spec)))) (dolist (k keys) (when (equal (symbol-name k) name) - (aput 'valist er (plist-get spec k)))))) + (auth-source--aput valist er (plist-get spec k)))))) ;; for each required element (dolist (r required) - (let* ((data (aget valist r)) + (let* ((data (auth-source--aget valist r)) ;; take the first element if the data is a list (data (or (auth-source-netrc-element-or-first data) (plist-get current-data (intern (format ":%s" r) obarray)))) ;; this is the default to be offered - (given-default (aget auth-source-creation-defaults r)) + (given-default (auth-source--aget + auth-source-creation-defaults r)) ;; the default supplementals are simple: ;; for the user, try `given-default' and then (user-login-name); ;; otherwise take `given-default' @@ -1197,22 +1213,22 @@ See `auth-source-search' for details on SPEC." (cons 'user (or (auth-source-netrc-element-or-first - (aget valist 'user)) + (auth-source--aget valist 'user)) (plist-get artificial :user) "[any user]")) (cons 'host (or (auth-source-netrc-element-or-first - (aget valist 'host)) + (auth-source--aget valist 'host)) (plist-get artificial :host) "[any host]")) (cons 'port (or (auth-source-netrc-element-or-first - (aget valist 'port)) + (auth-source--aget valist 'port)) (plist-get artificial :port) "[any port]")))) - (prompt (or (aget auth-source-creation-prompts r) + (prompt (or (auth-source--aget auth-source-creation-prompts r) (case r (secret "%p password for %u@%h: ") (user "%p user name for %h: ") @@ -1221,9 +1237,9 @@ See `auth-source-search' for details on SPEC." (format "Enter %s (%%u@%%h:%%p): " r))) (prompt (auth-source-format-prompt prompt - `((?u ,(aget printable-defaults 'user)) - (?h ,(aget printable-defaults 'host)) - (?p ,(aget printable-defaults 'port)))))) + `((?u ,(auth-source--aget printable-defaults 'user)) + (?h ,(auth-source--aget printable-defaults 'host)) + (?p ,(auth-source--aget printable-defaults 'port)))))) ;; Store the data, prompting for the password if needed. (setq data (or data @@ -1384,16 +1400,16 @@ Respects `auth-source-save-behavior'. Uses file) (message "Saved new authentication information to %s" file) nil)))) - (aput 'auth-source-netrc-cache key "ran")))) + (auth-source--aput auth-source-netrc-cache key "ran")))) ;;; Backend specific parsing: Secrets API backend -;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t)) -;;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t)) -;;; (let ((auth-sources '(default))) (auth-source-search :max 1)) -;;; (let ((auth-sources '(default))) (auth-source-search)) -;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1)) -;;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git")) +;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t)) +;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t)) +;; (let ((auth-sources '(default))) (auth-source-search :max 1)) +;; (let ((auth-sources '(default))) (auth-source-search)) +;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1)) +;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git")) (defun* auth-source-secrets-search (&rest spec @@ -1609,7 +1625,7 @@ authentication tokens: ;; just the value otherwise (t (symbol-value br))))) (when br-choice - (aput 'valist br br-choice))))) + (auth-source--aput valist br br-choice))))) ;; for extra required elements, see if the spec includes a value for them (dolist (er create-extra) @@ -1618,17 +1634,18 @@ authentication tokens: collect (nth i spec)))) (dolist (k keys) (when (equal (symbol-name k) name) - (aput 'valist er (plist-get spec k)))))) + (auth-source--aput valist er (plist-get spec k)))))) ;; for each required element (dolist (r required) - (let* ((data (aget valist r)) + (let* ((data (auth-source--aget valist r)) ;; take the first element if the data is a list (data (or (auth-source-netrc-element-or-first data) (plist-get current-data (intern (format ":%s" r) obarray)))) ;; this is the default to be offered - (given-default (aget auth-source-creation-defaults r)) + (given-default (auth-source--aget + auth-source-creation-defaults r)) ;; the default supplementals are simple: ;; for the user, try `given-default' and then (user-login-name); ;; otherwise take `given-default' @@ -1640,22 +1657,22 @@ authentication tokens: (cons 'user (or (auth-source-netrc-element-or-first - (aget valist 'user)) + (auth-source--aget valist 'user)) (plist-get artificial :user) "[any user]")) (cons 'host (or (auth-source-netrc-element-or-first - (aget valist 'host)) + (auth-source--aget valist 'host)) (plist-get artificial :host) "[any host]")) (cons 'port (or (auth-source-netrc-element-or-first - (aget valist 'port)) + (auth-source--aget valist 'port)) (plist-get artificial :port) "[any port]")))) - (prompt (or (aget auth-source-creation-prompts r) + (prompt (or (auth-source--aget auth-source-creation-prompts r) (case r (secret "%p password for %u@%h: ") (user "%p user name for %h: ") @@ -1664,20 +1681,21 @@ authentication tokens: (format "Enter %s (%%u@%%h:%%p): " r))) (prompt (auth-source-format-prompt prompt - `((?u ,(aget printable-defaults 'user)) - (?h ,(aget printable-defaults 'host)) - (?p ,(aget printable-defaults 'port)))))) + `((?u ,(auth-source--aget printable-defaults 'user)) + (?h ,(auth-source--aget printable-defaults 'host)) + (?p ,(auth-source--aget printable-defaults 'port)))))) ;; Store the data, prompting for the password if needed. (setq data (or data (if (eq r 'secret) (or (eval default) (read-passwd prompt)) (if (stringp default) - (read-string (if (string-match ": *\\'" prompt) - (concat (substring prompt 0 (match-beginning 0)) - " (default " default "): ") - (concat prompt "(default " default ") ")) - nil nil default) + (read-string + (if (string-match ": *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " (default " default "): ") + (concat prompt "(default " default ") ")) + nil nil default) (eval default))))) (when data @@ -1701,7 +1719,7 @@ authentication tokens: ;;; older API -;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") +;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") ;; deprecate the old interface (make-obsolete 'auth-source-user-or-password diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index bbd3c95265d..525008c351f 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -242,7 +242,6 @@ NOTES: (defvar gnus-category-group-cache nil) (defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-file-name nil) -(defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-total-fetched-hashtb nil) @@ -683,11 +682,7 @@ This will modify the `gnus-setup-news-hook', and minor mode in all Gnus buffers." (interactive) (gnus-open-agent) - (unless gnus-agent-send-mail-function - (setq gnus-agent-send-mail-function - (or message-send-mail-real-function - (function (lambda () (funcall message-send-mail-function)))) - message-send-mail-real-function 'gnus-agent-send-mail)) + (setq message-send-mail-real-function 'gnus-agent-send-mail) ;; If the servers file doesn't exist, auto-agentize some servers and ;; save the servers file so this auto-agentizing isn't invoked @@ -723,7 +718,7 @@ Optional arg GROUP-NAME allows to specify another group." (defun gnus-agent-send-mail () (if (or (not gnus-agent-queue-mail) (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) - (funcall gnus-agent-send-mail-function) + (message-multi-smtp-send-mail) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) @@ -1304,12 +1299,18 @@ This can be added to `gnus-select-article-hook' or (gnus-group-update-group group t))) nil)) -(defun gnus-agent-save-active (method) +(defun gnus-agent-save-active (method &optional groups-p) + "Sync the agent's active file with the current buffer. +Pass non-nil for GROUPS-P if the buffer starts out in groups format. +Regardless, both the file and the buffer end up in active format +if METHOD is agentized; otherwise the function is a no-op." (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) (file (gnus-agent-lib-file "active"))) - (gnus-active-to-gnus-format nil new) + (if groups-p + (gnus-groups-to-gnus-format nil new) + (gnus-active-to-gnus-format nil new)) (gnus-agent-write-active file new) (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) @@ -3742,6 +3743,13 @@ has been fetched." (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) + (when fetch-old + (setq articles (gnus-uncompress-range + (cons (if (numberp fetch-old) + (max 1 (- (car articles) fetch-old)) + 1) + (car (last articles)))))) + ;; Populate temp buffer with known headers (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer @@ -3778,12 +3786,7 @@ has been fetched." (set-buffer nntp-server-buffer) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) - (min (cond ((numberp fetch-old) - (max 1 (- (car articles) fetch-old))) - (fetch-old - 1) - (t - (car articles)))) + (min (car articles)) (max (car (last articles)))) ;; Get the list of articles that were fetched @@ -3858,8 +3861,7 @@ has been fetched." (not (numberp fetch-old))) t ; Don't remove anything. (nnheader-nov-delete-outside-range - (if fetch-old (max 1 (- (car articles) fetch-old)) - (car articles)) + (car articles) (car (last articles))) t) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index b04615dc5a9..b92c3b6435f 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2231,7 +2231,8 @@ unfolded." (unfoldable (or (equal gnus-article-unfold-long-headers t) (and (stringp gnus-article-unfold-long-headers) - (string-match gnus-article-unfold-long-headers header))))) + (string-match gnus-article-unfold-long-headers + header))))) (with-temp-buffer (insert header) (goto-char (point-min)) @@ -5329,9 +5330,8 @@ Compressed files like .gz and .bz2 are decompressed." (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (mm-read-coding-system "Charset: ")))) - (t - (if (mm-handle-undisplayer handle) - (mm-remove-part handle)))) + ((mm-handle-undisplayer handle) + (mm-remove-part handle))) (forward-line 2) (mm-display-inline handle) (goto-char b))))) @@ -6200,12 +6200,13 @@ Provided for backwards compatibility." (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) -(declare-function shr-put-image "shr" (data alt)) +(declare-function shr-put-image "shr" (data alt &optional flags)) -(defun gnus-shr-put-image (data alt) +(defun gnus-shr-put-image (data alt &optional flags) "Put image DATA with a string ALT. Enable image to be deleted." (let ((image (shr-put-image data (propertize (or alt "*") - 'gnus-image-category 'shr)))) + 'gnus-image-category 'shr) + flags))) (when image (gnus-add-image 'shr image)))) @@ -6524,7 +6525,8 @@ not have a face in `gnus-article-boring-faces'." (ding) (unless (member keys nosave-in-article) (set-buffer gnus-article-current-summary)) - (when (get func 'disabled) + (when (and (symbolp func) + (get func 'disabled)) (error "Function %s disabled" func)) (call-interactively func) (setq new-sum-point (point))) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index c7443446ceb..6bcba714696 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -509,6 +509,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (if (and (equal (cdadr m) "") (equal (cdar m) (cdaddr m)) (goto-char (caadr m)) + (looking-at "[ \t]*$") (forward-line 1) (= (point) (caaddr m))) (setcdr m (cdddr m)) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index d0baf25d5d9..115c5777448 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -71,7 +71,7 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." ;;; Internal variables. (defvar gnus-demon-timers nil - "List of idle timers which are running.") + "Plist of idle timers which are running.") (defvar gnus-inhibit-demon nil "If non-nil, no daemonic function will be run.") @@ -98,15 +98,32 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." (float-time (or (current-idle-time) '(0 0 0))))) -(defun gnus-demon-run-callback (func &optional idle) - "Run FUNC if Emacs has been idle for longer than IDLE seconds." +(defun gnus-demon-run-callback (func &optional idle time special) + "Run FUNC if Emacs has been idle for longer than IDLE seconds. +If not, and a TIME is given, restart a new idle timer, so FUNC +can be called at the next opportunity. Such a special idle run is +marked with SPECIAL." (unless gnus-inhibit-demon - (when (or (not idle) - (and (eq idle t) (> (gnus-demon-idle-since) 0)) - (<= idle (gnus-demon-idle-since))) + (block run-callback + (when (eq idle t) + (setq idle 0.001)) + (cond (special + (setq gnus-demon-timers + (plist-put gnus-demon-timers func + (run-with-timer time time 'gnus-demon-run-callback + func idle time)))) + ((and idle (> idle (gnus-demon-idle-since))) + (when time + (nnheader-cancel-timer (plist-get gnus-demon-timers func)) + (setq gnus-demon-timers + (plist-put gnus-demon-timers func + (run-with-idle-timer idle nil + 'gnus-demon-run-callback + func idle time t)))) + (return-from run-callback))) (with-local-quit - (ignore-errors - (funcall func)))))) + (ignore-errors + (funcall func)))))) (defun gnus-demon-init () "Initialize the Gnus daemon." @@ -116,7 +133,6 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." ;; Set up the timer. (let* ((func (nth 0 handler)) (time (nth 1 handler)) - (time-type (type-of time)) (idle (nth 2 handler)) ;; Compute time according with timestep. ;; If t, replace by 1 @@ -140,13 +156,15 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." (run-with-idle-timer idle t 'gnus-demon-run-callback func)) ;; (func number any) ;; Call every `time' - ((eq time-type 'integer) - (run-with-timer time time 'gnus-demon-run-callback func idle)) + ((integerp time) + (run-with-timer time time 'gnus-demon-run-callback + func idle time)) ;; (func string any) - ((eq time-type 'string) - (run-with-timer time (* 24 60 60) 'gnus-demon-run-callback func idle))))) + ((stringp time) + (run-with-timer time (* 24 60 60) 'gnus-demon-run-callback + func idle))))) (when timer - (add-to-list 'gnus-demon-timers timer))))) + (setq gnus-demon-timers (plist-put gnus-demon-timers func timer)))))) (defun gnus-demon-time-to-step (time) "Find out how many steps to TIME, which is on the form \"17:43\"." @@ -185,8 +203,8 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." (defun gnus-demon-cancel () "Cancel any Gnus daemons." (interactive) - (dolist (timer gnus-demon-timers) - (nnheader-cancel-timer timer)) + (dotimes (i (/ (length gnus-demon-timers) 2)) + (nnheader-cancel-timer (nth (1+ (* i 2)) gnus-demon-timers))) (setq gnus-demon-timers nil)) (defun gnus-demon-add-disconnection () diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index f97d9a69eae..8287a6bb86e 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -56,7 +56,7 @@ (autoload 'gnus-group-make-nnir-group "nnir") -(defcustom gnus-no-groups-message "No Gnus is good news" +(defcustom gnus-no-groups-message "No news is good news" "*Message displayed by Gnus when no groups are available." :group 'gnus-start :type 'string) @@ -2290,9 +2290,12 @@ Return the name of the group if selection was successful." ;; (gnus-read-group "Group name: ") (gnus-group-completing-read) (gnus-read-method "From method"))) - ;; Transform the select method into a unique server. (unless (gnus-alive-p) - (gnus-no-server)) + (nnheader-init-server-buffer) + ;; Necessary because of funky inlining. + (require 'gnus-cache) + (setq gnus-newsrc-hashtb (gnus-make-hashtable))) + ;; Transform the select method into a unique server. (when (stringp method) (setq method (gnus-server-to-method method))) (let ((address-slot @@ -2312,18 +2315,22 @@ Return the name of the group if selection was successful." `(-1 nil (,group ,gnus-level-default-subscribed nil nil ,method ,(cons - (cond - (quit-config - (cons 'quit-config quit-config)) - ((assq gnus-current-window-configuration - gnus-buffer-configuration) - (cons 'quit-config + (cons 'quit-config + (cond + (quit-config + quit-config) + ((assq gnus-current-window-configuration + gnus-buffer-configuration) (cons gnus-summary-buffer - gnus-current-window-configuration)))) + gnus-current-window-configuration)) + (t + (cons (current-buffer) + (current-window-configuration))))) parameters))) gnus-newsrc-hashtb) (push method gnus-ephemeral-servers) - (set-buffer gnus-group-buffer) + (when (gnus-buffer-live-p gnus-group-buffer) + (set-buffer gnus-group-buffer)) (unless (gnus-check-server method) (error "Unable to contact server: %s" (gnus-status-message method))) (when activate @@ -4014,11 +4021,13 @@ entail asking the server for the groups." (gnus-activate-foreign-newsgroups level)) (gnus-group-get-new-news))) -(defun gnus-group-get-new-news (&optional arg) +(defun gnus-group-get-new-news (&optional arg one-level) "Get newly arrived articles. If ARG is a number, it specifies which levels you are interested in re-scanning. If ARG is non-nil and not a number, this will force -\"hard\" re-reading of the active files from all servers." +\"hard\" re-reading of the active files from all servers. +If ONE-LEVEL is not nil, then re-scan only the specified level, +otherwise all levels below ARG will be scanned too." (interactive "P") (require 'nnmail) (let ((gnus-inhibit-demon t) @@ -4032,7 +4041,8 @@ re-scanning. If ARG is non-nil and not a number, this will force (unless gnus-slave (gnus-master-read-slave-newsrc)) - (gnus-get-unread-articles arg) + (gnus-get-unread-articles (gnus-group-default-level arg t) + nil one-level) ;; If the user wants it, we scan for new groups. (when (eq gnus-check-new-newsgroups 'always) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index 1190d79f778..18e56ed9b3a 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -533,15 +533,69 @@ If BUFFER, insert the article in that group." header (gnus-group-real-name group)))) +(defun gnus-select-group-with-message-id (group message-id) + "Activate and select GROUP with the given MESSAGE-ID selected. +Returns the article number of the message. + +If GROUP is not already selected, the message will be the only one in +the group's summary. +" + ;; TODO: is there a way to know at this point whether the group will + ;; be newly-selected? If so we could clean up the logic at the end + ;; + ;; save the new group's display parameter, if any, so we + ;; can replace it temporarily with zero. + (let ((saved-display + (gnus-group-get-parameter group 'display :allow-list))) + + ;; Tell gnus we really don't want any articles + (gnus-group-set-parameter group 'display 0) + + (unwind-protect + (gnus-summary-read-group-1 + group (not :show-all) :no-article (not :kill-buffer) + ;; The combination of no-display and this dummy list of + ;; articles to select somehow makes it possible to open a + ;; group with no articles in it. Black magic. + :no-display '(-1); select-articles + ) + ;; Restore the new group's display parameter + (gnus-group-set-parameter group 'display saved-display))) + + ;; The summary buffer was suppressed by :no-display above. + ;; Create it now and insert the message + (let ((group-is-new (gnus-summary-setup-buffer group))) + (condition-case err + (let ((article-number + (gnus-summary-insert-subject message-id))) + (unless article-number + (signal 'error "message-id not in group")) + (gnus-summary-select-article nil nil nil article-number) + article-number) + ;; Clean up the new summary and propagate the error + (error (when group-is-new (gnus-summary-exit)) + (apply 'signal err))))) + +(defun gnus-simplify-group-name (group) + "Return the simplest representation of the name of GROUP. +This is the string that Gnus uses to identify the group." + (gnus-group-prefixed-name + (gnus-group-real-name group) + (gnus-group-method group))) + (defun gnus-warp-to-article () "Warps from an article in a virtual group to the article in its real group. Does nothing on a real group." (interactive) - (let ((gnus-command-method - (gnus-find-method-for-group gnus-newsgroup-name))) - (when (gnus-check-backend-function - 'warp-to-article (car gnus-command-method)) - (funcall (gnus-get-function gnus-command-method 'warp-to-article))))) + (when (gnus-virtual-group-p gnus-newsgroup-name) + (let ((gnus-command-method + (gnus-find-method-for-group gnus-newsgroup-name))) + (or + (when (gnus-check-backend-function + 'warp-to-article (car gnus-command-method)) + (funcall (gnus-get-function gnus-command-method 'warp-to-article))) + (and (bound-and-true-p gnus-registry-enabled) + (gnus-try-warping-via-registry)))))) (defun gnus-request-head (article group) "Request the head of ARTICLE in GROUP." diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index c6d0c3213a0..d38f36a0c77 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -163,6 +163,22 @@ if nil, attach files as normal parts." (const all :tag "Any") (string :tag "Regexp"))) +(defcustom gnus-gcc-self-resent-messages 'no-gcc-self + "Like `gcc-self' group parameter, only for unmodified resent messages. +Applied to messages sent by `gnus-summary-resend-message'. Non-nil +value of this variable takes precedence over any existing Gcc header. + +If this is `none', no Gcc copy will be made. If this is t, messages +resent will be Gcc'd to the current group. If this is a string, it +specifies a group to which resent messages will be Gcc'd. If this is +nil, Gcc will be done according to existing Gcc header(s), if any. +If this is `no-gcc-self', resent messages will be Gcc'd to groups that +existing Gcc header specifies, except for the current group." + :version "24.2" + :group 'gnus-message + :type '(choice (const none) (const t) string (const nil) + (const no-gcc-self))) + (gnus-define-group-parameter posting-charset-alist :type list @@ -297,6 +313,22 @@ If nil, the address field will always be empty after invoking :group 'gnus-message :type 'boolean) +(defcustom gnus-gcc-pre-body-encode-hook nil + "A hook called before encoding the body of the Gcc copy of a message. +The current buffer (when the hook is run) contains the message +including the message header. Changes made to the message will +only affect the Gcc copy, but not the original message." + :group 'gnus-message + :type 'hook) + +(defcustom gnus-gcc-post-body-encode-hook nil + "A hook called after encoding the body of the Gcc copy of a message. +The current buffer (when the hook is run) contains the message +including the message header. Changes made to the message will +only affect the Gcc copy, but not the original message." + :group 'gnus-message + :type 'hook) + (autoload 'gnus-message-citation-mode "gnus-cite" nil t) ;;; Internal variables. @@ -487,8 +519,10 @@ If Gnus isn't running, a plain `message-mail' setup is used instead." (interactive) (if (not (gnus-alive-p)) - (message-mail to subject other-headers continue - nil yank-action send-actions return-action) + (progn + (message "Gnus not running; using plain Message mode") + (message-mail to subject other-headers continue + nil yank-action send-actions return-action)) (let ((buf (current-buffer)) (gnus-newsgroup-name (or gnus-newsgroup-name "")) mail-buf) @@ -810,9 +844,21 @@ post using the current select method." (interactive (gnus-interactive "P\ny")) (let ((message-post-method `(lambda (arg) - (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) + (user-mail-address user-mail-address)) (dolist (article (gnus-summary-work-articles n)) (when (gnus-summary-select-article t nil nil article) + ;; Pretend that we're doing a followup so that we can see what + ;; the From header would have ended up being. + (save-window-excursion + (save-excursion + (gnus-summary-followup nil) + (let ((from (message-fetch-field "from"))) + (when from + (setq user-mail-address + (car (mail-header-parse-address from))))) + (kill-buffer (current-buffer)))) + ;; Now cancel the article using the From header we got. (when (gnus-eval-in-buffer-window gnus-original-article-buffer (message-cancel-news)) (gnus-summary-mark-as-read article gnus-canceled-mark) @@ -1271,6 +1317,44 @@ For the \"inline\" alternatives, also see the variable (set-buffer gnus-original-article-buffer) (message-forward post))))))) +(defun gnus-summary-resend-message-insert-gcc () + "Insert Gcc header according to `gnus-gcc-self-resent-messages'." + (gnus-inews-insert-gcc) + (let ((gcc (mapcar + (lambda (group) + (mm-encode-coding-string + group + (gnus-group-name-charset (gnus-inews-group-method group) + group))) + (message-unquote-tokens + (message-tokenize-header (mail-fetch-field "gcc" nil t) + " ,")))) + (self (with-current-buffer gnus-summary-buffer + gnus-gcc-self-resent-messages))) + (message-remove-header "gcc") + (when gcc + (goto-char (point-max)) + (cond ((eq self 'none)) + ((eq self t) + (insert "Gcc: \"" gnus-newsgroup-name "\"\n")) + ((stringp self) + (insert "Gcc: " + (mm-encode-coding-string + (if (string-match " " self) + (concat "\"" self "\"") + self) + (gnus-group-name-charset (gnus-inews-group-method self) + self)) + "\n")) + ((null self) + (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n")) + ((eq self '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 @@ -1284,12 +1368,24 @@ For the \"inline\" alternatives, also see the variable (with-current-buffer gnus-original-article-buffer (nnmail-fetch-field "to")))) current-prefix-arg)) - (dolist (article (gnus-summary-work-articles n)) - (gnus-summary-select-article nil nil nil article) - (with-current-buffer gnus-original-article-buffer - (let ((gnus-gcc-externalize-attachments nil)) - (message-resend address))) - (gnus-summary-mark-article-as-forwarded article))) + (let ((message-header-setup-hook (copy-sequence message-header-setup-hook)) + (message-sent-hook (copy-sequence message-sent-hook))) + ;; `gnus-summary-resend-message-insert-gcc' must run last. + (add-hook 'message-header-setup-hook + 'gnus-summary-resend-message-insert-gcc t) + (add-hook 'message-sent-hook + `(lambda () + (let ((rfc2047-encode-encoded-words nil)) + ,(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 () @@ -1581,7 +1677,9 @@ this is a reply." (nnheader-set-temp-buffer " *acc*") (setq message-options (with-current-buffer cur message-options)) (insert-buffer-substring cur) + (run-hooks 'gnus-gcc-pre-body-encode-hook) (message-encode-message-body) + (run-hooks 'gnus-gcc-post-body-encode-hook) (save-restriction (message-narrow-to-headers) (let* ((mail-parse-charset message-default-charset) @@ -1630,12 +1728,16 @@ this is a reply." (when (and group-art ;; FIXME: Should gcc-mark-as-read work when ;; Gnus is not running? - (gnus-alive-p) - (or gnus-gcc-mark-as-read - (and - (boundp 'gnus-inews-mark-gcc-as-read) - (symbol-value 'gnus-inews-mark-gcc-as-read)))) - (gnus-group-mark-article-read group (cdr group-art))) + (gnus-alive-p)) + (if (or gnus-gcc-mark-as-read + (and (boundp 'gnus-inews-mark-gcc-as-read) + (symbol-value 'gnus-inews-mark-gcc-as-read))) + (gnus-group-mark-article-read group (cdr group-art)) + (with-current-buffer gnus-group-buffer + (let ((gnus-group-marked (list group)) + (gnus-get-new-news-hook nil) + (inhibit-read-only t)) + (gnus-group-get-new-news-this-group nil t))))) (setq options message-options) (with-current-buffer cur (setq message-options options)) (kill-buffer (current-buffer))))))))) diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index 2f347efe579..3b335b335dd 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -75,6 +75,12 @@ Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'gnus-picon) +(defcustom gnus-picon-properties '(:color-symbols (("None" . "white"))) + "List of image properties applied to picons." + :type 'list + :version "24.2" + :group 'gnus-picon) + (defcustom gnus-picon-style 'inline "How should picons be displayed. If `inline', the textual representation is replaced. If `right', picons are @@ -157,9 +163,9 @@ replacement is added." (defun gnus-picon-create-glyph (file) (or (cdr (assoc file gnus-picon-glyph-alist)) - (cdar (push (cons file (gnus-create-image - file nil nil - :color-symbols '(("None" . "white")))) + (cdar (push (cons file (apply 'gnus-create-image + file nil nil + gnus-picon-properties)) gnus-picon-glyph-alist)))) ;;; Functions that does picon transformations: diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index f1618b376ef..8aecc98ee86 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -78,12 +78,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (require 'gnus) (require 'gnus-int) (require 'gnus-sum) @@ -96,7 +90,7 @@ (defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t - "Boolean set to t when the registry is modified") + "Boolean set to t when the registry is modified.") (defgroup gnus-registry nil "The Gnus registry." @@ -267,7 +261,7 @@ the Bit Bucket." (append gnus-registry-track-extra '(mark group keyword))) (when (not (equal old (oref db :tracked))) - (gnus-message 4 "Reindexing the Gnus registry (tracked change)") + (gnus-message 9 "Reindexing the Gnus registry (tracked change)") (registry-reindex db)))) db) @@ -284,7 +278,7 @@ the Bit Bucket." :tracked nil))) (defvar gnus-registry-db (gnus-registry-make-db) - "*The article registry by Message ID. See `registry-db'") + "The article registry by Message ID. See `registry-db'.") ;; top-level registry data management (defun gnus-registry-remake-db (&optional forsure) @@ -418,9 +412,9 @@ This is not required after changing `gnus-registry-cache-file'." ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. (defun gnus-registry-split-fancy-with-parent () - "Split this message into the same group as its parent. The parent -is obtained from the registry. This function can be used as an entry -in `nnmail-split-fancy' or `nnimap-split-fancy', for example like + "Split this message into the same group as its parent. +The parent is obtained from the registry. This function can be used as an +entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like this: (: gnus-registry-split-fancy-with-parent) This function tracks ALL backends, unlike @@ -746,7 +740,7 @@ Overrides existing keywords with FORCE set non-nil." (registry-lookup-secondary-value gnus-registry-db 'keyword keyword)) (defun gnus-registry-register-message-ids () - "Register the Message-ID of every article in the group" + "Register the Message-ID of every article in the group." (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) (dolist (article gnus-newsgroup-articles) (let* ((id (gnus-registry-fetch-message-id-fast article)) @@ -761,7 +755,7 @@ Overrides existing keywords with FORCE set non-nil." ;; message field fetchers (defun gnus-registry-fetch-message-id-fast (article) - "Fetch the Message-ID quickly, using the internal gnus-data-list function" + "Fetch the Message-ID quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) @@ -793,7 +787,7 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-simplified-message-subject-fast (article) - "Fetch the Subject quickly, using the internal gnus-data-list function" + "Fetch the Subject quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties @@ -811,7 +805,7 @@ Addresses without a name will say \"noname\"." (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) (defun gnus-registry-fetch-header-fast (article header) - "Fetch the HEADER quickly, using the internal gnus-data-list function" + "Fetch the HEADER quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties @@ -831,7 +825,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value." (when cell-data (funcall function mark cell-data))))) -;;; this is ugly code, but I don't know how to do it better +;; FIXME: Why not merge gnus-registry--set/remove-mark and +;; gnus-registry-set-article-mark-internal? +(defun gnus-registry--set/remove-mark (remove mark articles) + "Set/remove the MARK over process-marked ARTICLES." + ;; If this is called and the user doesn't want the + ;; registry enabled, we'll ask anyhow. + (unless gnus-registry-install + (let ((gnus-registry-install 'ask)) + (gnus-registry-install-p))) + + ;; Now the user is asked if gnus-registry-install is `ask'. + (when (gnus-registry-install-p) + (gnus-registry-set-article-mark-internal + ;; All this just to get the mark, I must be doing it wrong. + mark articles remove t) + ;; FIXME: Why do we do the above only here and not directly inside + ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do + ;; the things below when gnus-registry-set-article-mark-internal is called + ;; from gnus-registry-set-article-mark or + ;; gnus-registry-remove-article-mark? + (gnus-message 9 "Applying mark %s to %d articles" + mark (length articles)) + (dolist (article articles) + (gnus-summary-update-article + article + (assoc article (gnus-data-list nil)))))) + +;; This is ugly code, but I don't know how to do it better. (defun gnus-registry-install-shortcuts () "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." @@ -843,69 +864,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (let ((function-format (format "gnus-registry-%%s-article-%s-mark" mark))) -;;; The following generates these functions: -;;; (defun gnus-registry-set-article-Important-mark (&rest articles) -;;; "Apply the Important mark to process-marked ARTICLES." -;;; (interactive (gnus-summary-work-articles current-prefix-arg)) -;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) -;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) -;;; "Apply the Important mark to process-marked ARTICLES." -;;; (interactive (gnus-summary-work-articles current-prefix-arg)) -;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) +;;; The following generates these functions: +;;; (defun gnus-registry-set-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) +;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) (dolist (remove '(t nil)) (let* ((variant-name (if remove "remove" "set")) - (function-name (format function-format variant-name)) - (shortcut (format "%c" data)) - (shortcut (if remove (upcase shortcut) shortcut))) - (unintern function-name obarray) - (eval - `(defun - ;; function name - ,(intern function-name) - ;; parameter definition - (&rest articles) - ;; documentation - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - ;; interactive definition - (interactive - (gnus-summary-work-articles current-prefix-arg)) - ;; actual code - - ;; if this is called and the user doesn't want the - ;; registry enabled, we'll ask anyhow - (unless gnus-registry-install - (let ((gnus-registry-install 'ask)) - (gnus-registry-install-p))) - - ;; now the user is asked if gnus-registry-install is 'ask - (when (gnus-registry-install-p) - (gnus-registry-set-article-mark-internal - ;; all this just to get the mark, I must be doing it wrong - (intern ,(symbol-name mark)) - articles ,remove t) - (gnus-message - 9 - "Applying mark %s to %d articles" - ,(symbol-name mark) (length articles)) - (dolist (article articles) - (gnus-summary-update-article - article - (assoc article (gnus-data-list nil))))))) - (push (intern function-name) keys-plist) + (function-name + (intern (format function-format variant-name))) + (shortcut (format "%c" (if remove (upcase data) data)))) + (defalias function-name + ;; If it weren't for the function's docstring, we could + ;; use a closure, with lexical-let :-( + `(lambda (&rest articles) + ,(format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark ',mark ',remove articles))) + (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" (upcase-initials variant-name) (symbol-name mark)) - (intern function-name) t) + function-name t) gnus-registry-misc-menus) - (gnus-message - 9 - "Defined mark handling function %s" - function-name)))))) + (gnus-message 9 "Defined mark handling function %s" + function-name)))))) (gnus-define-keys-1 '(gnus-registry-mark-map "M" gnus-summary-mark-map) keys-plist) @@ -925,7 +918,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; use like this: ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) - "Show the marks for an article by the :char property" + "Show the marks for an article by the :char property." (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) (mapconcat (lambda (mark) @@ -938,7 +931,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; use like this: ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) - "Show the marks for an article by name" + "Show the marks for an article by name." (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) (mapconcat (lambda (mark) (symbol-name mark)) marks ","))) @@ -1078,88 +1071,16 @@ only the last one's marks are returned." (gnus-registry-set-id-key id key val)))) (message "Import done, collected %d entries" count)))) -(ert-deftest gnus-registry-misc-test () - (should-error (gnus-registry-extract-addresses '("" ""))) - - (should (equal '("Ted Zlatanov <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." + "Initialize the Gnus registry." (interactive) (gnus-message 5 "Initializing the registry") (gnus-registry-install-hooks) (gnus-registry-install-shortcuts) (gnus-registry-read)) +;; FIXME: Why autoload this function? ;;;###autoload (defun gnus-registry-install-hooks () "Install the registry hooks." @@ -1206,6 +1127,52 @@ the user is asked first. Returns non-nil iff the registry is enabled." (gnus-registry-initialize))) gnus-registry-enabled) +;; largely based on nnir-warp-to-article +(defun gnus-try-warping-via-registry () + "Try to warp via the registry. +This will be done via the current article's source group based on +data stored in the registry." + (interactive) + (when (gnus-summary-article-header) + (let* ((message-id (mail-header-id (gnus-summary-article-header))) + ;; Retrieve the message's group(s) from the registry + (groups (gnus-registry-get-id-key message-id 'group)) + ;; If starting from an ephemeral group, this describes + ;; how to restore the window configuration + (quit-config + (gnus-ephemeral-group-p gnus-newsgroup-name)) + (seen-groups (list (gnus-group-group-name)))) + + (catch 'found + (dolist (group (mapcar 'gnus-simplify-group-name groups)) + + ;; skip over any groups we really don't want to warp to. + (unless (or (member group seen-groups) + (gnus-ephemeral-group-p group) ;; any ephemeral group + (memq (car (gnus-find-method-for-group group)) + ;; Specific methods; this list may need to expand. + '(nnir))) + + ;; remember that we've seen this group already + (push group seen-groups) + + ;; first exit from any ephemeral summary buffer. + (when quit-config + (gnus-summary-exit) + ;; and if the ephemeral summary buffer in turn came from + ;; another summary buffer we have to clean that summary + ;; up too. + (when (eq (cdr quit-config) 'summary) + (gnus-summary-exit)) + ;; remember that we've already done this part + (setq quit-config nil)) + + ;; Try to activate the group. If that fails, just move + ;; along. We may have more groups to work with + (ignore-errors + (gnus-select-group-with-message-id group message-id)) + (throw 'found t))))))) + ;; TODO: a few things (provide 'gnus-registry) diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index e1879202ef3..f40177d5c60 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -101,66 +101,13 @@ text properties. This is only needed on XEmacs, as Emacs does this anyway." (propertize (string 8206) 'invisible t) "")) -(defun gnus-summary-line-format-spec () - (insert gnus-tmp-unread gnus-tmp-replied - gnus-tmp-score-char gnus-tmp-indentation) - (gnus-put-text-property - (point) - (progn - (insert - (format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines - (let ((val - (inline - (gnus-summary-from-or-to-or-newsgroups - gnus-tmp-header gnus-tmp-from)))) - (if (> (length val) 23) - (if (gnus-lrm-string-p val) - (concat (substring val 0 23) gnus-lrm-string) - (substring val 0 23)) - val)) - gnus-tmp-closing-bracket)) - (point)) - gnus-mouse-face-prop gnus-mouse-face) - (insert " " gnus-tmp-subject-or-nil "\n")) - -(defvar gnus-summary-line-format-spec - (gnus-byte-code 'gnus-summary-line-format-spec)) - -(defun gnus-summary-dummy-line-format-spec () - (insert "* ") - (gnus-put-text-property - (point) - (progn - (insert ": :") - (point)) - gnus-mouse-face-prop gnus-mouse-face) - (insert " " gnus-tmp-subject "\n")) - -(defvar gnus-summary-dummy-line-format-spec - (gnus-byte-code 'gnus-summary-dummy-line-format-spec)) - -(defun gnus-group-line-format-spec () - (insert gnus-tmp-marked-mark gnus-tmp-subscribed - gnus-tmp-process-marked - gnus-group-indentation - (format "%5s: " gnus-tmp-number-of-unread)) - (gnus-put-text-property - (point) - (progn - (insert gnus-tmp-group "\n") - (1- (point))) - gnus-mouse-face-prop gnus-mouse-face)) -(defvar gnus-group-line-format-spec - (gnus-byte-code 'gnus-group-line-format-spec)) +(defvar gnus-summary-line-format-spec nil) +(defvar gnus-summary-dummy-line-format-spec nil) +(defvar gnus-group-line-format-spec nil) (defvar gnus-format-specs `((version . ,emacs-version) - (gnus-version . ,(gnus-continuum-version)) - (group "%M\%S\%p\%P\%5y: %(%g%)\n" ,gnus-group-line-format-spec) - (summary-dummy "* %(: :%) %S\n" - ,gnus-summary-dummy-line-format-spec) - (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n" - ,gnus-summary-line-format-spec)) + (gnus-version . ,(gnus-continuum-version))) "Alist of format specs.") (defvar gnus-default-format-specs gnus-format-specs) @@ -214,15 +161,6 @@ Return a list of updated types." (not (equal emacs-version (cdr (assq 'version gnus-format-specs))))) (setq gnus-format-specs nil)) - ;; Flush the group format spec cache if there's the grouplens stuff - ;; or it doesn't support decoded group names. - (when (memq 'group types) - (let* ((spec (assq 'group gnus-format-specs)) - (sspec (gnus-prin1-to-string (nth 2 spec)))) - (when (or (string-match " gnus-tmp-grouplens[ )]" sspec) - (not (string-match " gnus-tmp-decoded-group[ )]" sspec))) - (setq gnus-format-specs (delq spec gnus-format-specs))))) - ;; Go through all the formats and see whether they need updating. (let (new-format entry type val updated) (while (setq type (pop types)) @@ -778,36 +716,6 @@ If PROPS, insert the result." (gnus-add-text-properties (point) (progn (eval form) (point)) props) (eval form)))) -(defun gnus-compile () - "Byte-compile the user-defined format specs." - (interactive) - (require 'bytecomp) - (let ((entries gnus-format-specs) - (byte-compile-warnings '(unresolved callargs redefine)) - entry gnus-tmp-func) - (save-excursion - (gnus-message 7 "Compiling format specs...") - - (while entries - (setq entry (pop entries)) - (if (memq (car entry) '(gnus-version version)) - (setq gnus-format-specs (delq entry gnus-format-specs)) - (let ((form (caddr entry))) - (when (and (listp form) - ;; Under GNU Emacs, it's (byte-code ...) - (not (eq 'byte-code (car form))) - ;; Under XEmacs, it's (funcall #<compiled-function ...>) - (not (and (eq 'funcall (car form)) - (byte-code-function-p (cadr form))))) - (defalias 'gnus-tmp-func `(lambda () ,form)) - (byte-compile 'gnus-tmp-func) - (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func)))))) - - (push (cons 'version emacs-version) gnus-format-specs) - ;; Mark the .newsrc.eld file as "dirty". - (gnus-dribble-touch) - (gnus-message 7 "Compiling user specs...done")))) - (defun gnus-set-format (type &optional insertable) (set (intern (format "gnus-%s-line-format-spec" type)) (gnus-parse-format diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index f025960c348..15bbf01c469 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1504,8 +1504,6 @@ backend check whether the group actually exists." ;; Return the new active info. active))))) -(defvar gnus-propagate-marks) ; gnus-sum - (defun gnus-get-unread-articles-in-group (info active &optional update) (when (and info active) ;; Allow the backend to update the info in the group. @@ -1515,13 +1513,6 @@ backend check whether the group actually exists." (gnus-info-group info))))) (gnus-activate-group (gnus-info-group info) nil t)) - ;; Allow backends to update marks, - (when gnus-propagate-marks - (let ((method (inline (gnus-find-method-for-group - (gnus-info-group info))))) - (when (gnus-check-backend-function 'request-marks (car method)) - (gnus-request-marks info method)))) - (let* ((range (gnus-info-read info)) (num 0)) @@ -1610,7 +1601,7 @@ backend check whether the group actually exists." ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' ;; and compute how many unread articles there are in each group. -(defun gnus-get-unread-articles (&optional level dont-connect) +(defun gnus-get-unread-articles (&optional level dont-connect one-level) (setq gnus-server-method-cache nil) (require 'gnus-agent) (let* ((newsrc (cdr gnus-newsrc-alist)) @@ -1667,7 +1658,7 @@ backend check whether the group actually exists." (push (setq method-group-list (list method method-type nil nil)) type-cache)) ;; Only add groups that need updating. - (if (<= (gnus-info-level info) + (if (funcall (if one-level #'= #'<=) (gnus-info-level info) (if (eq (cadr method-group-list) 'foreign) foreign-level alevel)) @@ -2230,7 +2221,7 @@ backend check whether the group actually exists." (gnus-online method) (gnus-agent-method-p method)) (progn - (gnus-agent-save-active method) + (gnus-agent-save-active method t) (gnus-active-to-gnus-format method hashtb nil real-active)) (goto-char (point-min)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 7f095e15496..10b314a1435 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -451,7 +451,8 @@ current article is unread." :group 'gnus-summary-maneuvering :type 'boolean) -(defcustom gnus-auto-center-summary 2 +(defcustom gnus-auto-center-summary + (max (or (bound-and-true-p scroll-margin) 0) 2) "*If non-nil, always center the current summary buffer. In particular, if `vertical' do only vertical recentering. If non-nil and non-`vertical', do both horizontal and vertical recentering." @@ -1243,13 +1244,6 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :type 'boolean :group 'gnus-summary-marks) -(defcustom gnus-propagate-marks nil - "If non-nil, Gnus will store and retrieve marks from the backends. -This means that marks will be stored both in .newsrc.eld and in -the backend, and will slow operation down somewhat." - :type 'boolean - :group 'gnus-summary-marks) - (defcustom gnus-alter-articles-to-read-function nil "Function to be called to alter the list of articles to be selected." :type '(choice (const nil) function) @@ -1918,6 +1912,7 @@ increase the score of each group you read." "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article [tab] gnus-summary-widget-forward + [backtab] gnus-summary-widget-backward "t" gnus-summary-toggle-header "g" gnus-summary-show-article "l" gnus-summary-goto-last-article @@ -2082,6 +2077,7 @@ increase the score of each group you read." "g" gnus-summary-show-article "s" gnus-summary-isearch-article [tab] gnus-summary-widget-forward + [backtab] gnus-summary-widget-backward "P" gnus-summary-print-article "S" gnus-sticky-article "M" gnus-mailing-list-insinuate @@ -3558,7 +3554,7 @@ buffer that was in action when the last article was fetched." (push (eval (car locals)) vlist)) (setq locals (cdr locals))) (setq vlist (nreverse vlist))) - (with-current-buffer gnus-group-buffer + (with-temp-buffer (setq gnus-newsgroup-name name gnus-newsgroup-marked marked gnus-newsgroup-spam-marked spam @@ -6074,10 +6070,6 @@ If SELECT-ARTICLES, only select those articles from GROUP." (when (and (gnus-check-backend-function 'request-set-mark gnus-newsgroup-name) - (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group gnus-newsgroup-name) - 'server-marks)) (not (gnus-article-unpropagatable-p (cdr type)))) (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) ;; Don't do anything about marks for articles we @@ -6289,10 +6281,9 @@ The resulting hash table is returned, or nil if no Xrefs were found." (info (nth 2 entry)) (active (gnus-active group)) (set-marks - (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group group) - 'server-marks))) + (gnus-method-option-p + (gnus-find-method-for-group group) + 'server-marks)) range) (if (not entry) ;; Group that Gnus doesn't know exists, but still allow the @@ -6629,9 +6620,9 @@ too, instead of trying to fetch new headers." ;; article if ID is a number -- so that the next `P' or `N' ;; command will fetch the previous (or next) article even ;; if the one we tried to fetch this time has been canceled. - (when (> number gnus-newsgroup-end) + (unless (and gnus-newsgroup-end (< number gnus-newsgroup-end)) (setq gnus-newsgroup-end number)) - (when (< number gnus-newsgroup-begin) + (unless (and gnus-newsgroup-begin (> number gnus-newsgroup-begin)) (setq gnus-newsgroup-begin number)) (setq gnus-newsgroup-unselected (delq number gnus-newsgroup-unselected))) @@ -7257,7 +7248,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-summary-update-info)) (gnus-close-group group) ;; Make sure where we were, and go to next newsgroup. - (set-buffer gnus-group-buffer) + (when (buffer-live-p (get-buffer gnus-group-buffer)) + (set-buffer gnus-group-buffer)) (unless quit-config (gnus-group-jump-to-group group)) (gnus-run-hooks 'gnus-summary-exit-hook) @@ -7282,7 +7274,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-kill-buffer buf))) (setq gnus-current-select-method gnus-select-method) - (set-buffer gnus-group-buffer) + (when (gnus-buffer-live-p gnus-group-buffer) + (set-buffer gnus-group-buffer)) (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) @@ -7361,7 +7354,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." "Handle movement when leaving an ephemeral group. The state which existed when entering the ephemeral is reset." (if (not (buffer-live-p (car quit-config))) - (gnus-configure-windows 'group 'force) + (when (gnus-buffer-live-p gnus-group-buffer) + (gnus-configure-windows 'group 'force)) (set-buffer (car quit-config)) (unless (eq (cdr quit-config) 'group) (setq gnus-current-select-method @@ -8238,7 +8232,12 @@ If NOT-MATCHING, excluding articles that have authors that match a regexp." (interactive (list (read-string (if current-prefix-arg "Exclude author (regexp): " - "Limit to author (regexp): ")) + "Limit to author (regexp): ") + (let ((header (gnus-summary-article-header))) + (if (not header) + "" + (car (mail-header-parse-address + (mail-header-from header)))))) current-prefix-arg)) (gnus-summary-limit-to-subject from "from" not-matching)) @@ -9270,6 +9269,17 @@ With optional ARG, move across that many fields." (select-window (gnus-get-buffer-window gnus-article-buffer)) (widget-forward arg)) +(defun gnus-summary-widget-backward (arg) + "Move point to the previous field or button in the article. +With optional ARG, move across that many fields." + (interactive "p") + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (select-window (gnus-get-buffer-window gnus-article-buffer)) + (unless (widget-at (point)) + (goto-char (point-max))) + (widget-backward arg)) + (defun gnus-summary-isearch-article (&optional regexp-p) "Do incremental search forward on the current article. If REGEXP-P (the prefix) is non-nil, do regexp isearch." @@ -10080,10 +10090,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." to-group 'expire (list to-article) info)) (when (and to-marks - (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group to-group) - 'server-marks))) + (gnus-method-option-p + (gnus-find-method-for-group to-group) + 'server-marks)) (gnus-request-set-mark to-group (list (list (list to-article) 'add to-marks))))) @@ -12418,6 +12427,13 @@ If REVERSE, save parts that do not match TYPE." (not (setq header (car (gnus-get-newsgroup-headers nil t))))) () ; Malformed head. (unless (gnus-summary-article-sparse-p (mail-header-number header)) + (when (and (bound-and-true-p gnus-registry-enabled) + (not (gnus-ephemeral-group-p (car where)))) + (gnus-registry-handle-action + (mail-header-id header) nil + (gnus-group-prefixed-name (car where) gnus-override-method) + (mail-header-subject header) + (mail-header-from header))) (when (and (stringp id) (or (not (string= (gnus-group-real-name group) @@ -12565,10 +12581,9 @@ UNREAD is a sorted list." (save-excursion (let (setmarkundo) ;; Propagate the read marks to the backend. - (when (and (or gnus-propagate-marks - (gnus-method-option-p - (gnus-find-method-for-group group) - 'server-marks)) + (when (and (gnus-method-option-p + (gnus-find-method-for-group group) + 'server-marks) (gnus-check-backend-function 'request-set-mark group)) (let ((del (gnus-remove-from-range (gnus-info-read info) read)) (add (gnus-remove-from-range read (gnus-info-read info)))) diff --git a/lisp/gnus/gnus-sync.el b/lisp/gnus/gnus-sync.el index 6efd34e1596..7e13b885edf 100644 --- a/lisp/gnus/gnus-sync.el +++ b/lisp/gnus/gnus-sync.el @@ -24,44 +24,94 @@ ;; This is the gnus-sync.el package. -;; It's due for a rewrite using gnus-after-set-mark-hook and -;; gnus-before-update-mark-hook, and my plan is to do this once No -;; Gnus development is done. Until then please consider it -;; experimental. - ;; Put this in your startup file (~/.gnus.el for instance) ;; possibilities for gnus-sync-backend: ;; Tramp over SSH: /ssh:user@host:/path/to/filename -;; Tramp over IMAP: /imaps:user@yourhosthere.com:/INBOX.test/filename ;; ...or any other file Tramp and Emacs can handle... ;; (setq gnus-sync-backend "/remote:/path.gpg" ; will use Tramp+EPA if loaded -;; gnus-sync-global-vars `(gnus-newsrc-last-checked-date) -;; gnus-sync-newsrc-groups `("nntp" "nnrss") -;; gnus-sync-newsrc-offsets `(2 3)) +;; gnus-sync-global-vars '(gnus-newsrc-last-checked-date) +;; gnus-sync-newsrc-groups '("nntp" "nnrss")) +;; gnus-sync-newsrc-offsets '(2 3)) +;; against a LeSync server (beware the vampire LeSync, who knows your newsrc) + +;; (setq gnus-sync-backend '(lesync "http://lesync.info:5984/tzz") +;; gnus-sync-newsrc-groups '("nntp" "nnrss")) + +;; What's a LeSync server? + +;; 1. install CouchDB, set up a real server admin user, and create a +;; database, e.g. "tzz" and save the URL, +;; e.g. http://lesync.info:5984/tzz + +;; 2. run `M-: (gnus-sync-lesync-setup "http://lesync.info:5984/tzz" "tzzadmin" "mypassword" "mysalt" t t)' + +;; (If you run it more than once, you have to remove the entry from +;; _users yourself. This is intentional. This sets up a database +;; admin for the "tzz" database, distinct from the server admin +;; user in (1) above.) + +;; That's it, you can start using http://lesync.info:5984/tzz in your +;; gnus-sync-backend as a LeSync backend. Fan fiction about the +;; vampire LeSync is welcome. + +;; You may not want to expose a CouchDB install to the Big Bad +;; Internet, especially if your love of all things furry would be thus +;; revealed. Make sure it's not accessible by unauthorized users and +;; guests, at least. + +;; If you want to try it out, I will create a test DB for you under +;; http://lesync.info:5984/yourfavoritedbname ;; TODO: -;; - after gnus-sync-read, the message counts are wrong. So it's not -;; run automatically, you have to call it with M-x gnus-sync-read +;; - after gnus-sync-read, the message counts look wrong until you do +;; `g'. So it's not run automatically, you have to call it with M-x +;; gnus-sync-read ;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to ;; catch the mark updates +;; - repositioning of groups within topic after a LeSync sync is a +;; weird sort of bubble sort ("buttle" sort: the old entry ends up +;; at the rear of the list); you will eventually end up with the +;; right order after calling `gnus-sync-read' a bunch of times. + +;; - installing topics and groups is inefficient and annoying, lots of +;; prompts could be avoided + ;;; Code: (eval-when-compile (require 'cl)) +(eval-and-compile + (or (ignore-errors (progn + (require 'json))) + ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib + (ignore-errors + (let ((load-path (cons (expand-file-name + "gnus-fallback-lib" + (file-name-directory (locate-library "gnus"))) + load-path))) + (require 'json))) + (error + "json not found in `load-path' or gnus-fallback-lib/ directory."))) (require 'gnus) (require 'gnus-start) (require 'gnus-util) +(defvar gnus-topic-alist) ;; gnus-group.el +(eval-when-compile + (autoload 'gnus-group-topic "gnus-topic") + (autoload 'gnus-topic-create-topic "gnus-topic" nil t) + (autoload 'gnus-topic-enter-dribble "gnus-topic")) + (defgroup gnus-sync nil "The Gnus synchronization facility." :version "24.1" :group 'gnus) -(defcustom gnus-sync-newsrc-groups `("nntp" "nnrss") +(defcustom gnus-sync-newsrc-groups '("nntp" "nnrss") "List of groups to be synchronized in the gnus-newsrc-alist. The group names are matched, they don't have to be fully qualified. Typically you would choose all of these. That's the @@ -70,20 +120,12 @@ this setting is harmless until the user chooses a sync backend." :group 'gnus-sync :type '(repeat regexp)) -(defcustom gnus-sync-newsrc-offsets '(2 3) - "List of per-group data to be synchronized." - :group 'gnus-sync - :type '(set (const :tag "Read ranges" 2) - (const :tag "Marks" 3))) - (defcustom gnus-sync-global-vars nil "List of global variables to be synchronized. You may want to sync `gnus-newsrc-last-checked-date' but pretty much any symbol is fair game. You could additionally sync `gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology', -and `gnus-topic-alist' to cover all the variables in -newsrc.eld (except for `gnus-format-specs' which should not be -synchronized, I believe). Also see `gnus-variable-list'." +and `gnus-topic-alist'. Also see `gnus-variable-list'." :group 'gnus-sync :type '(repeat (choice (variable :tag "A known variable") (symbol :tag "Any symbol")))) @@ -92,30 +134,625 @@ synchronized, I believe). Also see `gnus-variable-list'." "The synchronization backend." :group 'gnus-sync :type '(radio (const :format "None" nil) + (list :tag "Sync server" + (const :format "LeSync Server API" lesync) + (string :tag "URL of a CouchDB database for API access")) (string :tag "Sync to a file"))) (defvar gnus-sync-newsrc-loader nil "Carrier for newsrc data") -(defun gnus-sync-save () -"Save the Gnus sync data to the backend." - (interactive) +(defcustom gnus-sync-lesync-name (system-name) + "The LeSync name for this machine." + :group 'gnus-sync + :type 'string) + +(defcustom gnus-sync-lesync-install-topics 'ask + "Should LeSync install the recorded topics?" + :group 'gnus-sync + :type '(choice (const :tag "Never Install" nil) + (const :tag "Always Install" t) + (const :tag "Ask Me Once" ask))) + +(defvar gnus-sync-lesync-props-hash (make-hash-table :test 'equal) + "LeSync props, keyed by group name") + +(defvar gnus-sync-lesync-design-prefix "/_design/lesync" + "The LeSync design prefix for CouchDB") + +(defvar gnus-sync-lesync-security-object "/_security" + "The LeSync security object for CouchDB") + +(defun gnus-sync-lesync-parse () + "Parse the result of a LeSync request." + (goto-char (point-min)) + (condition-case nil + (when (search-forward-regexp "^$" nil t) + (json-read)) + (error + (gnus-message + 1 + "gnus-sync-lesync-parse: Could not read the LeSync response!") + nil))) + +(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." + (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) + (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) + (kill-buffer (current-buffer)) + data))))) + +(defun gnus-sync-lesync-PUT (url headers &optional data) + (gnus-sync-lesync-call url "PUT" headers data)) + +(defun gnus-sync-lesync-POST (url headers &optional data) + (gnus-sync-lesync-call url "POST" headers data)) + +(defun gnus-sync-lesync-GET (url headers &optional data) + (gnus-sync-lesync-call url "GET" headers data)) + +(defun gnus-sync-lesync-DELETE (url headers &optional data) + (gnus-sync-lesync-call url "DELETE" headers data)) + +;; this is not necessary with newer versions of json.el but 1.2 or older +;; (which are in Emacs 24.1 and earlier) need it +(defun gnus-sync-json-alist-p (list) + "Non-null if and only if LIST is an alist." + (while (consp list) + (setq list (if (consp (car list)) + (cdr list) + 'not-alist))) + (null list)) + +;; this is not necessary with newer versions of json.el but 1.2 or older +;; (which are in Emacs 24.1 and earlier) need it +(defun gnus-sync-json-plist-p (list) + "Non-null if and only if LIST is a plist." + (while (consp list) + (setq list (if (and (keywordp (car list)) + (consp (cdr list))) + (cddr list) + 'not-plist))) + (null list)) + +; (gnus-sync-lesync-setup "http://lesync.info:5984/tzz" "tzzadmin" "mypassword" "mysalt" t t) +; (gnus-sync-lesync-setup "http://lesync.info:5984/tzz") + +(defun gnus-sync-lesync-setup (url &optional user password salt reader admin) + (interactive "sEnter URL to set up: ") + "Set up the LeSync database at URL. +Install USER as a READER and/or an ADMIN in the security object +under \"_security\", and in the CouchDB \"_users\" table using +PASSWORD and SALT. Only one USER is thus supported for now. +When SALT is nil, a random one will be generated using `random'." + (let* ((design-url (concat url gnus-sync-lesync-design-prefix)) + (security-object (concat url "/_security")) + (user-record `((names . [,user]) (roles . []))) + (couch-user-name (format "org.couchdb.user:%s" user)) + (salt (or salt (sha1 (format "%s" (random t))))) + (couch-user-record + `((_id . ,couch-user-name) + (type . user) + (name . ,(format "%s" user)) + (roles . []) + (salt . ,salt) + (password_sha . ,(when password + (sha1 + (format "%s%s" password salt)))))) + (rev (progn + (gnus-sync-lesync-find-prop 'rev design-url design-url) + (gnus-sync-lesync-get-prop 'rev design-url))) + (latest-func "function(head,req) +{ + var tosend = []; + var row; + var ftime = (req.query['ftime'] || 0); + while (row = getRow()) + { + if (row.value['float-time'] > ftime) + { + var s = row.value['_id']; + if (s) tosend.push('\"'+s.replace('\"', '\\\"')+'\"'); + } + } + send('['+tosend.join(',') + ']'); +}") +;; <key>read</key> +;; <dict> +;; <key>de.alt.fan.ipod</key> +;; <array> +;; <integer>1</integer> +;; <integer>2</integer> +;; <dict> +;; <key>start</key> +;; <integer>100</integer> +;; <key>length</key> +;; <integer>100</integer> +;; </dict> +;; </array> +;; </dict> + (xmlplistread-func "function(head, req) { + var row; + start({ 'headers': { 'Content-Type': 'text/xml' } }); + + send('<dict>'); + send('<key>read</key>'); + send('<dict>'); + while(row = getRow()) + { + var read = row.value.read; + if (read && read[0] && read[0] == 'invlist') + { + send('<key>'+row.key+'</key>'); + //send('<invlist>'+read+'</invlist>'); + send('<array>'); + + var from = 0; + var flip = false; + + for (var i = 1; i < read.length && read[i]; i++) + { + var cur = read[i]; + if (flip) + { + if (from == cur-1) + { + send('<integer>'+read[i]+'</integer>'); + } + else + { + send('<dict>'); + send('<key>start</key>'); + send('<integer>'+from+'</integer>'); + send('<key>end</key>'); + send('<integer>'+(cur-1)+'</integer>'); + send('</dict>'); + } + + } + flip = ! flip; + from = cur; + } + send('</array>'); + } + } + + send('</dict>'); + send('</dict>'); +} +") + (subs-func "function(doc){emit([doc._id, doc.source], doc._rev);}") + (revs-func "function(doc){emit(doc._id, doc._rev);}") + (bytimesubs-func "function(doc) +{emit([(doc['float-time']||0), doc._id], doc._rev);}") + (bytime-func "function(doc) +{emit([(doc['float-time']||0), doc._id], doc);}") + (groups-func "function(doc){emit(doc._id, doc);}")) + (and (if user + (and (assq 'ok (gnus-sync-lesync-PUT + security-object + nil + (append (and reader + (list `(readers . ,user-record))) + (and admin + (list `(admins . ,user-record)))))) + (assq 'ok (gnus-sync-lesync-PUT + (concat (file-name-directory url) + "_users/" + couch-user-name) + nil + couch-user-record))) + t) + (assq 'ok (gnus-sync-lesync-PUT + design-url + nil + `(,@(when rev (list (cons '_rev rev))) + (lists . ((latest . ,latest-func) + (xmlplistread . ,xmlplistread-func))) + (views . ((subs . ((map . ,subs-func))) + (revs . ((map . ,revs-func))) + (bytimesubs . ((map . ,bytimesubs-func))) + (bytime . ((map . ,bytime-func))) + (groups . ((map . ,groups-func))))))))))) + +(defun gnus-sync-lesync-find-prop (prop url key) + "Retrieve a PROPerty of a document KEY at URL. +Calls `gnus-sync-lesync-set-prop'. +For the 'rev PROP, uses '_rev against the document." + (gnus-sync-lesync-set-prop + prop key (cdr (assq (if (eq prop 'rev) '_rev prop) + (gnus-sync-lesync-GET url nil))))) + +(defun gnus-sync-lesync-set-prop (prop key val) + "Update the PROPerty of document KEY at URL to VAL. +Updates `gnus-sync-lesync-props-hash'." + (puthash (format "%s.%s" key prop) val gnus-sync-lesync-props-hash)) + +(defun gnus-sync-lesync-get-prop (prop key) + "Get the PROPerty of KEY from `gnus-sync-lesync-props-hash'." + (gethash (format "%s.%s" key prop) gnus-sync-lesync-props-hash)) + +(defun gnus-sync-deep-print (data) + (let* ((print-quoted t) + (print-readably t) + (print-escape-multibyte nil) + (print-escape-nonascii t) + (print-length nil) + (print-level nil) + (print-circle nil) + (print-escape-newlines t)) + (format "%S" data))) + +(defun gnus-sync-newsrc-loader-builder (&optional only-modified) + (let* ((entries (cdr gnus-newsrc-alist)) + entry name ret) + (while entries + (setq entry (pop entries) + name (car entry)) + (when (gnus-grep-in-list name gnus-sync-newsrc-groups) + (if only-modified + (when (not (equal (gnus-sync-deep-print entry) + (gnus-sync-lesync-get-prop 'checksum name))) + (gnus-message 9 "%s: add %s, it's modified" + "gnus-sync-newsrc-loader-builder" name) + (push entry ret)) + (push entry ret)))) + ret)) + +; (json-encode (gnus-sync-range2invlist '((1 . 47137) (47139 . 47714) 48129 48211 49231 49281 49342 49473 49475 49502))) +(defun gnus-sync-range2invlist (ranges) + (append '(invlist) + (let ((ranges (delq nil ranges)) + ret range from to) + (while ranges + (setq range (pop ranges)) + (if (atom range) + (setq from range + to range) + (setq from (car range) + to (cdr range))) + (push from ret) + (push (1+ to) ret)) + (reverse ret)))) + +; (let* ((d '((1 . 47137) (47139 . 47714) 48129 48211 49231 49281 49342 49473 49475 49502)) (j (format "%S" (gnus-sync-invlist2range (gnus-sync-range2invlist d))))) (or (equal (format "%S" d) j) j)) +(defun gnus-sync-invlist2range (inv) + (setq inv (append inv nil)) + (if (equal (format "%s" (car inv)) "invlist") + (let ((i (cdr inv)) + (start 0) + ret cur top flip) + (while i + (setq cur (pop i)) + (when flip + (setq top (1- cur)) + (if (= start top) + (push start ret) + (push (cons start top) ret))) + (setq flip (not flip)) + (setq start cur)) + (reverse ret)) + inv)) + +(defun gnus-sync-position (search list &optional test) + "Find the position of SEARCH in LIST using TEST, defaulting to `eq'." + (let ((pos 0) + (test (or test 'eq))) + (while (and list (not (funcall test (car list) search))) + (pop list) + (incf pos)) + (if (funcall test (car list) search) pos nil))) + +(defun gnus-sync-topic-group-position (group topic-name) + (gnus-sync-position + group (cdr (assoc topic-name gnus-topic-alist)) 'equal)) + +(defun gnus-sync-fix-topic-group-position (group topic-name position) + (unless (equal position (gnus-sync-topic-group-position group topic-name)) + (let* ((loc "gnus-sync-fix-topic-group-position") + (groups (delete group (cdr (assoc topic-name gnus-topic-alist)))) + (position (min position (1- (length groups)))) + (old (nth position groups))) + (when (and old (not (equal old group))) + (setf (nth position groups) group) + (setcdr (assoc topic-name gnus-topic-alist) + (append groups (list old))) + (gnus-message 9 "%s: %s moved to %d, swap with %s" + loc group position old))))) + +(defun gnus-sync-lesync-pre-save-group-entry (url nentry &rest passed-props) + (let* ((loc "gnus-sync-lesync-save-group-entry") + (k (car nentry)) + (revision (gnus-sync-lesync-get-prop 'rev k)) + (sname gnus-sync-lesync-name) + (topic (gnus-group-topic k)) + (topic-offset (gnus-sync-topic-group-position k topic)) + (sources (gnus-sync-lesync-get-prop 'source k))) + ;; set the revision so we don't have a conflict + `(,@(when revision + (list (cons '_rev revision))) + (_id . ,k) + ;; the time we saved + ,@passed-props + ;; add our name to the sources list for this key + (source ,@(if (member gnus-sync-lesync-name sources) + sources + (cons gnus-sync-lesync-name sources))) + ,(cons 'level (nth 1 nentry)) + ,@(if topic (list (cons 'topic topic)) nil) + ,@(if topic-offset (list (cons 'topic-offset topic-offset)) nil) + ;; the read marks + ,(cons 'read (gnus-sync-range2invlist (nth 2 nentry))) + ;; the other marks + ,@(delq nil (mapcar (lambda (mark-entry) + (gnus-message 12 "%s: prep param %s in %s" + loc + (car mark-entry) + (nth 3 nentry)) + (if (listp (cdr mark-entry)) + (cons (car mark-entry) + (gnus-sync-range2invlist + (cdr mark-entry))) + (progn ; else this is not a list + (gnus-message 9 "%s: non-list param %s in %s" + loc + (car mark-entry) + (nth 3 nentry)) + nil))) + (nth 3 nentry)))))) + +(defun gnus-sync-lesync-post-save-group-entry (url entry) + (let* ((loc "gnus-sync-lesync-post-save-group-entry") + (k (cdr (assq 'id entry)))) + (cond + ;; success! + ((and (assq 'rev entry) (assq 'id entry)) + (progn + (gnus-sync-lesync-set-prop 'rev k (cdr (assq 'rev entry))) + (gnus-sync-lesync-set-prop 'checksum + k + (gnus-sync-deep-print + (assoc k gnus-newsrc-alist))) + (gnus-message 9 "%s: successfully synced %s to %s" + loc k url))) + ;; specifically check for document conflicts + ((equal "conflict" (format "%s" (cdr-safe (assq 'error entry)))) + (gnus-error + 1 + "%s: use `%s' to resolve the conflict synchronizing %s to %s: %s" + loc "gnus-sync-read" k url (cdr (assq 'reason entry)))) + ;; generic errors + ((assq 'error entry) + (gnus-error 1 "%s: got error while synchronizing %s to %s: %s" + loc k url (cdr (assq 'reason entry)))) + + (t + (gnus-message 2 "%s: unknown sync status after %s to %s: %S" + loc k url entry))) + (assoc 'error entry))) + +(defun gnus-sync-lesync-groups-builder (url) + (let ((u (concat url gnus-sync-lesync-design-prefix "/_view/groups"))) + (cdr (assq 'rows (gnus-sync-lesync-GET u nil))))) + +(defun gnus-sync-subscribe-group (name) + "Subscribe to group NAME. Returns NAME on success, nil otherwise." + (gnus-subscribe-newsgroup name)) + +(defun gnus-sync-lesync-read-group-entry (url name entry &rest passed-props) + "Read ENTRY information for NAME. Returns NAME if successful. +Skips entries whose sources don't contain +`gnus-sync-lesync-name'. When the alist PASSED-PROPS has a +`subscribe-all' element that evaluates to true, we attempt to +subscribe to unknown groups. The user is also allowed to delete +unwanted groups via the LeSync URL." + (let* ((loc "gnus-sync-lesync-read-group-entry") + (entry (gnus-sync-lesync-normalize-group-entry entry passed-props)) + (subscribe-all (cdr (assq 'subscribe-all passed-props))) + (sources (cdr (assq 'source entry))) + (rev (cdr (assq 'rev entry))) + (in-sources (member gnus-sync-lesync-name sources)) + (known (assoc name gnus-newsrc-alist)) + cell) + (unless known + (if (and subscribe-all + (y-or-n-p (format "Subscribe to group %s?" name))) + (setq known (gnus-sync-subscribe-group name) + in-sources t) + ;; else... + (when (y-or-n-p (format "Delete group %s from server?" name)) + (if (equal name (gnus-sync-lesync-delete-group url name)) + (gnus-message 1 "%s: removed group %s from server %s" + loc name url) + (gnus-error 1 "%s: could not remove group %s from server %s" + loc name url))))) + (when known + (unless in-sources + (setq in-sources + (y-or-n-p + (format "Read group %s even though %s is not in sources %S?" + name gnus-sync-lesync-name (or sources "")))))) + (when rev + (gnus-sync-lesync-set-prop 'rev name rev)) + + ;; if the source matches AND we have this group + (if (and known in-sources) + (progn + (gnus-message 10 "%s: reading LeSync entry %s, sources %S" + loc name sources) + (while entry + (setq cell (pop entry)) + (let ((k (car cell)) + (val (cdr cell))) + (gnus-sync-lesync-set-prop k name val))) + name) + ;; else... + (unless known + (gnus-message 5 "%s: ignoring entry %s, it wasn't subscribed. %s" + loc name "Call `gnus-sync-read' with C-u to force it.")) + (unless in-sources + (gnus-message 5 "%s: ignoring entry %s, %s not in sources %S" + loc name gnus-sync-lesync-name (or sources ""))) + nil))) + +(defun gnus-sync-lesync-install-group-entry (name) + (let* ((master (assoc name gnus-newsrc-alist)) + (old-topic-name (gnus-group-topic name)) + (old-topic (assoc old-topic-name gnus-topic-alist)) + (target-topic-name (gnus-sync-lesync-get-prop 'topic name)) + (target-topic-offset (gnus-sync-lesync-get-prop 'topic-offset name)) + (target-topic (assoc target-topic-name gnus-topic-alist)) + (loc "gnus-sync-lesync-install-group-entry")) + (if master + (progn + (when (eq 'ask gnus-sync-lesync-install-topics) + (setq gnus-sync-lesync-install-topics + (y-or-n-p "Install topics from LeSync?"))) + (when (and (eq t gnus-sync-lesync-install-topics) + target-topic-name) + (if (equal old-topic-name target-topic-name) + (gnus-message 12 "%s: %s is already in topic %s" + loc name target-topic-name) + ;; see `gnus-topic-move-group' + (when (and old-topic target-topic) + (setcdr old-topic (gnus-delete-first name (cdr old-topic))) + (gnus-message 5 "%s: removing %s from topic %s" + loc name old-topic-name)) + (unless target-topic + (when (y-or-n-p (format "Create missing topic %s?" + target-topic-name)) + (gnus-topic-create-topic target-topic-name nil) + (setq target-topic (assoc target-topic-name + gnus-topic-alist)))) + (if target-topic + (prog1 + (nconc target-topic (list name)) + (gnus-message 5 "%s: adding %s to topic %s" + loc name (car target-topic)) + (gnus-topic-enter-dribble)) + (gnus-error 2 "%s: LeSync group %s can't go in missing topic %s" + loc name target-topic-name))) + (when (and target-topic-offset target-topic) + (gnus-sync-fix-topic-group-position + name target-topic-name target-topic-offset))) + ;; install the subscription level + (when (gnus-sync-lesync-get-prop 'level name) + (setf (nth 1 master) (gnus-sync-lesync-get-prop 'level name))) + ;; install the read and other marks + (setf (nth 2 master) (gnus-sync-lesync-get-prop 'read name)) + (setf (nth 3 master) (gnus-sync-lesync-get-prop 'marks name)) + (gnus-sync-lesync-set-prop 'checksum + name + (gnus-sync-deep-print master)) + nil) + (gnus-error 1 "%s: invalid LeSync group %s" loc name) + 'invalid-name))) + +; (gnus-sync-lesync-delete-group (cdr gnus-sync-backend) "nntp+Gmane:gwene.org.slashdot") + +(defun gnus-sync-lesync-delete-group (url name) + "Returns NAME if successful deleting it from URL, an error otherwise." + (interactive "sEnter URL to set up: \rsEnter group name: ") + (let* ((u (concat (cadr gnus-sync-backend) "/" (url-hexify-string name))) + (del (gnus-sync-lesync-DELETE + u + `(,@(when (gnus-sync-lesync-get-prop 'rev name) + (list (cons "If-Match" + (gnus-sync-lesync-get-prop 'rev name)))))))) + (or (cdr (assq 'id del)) del))) + +;;; (gnus-sync-lesync-normalize-group-entry '((subscribe . ["invlist"]) (read . ["invlist"]) (topic-offset . 20) (topic . "news") (level . 6) (source . ["a" "b"]) (float-time . 1319671237.099285) (_rev . "10-edf5107f41e5e6f7f6629d1c0ee172f7") (_id . "nntp+news.net:alt.movies")) '((read-time 1319672156.486414) (subscribe-all nil))) + +(defun gnus-sync-lesync-normalize-group-entry (entry &optional passed-props) + (let (ret + marks + cell) + (setq entry (append passed-props entry)) + (while (setq cell (pop entry)) + (let ((k (car cell)) + (val (cdr cell))) + (cond + ((eq k 'read) + (push (cons k (gnus-sync-invlist2range val)) ret)) + ;; we ignore these parameters + ((member k '(_id subscribe-all _deleted_conflicts)) + nil) + ((eq k '_rev) + (push (cons 'rev val) ret)) + ((eq k 'source) + (push (cons 'source (append val nil)) ret)) + ((or (eq k 'float-time) + (eq k 'level) + (eq k 'topic) + (eq k 'topic-offset) + (eq k 'read-time)) + (push (cons k val) ret)) +;;; "How often have I said to you that when you have eliminated the +;;; impossible, whatever remains, however improbable, must be the +;;; truth?" --Sherlock Holmes + ;; everything remaining must be a mark + (t (push (cons k (gnus-sync-invlist2range val)) marks))))) + (cons (cons 'marks marks) ret))) + +(defun gnus-sync-save (&optional force) +"Save the Gnus sync data to the backend. +With a prefix, FORCE is set and all groups will be saved." + (interactive "P") (cond + ((and (listp gnus-sync-backend) + (eq (nth 0 gnus-sync-backend) 'lesync) + (stringp (nth 1 gnus-sync-backend))) + + ;; refresh the revisions if we're forcing the save + (when force + (mapc (lambda (entry) + (when (and (assq 'key entry) + (assq 'value entry)) + (gnus-sync-lesync-set-prop + 'rev + (cdr (assq 'key entry)) + (cdr (assq 'value entry))))) + ;; the revs view is key = name, value = rev + (cdr (assq 'rows (gnus-sync-lesync-GET + (concat (nth 1 gnus-sync-backend) + gnus-sync-lesync-design-prefix + "/_view/revs") + nil))))) + + (let* ((ftime (float-time)) + (url (nth 1 gnus-sync-backend)) + (entries + (mapcar (lambda (entry) + (gnus-sync-lesync-pre-save-group-entry + (cadr gnus-sync-backend) + entry + (cons 'float-time ftime))) + (gnus-sync-newsrc-loader-builder (not force)))) + ;; when there are no entries, there's nothing to save + (sync (if entries + (gnus-sync-lesync-POST + (concat url "/_bulk_docs") + '(("Content-Type" . "application/json")) + `((docs . ,(vconcat entries nil)))) + (gnus-message + 2 "gnus-sync-save: nothing to save to the LeSync backend") + nil))) + (mapcar (lambda (e) (gnus-sync-lesync-post-save-group-entry url e)) + sync))) ((stringp gnus-sync-backend) - (gnus-message 7 "gnus-sync: saving to backend %s" gnus-sync-backend) + (gnus-message 7 "gnus-sync-save: saving to backend %s" gnus-sync-backend) ;; populate gnus-sync-newsrc-loader from all but the first dummy ;; entry in gnus-newsrc-alist whose group matches any of the ;; gnus-sync-newsrc-groups ;; TODO: keep the old contents for groups we don't have! - (let ((gnus-sync-newsrc-loader - (loop for entry in (cdr gnus-newsrc-alist) - when (gnus-grep-in-list - (car entry) ;the group name - gnus-sync-newsrc-groups) - collect (cons (car entry) - (mapcar (lambda (offset) - (cons offset (nth offset entry))) - gnus-sync-newsrc-offsets))))) + (let ((gnus-sync-newsrc-loader (gnus-sync-newsrc-loader-builder))) (with-temp-file gnus-sync-backend (progn (let ((coding-system-for-write gnus-ding-file-coding-system) @@ -123,6 +760,7 @@ synchronized, I believe). Also see `gnus-variable-list'." (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" gnus-ding-file-coding-system)) (princ ";; Gnus sync data v. 0.0.1\n") + ;; TODO: replace with `gnus-sync-deep-print' (let* ((print-quoted t) (print-readably t) (print-escape-multibyte nil) @@ -147,14 +785,14 @@ synchronized, I believe). Also see `gnus-variable-list'." (princ (symbol-name variable))))) (gnus-message 7 - "gnus-sync: stored variables %s and %d groups in %s" + "gnus-sync-save: stored variables %s and %d groups in %s" gnus-sync-global-vars (length gnus-sync-newsrc-loader) gnus-sync-backend) ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> ;; Save the .eld file with extra line breaks. - (gnus-message 8 "gnus-sync: adding whitespace to %s" + (gnus-message 8 "gnus-sync-save: adding whitespace to %s" gnus-sync-backend) (save-excursion (goto-char (point-min)) @@ -166,49 +804,74 @@ synchronized, I believe). Also see `gnus-variable-list'." ;; the pass-through case: gnus-sync-backend is not a known choice (nil))) -(defun gnus-sync-read () -"Load the Gnus sync data from the backend." - (interactive) +(defun gnus-sync-read (&optional subscribe-all) + "Load the Gnus sync data from the backend. +With a prefix, SUBSCRIBE-ALL is set and unknown groups will be subscribed." + (interactive "P") (when gnus-sync-backend - (gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend) - (cond ((stringp gnus-sync-backend) - ;; read data here... - (if (or debug-on-error debug-on-quit) - (load gnus-sync-backend nil t) - (condition-case var - (load gnus-sync-backend nil t) - (error - (error "Error in %s: %s" gnus-sync-backend (cadr var))))) - (let ((valid-count 0) - invalid-groups) - (dolist (node gnus-sync-newsrc-loader) - (if (gnus-gethash (car node) gnus-newsrc-hashtb) - (progn - (incf valid-count) - (loop for store in (cdr node) - do (setf (nth (car store) - (assoc (car node) gnus-newsrc-alist)) - (cdr store)))) - (push (car node) invalid-groups))) - (gnus-message - 7 - "gnus-sync: loaded %d groups (out of %d) from %s" - valid-count (length gnus-sync-newsrc-loader) - gnus-sync-backend) - (when invalid-groups - (gnus-message - 7 - "gnus-sync: skipped %d groups (out of %d) from %s" - (length invalid-groups) - (length gnus-sync-newsrc-loader) - gnus-sync-backend) - (gnus-message 9 "gnus-sync: skipped groups: %s" - (mapconcat 'identity invalid-groups ", "))))) - (nil)) - ;; make the hashtable again because the newsrc-alist may have been modified - (when gnus-sync-newsrc-offsets - (gnus-message 9 "gnus-sync: remaking the newsrc hashtable") - (gnus-make-hashtable-from-newsrc-alist)))) + (gnus-message 7 "gnus-sync-read: loading from backend %s" gnus-sync-backend) + (cond + ((and (listp gnus-sync-backend) + (eq (nth 0 gnus-sync-backend) 'lesync) + (stringp (nth 1 gnus-sync-backend))) + (let ((errored nil) + name ftime) + (mapc (lambda (entry) + (setq name (cdr (assq 'id entry))) + ;; set ftime the FIRST time through this loop, that + ;; way it reflects the time we FINISHED reading + (unless ftime (setq ftime (float-time))) + + (unless errored + (setq errored + (when (equal name + (gnus-sync-lesync-read-group-entry + (nth 1 gnus-sync-backend) + name + (cdr (assq 'value entry)) + `(read-time ,ftime) + `(subscribe-all ,subscribe-all))) + (gnus-sync-lesync-install-group-entry + (cdr (assq 'id entry))))))) + (gnus-sync-lesync-groups-builder (nth 1 gnus-sync-backend))))) + + ((stringp gnus-sync-backend) + ;; read data here... + (if (or debug-on-error debug-on-quit) + (load gnus-sync-backend nil t) + (condition-case var + (load gnus-sync-backend nil t) + (error + (error "Error in %s: %s" gnus-sync-backend (cadr var))))) + (let ((valid-count 0) + invalid-groups) + (dolist (node gnus-sync-newsrc-loader) + (if (gnus-gethash (car node) gnus-newsrc-hashtb) + (progn + (incf valid-count) + (loop for store in (cdr node) + do (setf (nth (car store) + (assoc (car node) gnus-newsrc-alist)) + (cdr store)))) + (push (car node) invalid-groups))) + (gnus-message + 7 + "gnus-sync-read: loaded %d groups (out of %d) from %s" + valid-count (length gnus-sync-newsrc-loader) + gnus-sync-backend) + (when invalid-groups + (gnus-message + 7 + "gnus-sync-read: skipped %d groups (out of %d) from %s" + (length invalid-groups) + (length gnus-sync-newsrc-loader) + gnus-sync-backend) + (gnus-message 9 "gnus-sync-read: skipped groups: %s" + (mapconcat 'identity invalid-groups ", "))))) + (nil)) + + (gnus-message 9 "gnus-sync-read: remaking the newsrc hashtable") + (gnus-make-hashtable-from-newsrc-alist))) ;;;###autoload (defun gnus-sync-initialize () @@ -228,14 +891,11 @@ synchronized, I believe). Also see `gnus-variable-list'." (defun gnus-sync-unload-hook () "Uninstall the sync hooks." (interactive) - (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read) - (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) + (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)) (add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook) -;; this is harmless by default, until the gnus-sync-backend is set -(gnus-sync-initialize) +(when gnus-sync-backend (gnus-sync-initialize)) (provide 'gnus-sync) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index da899f4bf10..072e7b5822a 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -169,15 +169,6 @@ This is a compatibility function for different Emacsen." `(delete-region (point-at-bol) (progn (forward-line ,(or n 1)) (point)))) -(defun gnus-byte-code (func) - "Return a form that can be `eval'ed based on FUNC." - (let ((fval (indirect-function func))) - (if (byte-code-function-p fval) - (let ((flist (append fval nil))) - (setcar flist 'byte-code) - flist) - (cons 'progn (cddr fval))))) - (defun gnus-extract-address-components (from) "Extract address components from a From header. Given an RFC-822 address FROM, extract full name and canonical address. @@ -1927,6 +1918,19 @@ Sizes are in pixels." image))) image))) +(defun gnus-recursive-directory-files (dir) + "Return all regular files below DIR." + (let (files) + (dolist (file (directory-files dir t)) + (when (and (not (member (file-name-nondirectory file) '("." ".."))) + (file-readable-p file)) + (cond + ((file-regular-p file) + (push file files)) + ((file-directory-p file) + (setq files (append (gnus-recursive-directory-files file) files)))))) + files)) + (defun gnus-list-memq-of-list (elements list) "Return non-nil if any of the members of ELEMENTS are in LIST." (let ((found nil)) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 579210c6138..bd9ea10fdc4 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -239,7 +239,8 @@ See the Gnus manual for an explanation of the syntax used.") (defun gnus-configure-frame (split &optional window) "Split WINDOW according to SPLIT." - (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window))) + (let* ((current-window (or (get-buffer-window (current-buffer)) + (selected-window))) (window (or window current-window))) (select-window window) ;; The SPLIT might be something that is to be evalled to @@ -269,9 +270,23 @@ See the Gnus manual for an explanation of the syntax used.") (let ((buf (gnus-get-buffer-create (gnus-window-to-buffer-helper buffer)))) (when (buffer-name buf) - (if (eq buf (window-buffer (selected-window))) - (set-buffer buf) - (switch-to-buffer buf)))) + (cond + ((eq buf (window-buffer (selected-window))) + (set-buffer buf)) + ((eq t (window-dedicated-p + ;; XEmacs version of `window-dedicated-p' requires it. + (selected-window))) + ;; If the window is hard-dedicated, we have a problem because + ;; we just can't do what we're asked. But signaling an error, + ;; like `switch-to-buffer' would do, is not an option because + ;; it would prevent things like "^" (to jump to the *Servers*) + ;; in a dedicated *Group*. + ;; FIXME: Maybe a better/additional fix would be to change + ;; gnus-configure-windows so that when called + ;; from a hard-dedicated frame, it creates (and + ;; configures) a new frame, leaving the dedicated frame alone. + (pop-to-buffer buf)) + (t (switch-to-buffer buf))))) (when (memq 'frame-focus split) (setq gnus-window-frame-focus window)) ;; We return the window if it has the `point' spec. @@ -340,9 +355,9 @@ See the Gnus manual for an explanation of the syntax used.") ;; fashion. (setq comp-subs (nreverse comp-subs)) (while comp-subs - (if (null (cdr comp-subs)) - (setq new-win window) - (setq new-win + (setq new-win + (if (null (cdr comp-subs)) + window (split-window window (cadar comp-subs) (eq type 'horizontal)))) (setq result (or (gnus-configure-frame diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 635bb6fc96f..a605f483ea4 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1009,10 +1009,11 @@ be set in `.emacs' instead." (purp "#9999cc" "#666699") (no "#ff0000" "#ffff00") (neutral "#b4b4b4" "#878787") + (ma "#2020e0" "#8080ff") (september "#bf9900" "#ffcc00")) "Color alist used for the Gnus logo.") -(defcustom gnus-logo-color-style 'no +(defcustom gnus-logo-color-style 'ma "*Color styles used for the Gnus logo." :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) gnus-logo-color-alist)) @@ -1271,15 +1272,18 @@ Set this variable in `.emacs' instead." :type '(choice (const :tag "current" nil) directory)) -;; Site dependent variables. These variables should be defined in -;; paths.el. +;; Site dependent variables. -(defvar gnus-default-nntp-server nil - "Specify a default NNTP server. -This variable should be defined in paths.el, and should never be set -by the user. -If you want to change servers, you should use `gnus-select-method'. -See the documentation to that variable.") +;; Should this be obsolete? +(defcustom gnus-default-nntp-server nil + "The hostname of the default NNTP server. +The empty string, or nil, means to use the local host. +You may wish to set this on a site-wide basis. + +If you want to change servers, you should use `gnus-select-method'." + :group 'gnus-server + :type '(choice (const :tag "local host" nil) + (string :tag "host name"))) (defcustom gnus-nntpserver-file "/etc/nntpserver" "A file with only the name of the nntp server in it." @@ -1326,6 +1330,8 @@ If you use this variable, you must set `gnus-nntp-server' to nil. There is a lot more to know about select methods and virtual servers - see the manual for details." + ;; Emacs has set-after since 22.1. + ;set-after '(gnus-default-nntp-server) :group 'gnus-server :group 'gnus-start :initialize 'custom-initialize-default @@ -2798,6 +2804,8 @@ gnus-registry.el will populate this if it's loaded.") ("gnus-kill" gnus-kill gnus-apply-kill-file-internal gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author gnus-execute gnus-expunge gnus-batch-kill gnus-batch-score) + ("gnus-registry" gnus-try-warping-via-registry + gnus-registry-handle-action) ("gnus-cache" gnus-cache-possibly-enter-article gnus-cache-save-buffers gnus-cache-possibly-remove-articles gnus-cache-request-article gnus-cache-retrieve-headers gnus-cache-possibly-alter-active diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el index afbebbff79f..ecde35dca8f 100644 --- a/lisp/gnus/legacy-gnus-agent.el +++ b/lisp/gnus/legacy-gnus-agent.el @@ -206,29 +206,31 @@ converted to the compressed format." (gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t) (defun gnus-agent-unhook-expire-days (converting-to) - "Remove every lambda from gnus-group-prepare-hook that mention the -symbol gnus-agent-do-once in their definition. This should NOT be + "Remove every lambda from `gnus-group-prepare-hook' that mention the +symbol `gnus-agent-do-once' in their definition. This should NOT be necessary as gnus-agent.el no longer adds them. However, it is possible that the hook was persistently saved." - (let ((h t)) ; iterate from bgn of hook + (let ((h t)) ; Iterate from bgn of hook. (while h (let ((func (progn (when (eq h t) - ;; init h to list of functions + ;; Init h to list of functions. (setq h (cond ((listp gnus-group-prepare-hook) gnus-group-prepare-hook) ((boundp 'gnus-group-prepare-hook) (list gnus-group-prepare-hook))))) (pop h)))) - (when (cond ((eq (type-of func) 'compiled-function) - ;; Search def. of compiled function for gnus-agent-do-once string + (when (cond ((byte-code-function-p func) + ;; Search def. of compiled function for + ;; gnus-agent-do-once string. (let* (definition print-level print-length (standard-output (lambda (char) (setq definition (cons char definition))))) - (princ func) ; populates definition with reversed list of characters + (princ func) ; Populates definition with reversed list + ; of characters. (let* ((i (length definition)) (s (make-string i 0))) (while definition @@ -236,7 +238,7 @@ possible that the hook was persistently saved." (string-match "\\bgnus-agent-do-once\\b" s)))) ((listp func) - (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; handles eval'd lambda + (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; Handles eval'd lambda. )) (remove-hook 'gnus-group-prepare-hook func) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 4ce9279114b..21ce9e4a873 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -3057,66 +3057,79 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (defun message-goto-to () "Move point to the To header." (interactive) + (push-mark) (message-position-on-field "To")) (defun message-goto-from () "Move point to the From header." (interactive) + (push-mark) (message-position-on-field "From")) (defun message-goto-subject () "Move point to the Subject header." (interactive) + (push-mark) (message-position-on-field "Subject")) (defun message-goto-cc () "Move point to the Cc header." (interactive) + (push-mark) (message-position-on-field "Cc" "To")) (defun message-goto-bcc () "Move point to the Bcc header." (interactive) + (push-mark) (message-position-on-field "Bcc" "Cc" "To")) (defun message-goto-fcc () "Move point to the Fcc header." (interactive) + (push-mark) (message-position-on-field "Fcc" "To" "Newsgroups")) (defun message-goto-reply-to () "Move point to the Reply-To header." (interactive) + (push-mark) (message-position-on-field "Reply-To" "Subject")) (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) + (push-mark) (message-position-on-field "Newsgroups")) (defun message-goto-distribution () "Move point to the Distribution header." (interactive) + (push-mark) (message-position-on-field "Distribution")) (defun message-goto-followup-to () "Move point to the Followup-To header." (interactive) + (push-mark) (message-position-on-field "Followup-To" "Newsgroups")) (defun message-goto-mail-followup-to () "Move point to the Mail-Followup-To header." (interactive) + (push-mark) (message-position-on-field "Mail-Followup-To" "To")) (defun message-goto-keywords () "Move point to the Keywords header." (interactive) + (push-mark) (message-position-on-field "Keywords" "Subject")) (defun message-goto-summary () "Move point to the Summary header." (interactive) + (push-mark) (message-position-on-field "Summary" "Subject")) (eval-when-compile @@ -3137,6 +3150,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (when (and (message-called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) + (push-mark) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) @@ -3157,6 +3171,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." If there is no signature in the article, go to the end and return nil." (interactive) + (push-mark) (goto-char (point-min)) (if (re-search-forward message-signature-separator nil t) (forward-line 1) @@ -3796,7 +3811,7 @@ prefix, and don't delete any headers." (save-current-buffer (dolist (buffer (buffer-list t)) (set-buffer buffer) - (when (and (eq major-mode 'message-mode) + (when (and (derived-mode-p 'message-mode) (null message-sent-message-via)) (push (buffer-name buffer) buffers)))) (nreverse buffers))) @@ -4479,8 +4494,9 @@ This function could be useful in `message-setup-hook'." (end-of-line) (insert (format " (%d/%d)" n total)) (widen) - (funcall (or message-send-mail-real-function - message-send-mail-function))) + (if message-send-mail-real-function + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) @@ -4634,8 +4650,9 @@ If you always want Gnus to send messages in one piece, set "))) (progn (message "Sending via mail...") - (funcall (or message-send-mail-real-function - message-send-mail-function))) + (if message-send-mail-real-function + (funcall message-send-mail-real-function) + (message-multi-smtp-send-mail))) (message-send-mail-partially)) (setq options message-options)) (kill-buffer tembuf)) @@ -4644,6 +4661,28 @@ If you always want Gnus to send messages in one piece, set (push 'mail message-sent-message-via))) (defvar sendmail-program) +(defvar smtpmail-smtp-user) + +(defun message-multi-smtp-send-mail () + "Send the current buffer to `message-send-mail-function'. +Or, if there's a header that specifies a different method, use +that instead." + (let ((method (message-field-value "X-Message-SMTP-Method"))) + (if (not method) + (funcall message-send-mail-function) + (message-remove-header "X-Message-SMTP-Method") + (setq method (split-string method)) + (cond + ((equal (car method) "sendmail") + (message-send-mail-with-sendmail)) + ((equal (car method) "smtp") + (require 'smtpmail) + (let ((smtpmail-smtp-server (nth 1 method)) + (smtpmail-smtp-service (nth 2 method)) + (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) + (message-smtpmail-send-it))) + (t + (error "Unknown method %s" method)))))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." @@ -7530,7 +7569,7 @@ is for the internal use." (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) - beg) + gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) (set-buffer (get-buffer-create " *message resend*")) @@ -7543,6 +7582,8 @@ is for the internal use." ;; Insert our usual headers. (message-generate-headers '(From Date To Message-ID)) (message-narrow-to-headers) + (when (setq gcc (mail-fetch-field "gcc" nil t)) + (message-remove-header "gcc")) ;; Remove X-Draft-From header etc. (message-remove-header message-ignored-mail-headers t) ;; Rename them all to "Resent-*". @@ -7584,6 +7625,10 @@ is for the internal use." message-generate-hashcash rfc2047-encode-encoded-words) (message-send-mail)) + (when gcc + (message-goto-eoh) + (insert "Gcc: " gcc "\n")) + (run-hooks 'message-sent-hook) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el new file mode 100644 index 00000000000..7cfa4659fd9 --- /dev/null +++ b/lisp/gnus/mm-archive.el @@ -0,0 +1,107 @@ +;;; 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: + +(require 'mm-decode) +(eval-when-compile + (autoload 'gnus-recursive-directory-files "gnus-util") + (autoload 'mailcap-extension-to-mime "mailcap")) + +(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-archive-decoders () mm-archive-decoders) + +(defun mm-dissect-archive (handle) + (let ((decoder (cddr (assoc (car (mm-handle-type handle)) + mm-archive-decoders))) + (dir (mm-make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) + (set-file-modes dir #o700) + (unwind-protect + (progn + (mm-with-unibyte-buffer + (mm-insert-part handle) + (if (member "%f" decoder) + (let ((file (expand-file-name "mail.zip" dir))) + (write-region (point-min) (point-max) file nil 'silent) + (setq decoder (copy-sequence decoder)) + (setcar (member "%f" decoder) file) + (apply 'call-process (car decoder) nil nil nil + (append (cdr decoder) (list dir))) + (delete-file file)) + (apply 'call-process-region (point-min) (point-max) (car decoder) + nil (get-buffer-create "*tnef*") + nil (append (cdr decoder) (list dir))))) + `("multipart/mixed" + ,handle + ,@(mm-archive-list-files (gnus-recursive-directory-files dir)))) + (delete-directory dir t)))) + +(defun mm-archive-list-files (files) + (let ((handles nil) + type disposition) + (dolist (file files) + (with-temp-buffer + (when (string-match "\\.\\([^.]+\\)$" file) + (setq type (mailcap-extension-to-mime (match-string 1 file)))) + (unless type + (setq type "application/octet-stream")) + (setq disposition + (if (string-match "^image/\\|^text/" type) + "inline" + "attachment")) + (insert (format "Content-type: %s\n" type)) + (insert "Content-Transfer-Encoding: 8bit\n\n") + (insert-file-contents file) + (push + (mm-make-handle (mm-copy-to-buffer) + (list type) + '8bit nil + `(,disposition (filename . ,file)) + nil nil nil) + handles))) + handles)) + +(defun mm-archive-dissect-and-inline (handle) + (let ((start (point-marker))) + (save-restriction + (narrow-to-region (point) (point)) + (dolist (handle (cddr (mm-dissect-archive handle))) + (goto-char (point-max)) + (mm-display-inline handle)) + (goto-char (point-max)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t) + (end ,(point-marker))) + (remove-images ,start end) + (delete-region ,start end))))))) + +(provide 'mm-archive) + +;; mm-archive.el ends here diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 4a6da2d437c..d0401bc9de3 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -41,6 +41,10 @@ (autoload 'mm-extern-cache-contents "mm-extern") (autoload 'mm-insert-inline "mm-view") +(autoload 'mm-archive-decoders "mm-archive") +(autoload 'mm-archive-dissect-and-inline "mm-archive") +(autoload 'mm-dissect-archive "mm-archive") + (defvar gnus-current-window-configuration) (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list) @@ -248,6 +252,8 @@ before the external MIME handler is invoked." ("message/partial" mm-inline-partial identity) ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) + ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity) + ("application/zip" mm-archive-dissect-and-inline identity) ("audio/wav" mm-inline-audio (lambda (handle) (and (or (featurep 'nas-sound) (featurep 'native-sound)) @@ -275,7 +281,8 @@ before the external MIME handler is invoked." (ignore-errors (if (fboundp 'create-image) (create-image (buffer-string) 'imagemagick 'data-p) - (mm-create-image-xemacs (mm-handle-media-subtype handle)))))) + (mm-create-image-xemacs + (mm-handle-media-subtype handle)))))) (when image (setcar (cdr handle) (list "image/imagemagick")) (mm-image-fit-p handle))))))) @@ -297,6 +304,9 @@ before the external MIME handler is invoked." "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" + "application/x-gtar-compressed" + "application/x-tar" + "application/zip" ;; Mutt still uses this even though it has already been withdrawn. "application/pgp") "List of media types that are to be displayed inline. @@ -448,6 +458,7 @@ If not set, `default-directory' will be used." (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) (defvar mm-postponed-undisplay-list nil) +(defvar mm-inhibit-auto-detect-attachment nil) ;; According to RFC2046, in particular, in a digest, the default ;; Content-Type value for a body part is changed from "text/plain" to @@ -567,7 +578,9 @@ Postpone undisplaying of viewers for types in (autoload 'message-fetch-field "message") (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from) - "Dissect the current buffer and return a list of MIME handles." + "Dissect the current buffer and return a list of MIME handles. +If NO-STRICT-MIME, don't require the message to have a +MIME-Version header before proceeding." (save-excursion (let (ct ctl type subtype cte cd description id result) (save-restriction @@ -653,8 +666,26 @@ Postpone undisplaying of viewers for types in (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) + ;; Guess what the type of application/octet-stream parts should + ;; really be. + (let ((filename (cdr (assq 'filename (cdr cdl))))) + (when (and (not mm-inhibit-auto-detect-attachment) + (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)) @@ -665,7 +696,9 @@ Postpone undisplaying of viewers for types in (goto-char (point-max)) (if (re-search-backward close-delimiter nil t) (match-beginning 0) - (point-max))))) + (point-max)))) + (mm-inhibit-auto-detect-attachment + (equal (car ctl) "multipart/encrypted"))) (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) (while (and (< (point) end) (re-search-forward boundary end t)) (goto-char (match-beginning 0)) @@ -736,23 +769,29 @@ external if displayed external." (mail-content-type-get (mm-handle-type handle) 'name) "<file>")) - (external mm-enable-external)) - (if (and (mm-inlinable-p ehandle) - (mm-inlined-p ehandle)) - (progn - (forward-line 1) - (mm-display-inline handle) - 'inline) - (when (or method - (not no-default)) - (if (and (not method) - (equal "text" (car (split-string type "/")))) - (progn - (forward-line 1) - (mm-insert-inline handle (mm-get-part handle)) - 'inline) - (setq external - (and method ;; If nil, we always use "save". + (external mm-enable-external) + (decoder (assoc (car (mm-handle-type handle)) + (mm-archive-decoders)))) + (cond + ((and decoder + (executable-find (caddr decoder))) + (mm-archive-dissect-and-inline handle) + 'inline) + ((and (mm-inlinable-p ehandle) + (mm-inlined-p ehandle)) + (forward-line 1) + (mm-display-inline handle) + 'inline) + ((or method + (not no-default)) + (if (and (not method) + (equal "text" (car (split-string type "/")))) + (progn + (forward-line 1) + (mm-insert-inline handle (mm-get-part handle)) + 'inline) + (setq external + (and method ;; If nil, we always use "save". (stringp method) ;; 'mailcap-save-binary-file (or (eq mm-enable-external t) (and (eq mm-enable-external 'ask) @@ -765,12 +804,12 @@ external if displayed external." (concat " \"" (format method filename) "\"") "") - "? ")))))) - (if external - (mm-display-external - handle (or method 'mailcap-save-binary-file)) + "? ")))))) + (if external (mm-display-external - handle 'mailcap-save-binary-file))))))))) + handle (or method 'mailcap-save-binary-file)) + (mm-display-external + handle 'mailcap-save-binary-file))))))))) (declare-function gnus-configure-windows "gnus-win" (setting &optional force)) (defvar mailcap-mime-extensions) ; mailcap-mime-info autoloads @@ -918,46 +957,38 @@ external if displayed external." shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) - (lexical-let ;; Don't use `let'. - ;; Function used to remove temp file and directory. - ((fn `(lambda nil - ;; Don't use `ignore-errors'. - (condition-case nil - (delete-file ,file) - (error)) - (condition-case nil - (delete-directory - ,(file-name-directory file)) - (error)))) - ;; Form uses to kill the process buffer and - ;; remove the undisplayer. - (fm `(progn - (kill-buffer ,buffer) - ,(macroexpand - (list 'mm-handle-set-undisplayer - (list 'quote handle) - nil)))) - ;; Message to be issued when the process exits. - (done (format "Displaying %s...done" command)) - ;; In particular, the timer object (which is - ;; a vector in Emacs but is a list in XEmacs) - ;; requires that it is lexically scoped. - (timer (run-at-time 30.0 nil 'ignore))) - (if (featurep 'xemacs) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer itimer-list) - (set-itimer-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer timer-list) - (timer-set-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))))))) + (lexical-let ((outbuf outbuf) + (file file) + (buffer buffer) + (command command) + (handle handle)) + (run-at-time + 30.0 nil + (lambda () + (ignore-errors + (delete-file file)) + (ignore-errors + (delete-directory (file-name-directory file))))) + (lambda (process state) + (when (eq (process-status process) 'exit) + (condition-case nil + (delete-file file) + (error)) + (condition-case nil + (delete-directory (file-name-directory file)) + (error)) + (when (buffer-live-p outbuf) + (with-current-buffer outbuf + (let ((buffer-read-only nil) + (point (point))) + (forward-line 2) + (mm-insert-inline + handle (with-current-buffer buffer + (buffer-string))) + (goto-char point)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))) + (message "Displaying %s...done" command))))) (mm-handle-set-external-undisplayer handle (cons file buffer))) (message "Displaying %s..." command)) @@ -1762,6 +1793,8 @@ If RECURSIVE, search recursively." (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 () @@ -1778,4 +1811,8 @@ If RECURSIVE, search recursively." (provide 'mm-decode) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; mm-decode.el ends here diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index e9119284a04..4fb5ea704bd 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -1592,7 +1592,7 @@ gzip, bzip2, etc. are allowed." (unless filename (setq filename buffer-file-name)) (save-excursion - (let ((decomp (unless ;; No worth to examine charset of tar files. + (let ((decomp (unless ;; Not worth it to examine charset of tar files. (and filename (string-match "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'" diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index a9901d7163e..cc1aedf1b97 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -463,8 +463,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defvar mml-multipart-number 0) (defvar mml-inhibit-compute-boundary nil) -(defun mml-generate-mime () - "Generate a MIME message based on the current MML document." +(defun mml-generate-mime (&optional multipart-type) + "Generate a MIME message based on the current MML document. +MULTIPART-TYPE defaults to \"mixed\", but can also +be \"related\" or \"alternate\"." (let ((cont (mml-parse)) (mml-multipart-number mml-multipart-number) (options message-options)) @@ -476,8 +478,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (if (and (consp (car cont)) (= (length cont) 1)) (mml-generate-mime-1 (car cont)) - (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) - cont))) + (mml-generate-mime-1 + (nconc (list 'multipart (cons 'type (or multipart-type "mixed"))) + cont))) (setq options message-options) (buffer-string)) (setq message-options options))))) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 1800d0c02de..da50720ebbe 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -37,7 +37,8 @@ (require 'mm-util) (eval-when-compile (require 'cl)) -(declare-function nndraft-request-list "nnmh" (&rest args)) +;; The nnoo-import at the end, I think. +(declare-function nndraft-request-list "nndraft" (&rest args) t) (nnoo-declare nndraft nnmh) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 89961dc7dad..e93bd7f43e0 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -2,7 +2,7 @@ ;; 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> @@ -53,10 +53,6 @@ "The name of the nnfolder NOV directory. If nil, `nnfolder-directory' is used.") -(defvoo nnfolder-marks-directory nil - "The name of the nnfolder MARKS directory. -If nil, `nnfolder-directory' is used.") - (defvoo nnfolder-active-file (nnheader-concat nnfolder-directory "active") "The name of the active file.") @@ -134,21 +130,6 @@ all. This may very well take some time.") (defvar nnfolder-nov-buffer-file-name nil) -(defvoo nnfolder-marks-is-evil nil - "If non-nil, Gnus will never generate and use marks file for mail groups. -Using marks files makes it possible to backup and restore mail groups -separately from `.newsrc.eld'. If you have, for some reason, set -this to t, and want to set it to nil again, you should always remove -the corresponding marks file (usually base nnfolder file name -concatenated with `.mrk', but see `nnfolder-marks-file-suffix') for -the group. Then the marks file will be regenerated properly by Gnus.") - -(defvoo nnfolder-marks nil) - -(defvoo nnfolder-marks-file-suffix ".mrk") - -(defvar nnfolder-marks-modtime (gnus-make-hashtable)) - ;;; Interface functions @@ -231,9 +212,6 @@ the group. Then the marks file will be regenerated properly by Gnus.") (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) (and nnfolder-nov-directory (gnus-make-directory nnfolder-nov-directory))) - (unless nnfolder-marks-is-evil - (and nnfolder-marks-directory - (gnus-make-directory nnfolder-marks-directory))) (cond ((not (file-exists-p nnfolder-directory)) (nnfolder-close-server) @@ -607,11 +585,9 @@ the group. Then the marks file will be regenerated properly by Gnus.") () ; Don't delete the articles. ;; Delete the file that holds the group. (let ((data (nnfolder-group-pathname group)) - (nov (nnfolder-group-nov-pathname group)) - (mrk (nnfolder-group-marks-pathname group))) + (nov (nnfolder-group-nov-pathname group))) (ignore-errors (delete-file data)) - (ignore-errors (delete-file nov)) - (ignore-errors (delete-file mrk)))) + (ignore-errors (delete-file nov)))) ;; Remove the group from all structures. (setq nnfolder-group-alist (delq (assoc group nnfolder-group-alist) nnfolder-group-alist) @@ -632,11 +608,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (when (file-exists-p (nnfolder-group-nov-pathname group)) (setq new-file (nnfolder-group-nov-pathname new-name)) (gnus-make-directory (file-name-directory new-file)) - (rename-file (nnfolder-group-nov-pathname group) new-file)) - (when (file-exists-p (nnfolder-group-marks-pathname group)) - (setq new-file (nnfolder-group-marks-pathname new-name)) - (gnus-make-directory (file-name-directory new-file)) - (rename-file (nnfolder-group-marks-pathname group) new-file))) + (rename-file (nnfolder-group-nov-pathname group) new-file))) t) ;; That went ok, so we change the internal structures. (let ((entry (assoc group nnfolder-group-alist))) @@ -1087,16 +1059,17 @@ This command does not work if you use short group names." (defun nnfolder-save-buffer () "Save the buffer." - (when (buffer-modified-p) - (run-hooks 'nnfolder-save-buffer-hook) - (gnus-make-directory (file-name-directory (buffer-file-name))) - (let ((coding-system-for-write - (or nnfolder-file-coding-system-for-write - nnfolder-file-coding-system))) - (set (make-local-variable 'copyright-update) nil) - (save-buffer))) - (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) - (nnfolder-save-nov))) + (let ((delete-old-versions t)) + (when (buffer-modified-p) + (run-hooks 'nnfolder-save-buffer-hook) + (gnus-make-directory (file-name-directory (buffer-file-name))) + (let ((coding-system-for-write + (or nnfolder-file-coding-system-for-write + nnfolder-file-coding-system))) + (set (make-local-variable 'copyright-update) nil) + (save-buffer))) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (nnfolder-save-nov)))) (defun nnfolder-save-active (group-alist active-file) (let ((nnmail-active-file-coding-system @@ -1182,100 +1155,6 @@ This command does not work if you use short group names." (mail-header-set-number headers article) (nnheader-insert-nov headers))) -(deffoo nnfolder-request-set-mark (group actions &optional server) - (when (and server - (not (nnfolder-server-opened server))) - (nnfolder-open-server server)) - (unless nnfolder-marks-is-evil - (nnfolder-open-marks group server) - (setq nnfolder-marks (nnheader-update-marks-actions nnfolder-marks actions)) - (nnfolder-save-marks group server)) - nil) - -(deffoo nnfolder-request-marks (group info &optional server) - ;; Change servers. - (when (and server - (not (nnfolder-server-opened server))) - (nnfolder-open-server server)) - (when (and (not nnfolder-marks-is-evil) (nnfolder-marks-changed-p group)) - (nnheader-message 8 "Updating marks for %s..." group) - (nnfolder-open-marks group server) - ;; Update info using `nnfolder-marks'. - (mapc (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnfolder-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) - (let ((seen (cdr (assq 'read nnfolder-marks)))) - (gnus-info-set-read info - (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen))) - (nnheader-message 8 "Updating marks for %s...done" group)) - info) - -(defun nnfolder-group-marks-pathname (group) - "Make pathname for GROUP NOV." - (let ((nnfolder-directory (or nnfolder-marks-directory nnfolder-directory))) - (concat (nnfolder-group-pathname group) nnfolder-marks-file-suffix))) - -(defun nnfolder-marks-changed-p (group) - (let ((file (nnfolder-group-marks-pathname group))) - (if (null (gnus-gethash file nnfolder-marks-modtime)) - t ;; never looked at marks file, assume it has changed - (not (equal (gnus-gethash file nnfolder-marks-modtime) - (nth 5 (file-attributes file))))))) - -(defun nnfolder-save-marks (group server) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (nnfolder-group-marks-pathname group))) - (condition-case err - (progn - (with-temp-file file - (erase-buffer) - (gnus-prin1 nnfolder-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nnfolder-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nnfolder-open-marks (group server) - (let ((file (nnfolder-group-marks-pathname group))) - (if (file-exists-p file) - (condition-case err - (with-temp-buffer - (gnus-sethash file (nth 5 (file-attributes file)) - nnfolder-marks-modtime) - (nnheader-insert-file-contents file) - (setq nnfolder-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnfolder-marks (gnus-remassoc el nnfolder-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nnfolder marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nnfolder marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - group - (gnus-server-to-method (format "nnfolder:%s" server)))))) - (nnheader-message 7 "Bootstrapping marks for %s..." group) - (setq nnfolder-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nnfolder-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnfolder-marks (gnus-remassoc el nnfolder-marks))) - (nnfolder-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) - (provide 'nnfolder) ;;; nnfolder.el ends here diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index f978b8c9906..5126c25f66b 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -117,7 +117,7 @@ some servers.") (defvoo nnimap-fetch-partial-articles nil "If non-nil, Gnus will fetch partial articles. -If t, nnimap will fetch only the first part. If a string, it +If t, Gnus will fetch only the first part. If a string, it will fetch all parts that have types that match that string. A likely value would be \"text/\" to automatically fetch all textual parts.") @@ -475,6 +475,8 @@ textual parts.") (when nnimap-object (when (nnimap-capability "QRESYNC") (nnimap-command "ENABLE QRESYNC")) + (nnheader-message 7 "Opening connection to %s...done" + nnimap-address) (nnimap-process nnimap-object)))))))) (autoload 'rfc2104-hash "rfc2104") diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 9c3a814d3ea..1645f49091f 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -40,6 +40,8 @@ (autoload 'gnus-add-buffer "gnus") (autoload 'gnus-kill-buffer "gnus") +(eval-when-compile + (autoload 'mail-send-and-exit "sendmail" nil t)) (defgroup nnmail nil "Reading mail with Gnus." @@ -553,11 +555,11 @@ parameter. It should return nil, `warn' or `delete'." (const warn) (const delete))) -(defcustom nnmail-extra-headers '(To Newsgroups) +(defcustom nnmail-extra-headers '(To Newsgroups Cc) "Extra headers to parse. In addition to the standard headers, these extra headers will be included in NOV headers (and the like) when backends parse headers." - :version "21.1" + :version "24.2" :group 'nnmail :type '(repeat symbol)) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index b8652600ae7..600a0d21e3c 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -4,7 +4,7 @@ ;; 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 @@ -67,15 +67,6 @@ the `nnml-generate-nov-databases' command. The function will go through all nnml directories and generate nov databases for them all. This may very well take some time.") -(defvoo nnml-marks-is-evil nil - "If non-nil, Gnus will never generate and use marks file for mail spools. -Using marks files makes it possible to backup and restore mail groups -separately from `.newsrc.eld'. If you have, for some reason, set this -to t, and want to set it to nil again, you should always remove the -corresponding marks file (usually named `.marks' in the nnml group -directory, but see `nnml-marks-file-name') for the group. Then the -marks file will be regenerated properly by Gnus.") - (defvoo nnml-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") @@ -102,7 +93,6 @@ non-nil.") "nnml version.") (defvoo nnml-nov-file-name ".overview") -(defvoo nnml-marks-file-name ".marks") (defvoo nnml-current-directory nil) (defvoo nnml-current-group nil) @@ -118,10 +108,6 @@ non-nil.") (defvoo nnml-file-coding-system nnmail-file-coding-system) -(defvoo nnml-marks nil) - -(defvar nnml-marks-modtime (gnus-make-hashtable)) - ;;; Interface functions. @@ -513,8 +499,7 @@ non-nil.") nnml-current-directory t (concat nnheader-numerical-short-files - "\\|" (regexp-quote nnml-nov-file-name) "$" - "\\|" (regexp-quote nnml-marks-file-name) "$"))) + "\\|" (regexp-quote nnml-nov-file-name) "$"))) (decoded (nnml-decoded-group-name group server))) (dolist (article articles) (when (file-writable-p article) @@ -554,10 +539,6 @@ non-nil.") (let ((overview (concat old-dir nnml-nov-file-name))) (when (file-exists-p overview) (rename-file overview (concat new-dir nnml-nov-file-name)))) - ;; Move .marks file. - (let ((marks (concat old-dir nnml-marks-file-name))) - (when (file-exists-p marks) - (rename-file marks (concat new-dir nnml-marks-file-name)))) (when (<= (length (directory-files old-dir)) 2) (ignore-errors (delete-directory old-dir))) ;; That went ok, so we change the internal structures. @@ -1033,99 +1014,6 @@ Use the nov database for the current group if available." (forward-line 1)) alist)))) -(deffoo nnml-request-set-mark (group actions &optional server) - (nnml-possibly-change-directory group server) - (unless nnml-marks-is-evil - (nnml-open-marks group server) - (setq nnml-marks (nnheader-update-marks-actions nnml-marks actions)) - (nnml-save-marks group server)) - nil) - -(deffoo nnml-request-marks (group info &optional server) - (nnml-possibly-change-directory group server) - (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group server)) - (nnheader-message 8 "Updating marks for %s..." group) - (nnml-open-marks group server) - ;; Update info using `nnml-marks'. - (mapc (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnml-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) - (let ((seen (cdr (assq 'read nnml-marks)))) - (gnus-info-set-read info - (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen))) - (nnheader-message 8 "Updating marks for %s...done" group)) - info) - -(defun nnml-marks-changed-p (group server) - (let ((file (nnml-group-pathname group nnml-marks-file-name server))) - (if (null (gnus-gethash file nnml-marks-modtime)) - t ;; never looked at marks file, assume it has changed - (not (equal (gnus-gethash file nnml-marks-modtime) - (nth 5 (file-attributes file))))))) - -(defun nnml-save-marks (group server) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (nnml-group-pathname group nnml-marks-file-name server))) - (condition-case err - (progn - (nnml-possibly-create-directory group server) - (with-temp-file file - (erase-buffer) - (gnus-prin1 nnml-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nnml-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nnml-open-marks (group server) - (let* ((decoded (nnml-decoded-group-name group server)) - (file (nnmail-group-pathname decoded nnml-directory - nnml-marks-file-name)) - (file-name-coding-system nnmail-pathname-coding-system)) - (if (file-exists-p file) - (condition-case err - (with-temp-buffer - (gnus-sethash file (nth 5 (file-attributes file)) - nnml-marks-modtime) - (nnheader-insert-file-contents file) - (setq nnml-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnml-marks (gnus-remassoc el nnml-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nnml marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nnml marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - group - (gnus-server-to-method - (format "nnml:%s" (or server ""))))))) - (setq decoded (if (member server '(nil "")) - (concat "nnml:" decoded) - (format "nnml+%s:%s" server decoded))) - (nnheader-message 7 "Bootstrapping marks for %s..." decoded) - (setq nnml-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nnml-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnml-marks (gnus-remassoc el nnml-marks))) - (nnml-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" decoded))))) - - ;;; ;;; Group and server compaction. -- dvl ;;; @@ -1275,19 +1163,11 @@ Use the nov database for the current group if available." (gnus-set-active group-full-name active)) ;; 1 bis/ ;; #### NOTE: normally, we should save the overview (NOV) file - ;; #### here, just like we save the marks file. However, there is no - ;; #### such function as nnml-save-nov for a single group. Only for - ;; #### all groups. Gnus inconsistency is getting worse every day... - ;; 2/ Rebuild marks file: - (unless nnml-marks-is-evil - ;; #### NOTE: this constant use of global variables everywhere is - ;; #### truly disgusting. Gnus really needs a *major* cleanup. - (setq nnml-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nnml-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nnml-marks (gnus-remassoc el nnml-marks))) - (nnml-save-marks group server)) - ;; 3/ Save everything if this was not part of a bigger operation: + ;; #### here. However, there is no such function as + ;; #### nnml-save-nov for a single group. Only for all + ;; #### groups. Gnus inconsistency is getting worse every + ;; #### day... ;; 3/ Save everything if this was not part of + ;; #### a bigger operation: (if (not save) ;; Nothing to save (yet): t @@ -1298,9 +1178,6 @@ Use the nov database for the current group if available." (nnml-save-nov) ;; b/ Save the active file: (nnmail-save-active nnml-group-alist nnml-active-file) - (let ((marks (nnml-group-pathname group nnml-marks-file-name server))) - (when (file-exists-p marks) - (delete-file marks))) t))))) (defun nnml-request-compact (&optional server) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 2b024e20740..ad9e9c62d6d 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -31,6 +31,26 @@ (require 'nnoo) (eval-when-compile (require 'cl)) +;; Probably this entire thing should be obsolete. +;; It's only used to init nnspool-spool-directory, so why not just +;; set that variable's default directly? +(eval-and-compile + (defvar news-directory (if (file-exists-p "/usr/spool/news/") + "/usr/spool/news/" + "/var/spool/news/") + "The root directory below which all news files are stored.") + (defvaralias 'news-path 'news-directory)) + +;; Ditto re obsolescence. +(defvar news-inews-program + (cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews") + ((file-exists-p "/usr/local/inews") "/usr/local/inews") + ((file-exists-p "/usr/local/bin/inews") "/usr/local/bin/inews") + ((file-exists-p "/usr/contrib/lib/news/inews") "/usr/contrib/lib/news/inews") + ((file-exists-p "/usr/lib/news/inews") "/usr/lib/news/inews") + (t "inews")) + "Program to post news.") + (nnoo-declare nnspool) (defvoo nnspool-inews-program news-inews-program diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 621aece8920..c538d740209 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -222,27 +222,6 @@ then use this hook to rsh to the remote machine and start a proxy NNTP server there that you can connect to. See also `nntp-open-connection-function'") -(defvoo nntp-coding-system-for-read 'binary - "*Coding system to read from NNTP.") - -(defvoo nntp-coding-system-for-write 'binary - "*Coding system to write to NNTP.") - -;; Marks -(defvoo nntp-marks-is-evil nil - "*If non-nil, Gnus will never generate and use marks file for nntp groups. -See `nnml-marks-is-evil' for more information.") - -(defvoo nntp-marks-file-name ".marks") -(defvoo nntp-marks nil) -(defvar nntp-marks-modtime (gnus-make-hashtable)) - -(defcustom nntp-marks-directory - (nnheader-concat gnus-directory "marks/") - "*The directory where marks for nntp groups will be stored." - :group 'nntp - :type 'directory) - (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :group 'nntp @@ -344,26 +323,26 @@ backend doesn't catch this error.") (insert (format-time-string "%Y%m%dT%H%M%S.%3N") " " nntp-address " " string "\n"))) +(defvar nntp--report-1 nil) + (defun nntp-report (&rest args) "Report an error from the nntp backend. The first string in ARGS can be a format string. For some commands, the failed command may be retried once before actually displaying the error report." + (if nntp--report-1 + (progn + ;; Throw out to nntp-with-open-group-error so that the connection may + ;; be restored and the command retried." + (when nntp-record-commands + (nntp-record-command "*** CONNECTION LOST ***")) + (throw 'nntp-with-open-group-error t)) - (when nntp-record-commands - (nntp-record-command "*** CALLED nntp-report ***")) - - (nnheader-report 'nntp args) + (when nntp-record-commands + (nntp-record-command "*** CALLED nntp-report ***")) - (apply 'error args)) + (nnheader-report 'nntp args) -(defun nntp-report-1 (&rest args) - "Throws out to nntp-with-open-group-error so that the connection may -be restored and the command retried." - - (when nntp-record-commands - (nntp-record-command "*** CONNECTION LOST ***")) - - (throw 'nntp-with-open-group-error t)) + (apply 'error args))) (defmacro nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." @@ -633,10 +612,6 @@ be restored and the command retried." (t nil))) -(eval-when-compile - (defvar nntp-with-open-group-internal nil) - (defvar nntp-report-n nil)) - (defun nntp-with-open-group-function (-group -server -connectionless -bodyfun) "Protect against servers that don't like clients that keep idle connections opens. The problem being that these servers may either close a connection or @@ -647,9 +622,9 @@ connection timeouts (which may be several minutes) or `nntp-connection-timeout' has expired. When these occur `nntp-with-open-group', opens a new connection then re-issues the NNTP command whose response triggered the error." - (letf ((nntp-report-n (symbol-function 'nntp-report)) - ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1)) - (nntp-with-open-group-internal nil)) + (let ((nntp-report-n nntp--report-1) + (nntp--report-1 t) + (nntp-with-open-group-internal nil)) (while (catch 'nntp-with-open-group-error ;; Open the connection to the server ;; NOTE: Existing connections are NOT tested. @@ -685,7 +660,7 @@ command whose response triggered the error." (when -timer (nnheader-cancel-timer -timer))) nil)) - (setf (symbol-function 'nntp-report) nntp-report-n)) + (setq nntp--report-1 nntp-report-n)) nntp-with-open-group-internal)) (defmacro nntp-with-open-group (group server &optional connectionless &rest forms) @@ -830,7 +805,8 @@ command whose response triggered the error." (progn (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) - (gnus-groups-to-gnus-format method gnus-active-hashtb t)) + (with-current-buffer nntp-server-buffer + (gnus-groups-to-gnus-format method gnus-active-hashtb t))) ;; We have read active entries, so we just delete the ;; superfluous gunk. (goto-char (point-min)) @@ -1188,43 +1164,6 @@ command whose response triggered the error." (deffoo nntp-asynchronous-p () t) -(deffoo nntp-request-set-mark (group actions &optional server) - (when (and (not nntp-marks-is-evil) - nntp-marks-file-name) - (nntp-possibly-create-directory group server) - (nntp-open-marks group server) - (setq nntp-marks (nnheader-update-marks-actions nntp-marks actions)) - (nntp-save-marks group server)) - nil) - -(deffoo nntp-request-marks (group info &optional server) - (when (and (not nntp-marks-is-evil) - nntp-marks-file-name) - (nntp-possibly-create-directory group server) - (when (nntp-marks-changed-p group server) - (nnheader-message 8 "Updating marks for %s..." group) - (nntp-open-marks group server) - ;; Update info using `nntp-marks'. - (mapc (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nntp-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) - (let ((seen (cdr (assq 'read nntp-marks)))) - (gnus-info-set-read info - (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen))) - (nnheader-message 8 "Updating marks for %s...done" group))) - nil) - - ;;; Hooky functions. @@ -1355,8 +1294,8 @@ password contained in '~/.nntp-authinfo'." (nntp-kill-buffer ,pbuffer))))) (process (condition-case err - (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write) + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) (map '((nntp-open-network-stream network) (network-only plain) ; compat (nntp-open-plain-stream plain) @@ -2165,95 +2104,6 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc))) -;; Marks handling - -(defun nntp-marks-directory (server) - (expand-file-name server nntp-marks-directory)) - -(defvar nntp-server-to-method-cache nil - "Alist of servers and select methods.") - -(defun nntp-group-pathname (server group &optional file) - "Return an absolute file name of FILE for GROUP on SERVER." - (let ((method (cdr (assoc server nntp-server-to-method-cache)))) - (unless method - (push (cons server (setq method (or (gnus-server-to-method server) - (gnus-find-method-for-group group)))) - nntp-server-to-method-cache)) - (nnmail-group-pathname - (mm-decode-coding-string group - (inline (gnus-group-name-charset method group))) - (nntp-marks-directory server) - file))) - -(defun nntp-possibly-create-directory (group server) - (let ((dir (nntp-group-pathname server group)) - (file-name-coding-system nnmail-pathname-coding-system)) - (unless (file-exists-p dir) - (make-directory (directory-file-name dir) t) - (nnheader-message 5 "Creating nntp marks directory %s" dir)))) - -(autoload 'time-less-p "time-date") - -(defun nntp-marks-changed-p (group server) - (let ((file (nntp-group-pathname server group nntp-marks-file-name)) - (file-name-coding-system nnmail-pathname-coding-system)) - (if (null (gnus-gethash file nntp-marks-modtime)) - t ;; never looked at marks file, assume it has changed - (time-less-p (gnus-gethash file nntp-marks-modtime) - (nth 5 (file-attributes file)))))) - -(defun nntp-save-marks (group server) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (file (nntp-group-pathname server group nntp-marks-file-name))) - (condition-case err - (progn - (nntp-possibly-create-directory group server) - (with-temp-file file - (erase-buffer) - (gnus-prin1 nntp-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nntp-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nntp-open-marks (group server) - (let ((file (nntp-group-pathname server group nntp-marks-file-name)) - (file-name-coding-system nnmail-pathname-coding-system)) - (if (file-exists-p file) - (condition-case err - (with-temp-buffer - (gnus-sethash file (nth 5 (file-attributes file)) - nntp-marks-modtime) - (nnheader-insert-file-contents file) - (setq nntp-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nntp-marks (gnus-remassoc el nntp-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nntp marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nntp marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - group - (gnus-server-to-method (format "nntp:%s" server))))) - (decoded-name (mm-decode-coding-string - group - (gnus-group-name-charset - (gnus-server-to-method server) group)))) - (nnheader-message 7 "Bootstrapping marks for %s..." decoded-name) - (setq nntp-marks (gnus-info-marks info)) - (push (cons 'read (gnus-info-read info)) nntp-marks) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nntp-marks (gnus-remassoc el nntp-marks))) - (nntp-save-marks group server) - (nnheader-message 7 "Bootstrapping marks for %s...done" - decoded-name))))) - (provide 'nntp) ;;; nntp.el ends here diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index a171cb35ae4..8c9c984ba2e 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -365,7 +365,7 @@ Valid types include `google', `dejanews', and `gmane'.") (match-string 1) (match-string 2) (or (match-string 3) - (substring (current-time-string) -4))) + (format-time-string "%Y"))) (current-time-string))) (setq From (match-string 4))) (widen) diff --git a/lisp/gnus/plstore.el b/lisp/gnus/plstore.el index cbd5e2a3b0a..6d5424e833d 100644 --- a/lisp/gnus/plstore.el +++ b/lisp/gnus/plstore.el @@ -64,8 +64,18 @@ ;; ;; Editing: ;; -;; Currently not supported but in the future plstore will provide a -;; major mode to edit PLSTORE files. +;; This file also provides `plstore-mode', a major mode for editing +;; the PLSTORE format file. Visit a non-existing file and put the +;; following line: +;; +;; (("foo" :host "foo.example.org" :secret-user "user")) +;; +;; where the prefixing `:secret-' means the property (without +;; `:secret-' prefix) is marked as secret. Thus, when you save the +;; buffer, the `:secret-user' property is encrypted as `:user'. +;; +;; You can toggle the view between encrypted form and the decrypted +;; form with C-c C-c. ;;; Code: @@ -107,6 +117,10 @@ symmetric encryption will be used.") (put 'plstore-encrypt-to 'permanent-local t) +(defvar plstore-encoded nil) + +(put 'plstore-encoded 'permanent-local t) + (defvar plstore-cache-passphrase-for-symmetric-encryption nil) (defvar plstore-passphrase-alist nil) @@ -194,10 +208,6 @@ symmetric encryption will be used.") (generate-new-buffer (format " plstore %s" filename)))) (store (plstore--make buffer))) (with-current-buffer buffer - ;; In the future plstore will provide a major mode called - ;; `plstore-mode' to edit PLSTORE files. - (if (eq major-mode 'plstore-mode) - (error "%s is opened for editing; kill the buffer first" file)) (erase-buffer) (condition-case nil (insert-file-contents-literally file) @@ -435,6 +445,131 @@ If no one is selected, symmetric encryption will be performed. " (plstore--insert-buffer plstore) (save-buffer))) +(defun plstore--encode (plstore) + (plstore--decrypt plstore) + (let ((merged-alist (plstore--get-merged-alist plstore))) + (concat "(" + (mapconcat + (lambda (entry) + (setq entry (copy-sequence entry)) + (let ((merged-plist (cdr (assoc (car entry) merged-alist))) + (plist (cdr entry))) + (while plist + (if (string-match "\\`:secret-" (symbol-name (car plist))) + (setcar (cdr plist) + (plist-get + merged-plist + (intern (concat ":" + (substring (symbol-name + (car plist)) + (match-end 0))))))) + (setq plist (nthcdr 2 plist))) + (prin1-to-string entry))) + (plstore--get-alist plstore) + "\n") + ")"))) + +(defun plstore--decode (string) + (let* ((alist (car (read-from-string string))) + (pointer alist) + secret-alist + plist + entry) + (while pointer + (unless (stringp (car (car pointer))) + (error "Invalid PLSTORE format %s" string)) + (setq plist (cdr (car pointer))) + (while plist + (when (string-match "\\`:secret-" (symbol-name (car plist))) + (setq entry (assoc (car (car pointer)) secret-alist)) + (unless entry + (setq entry (list (car (car pointer))) + secret-alist (cons entry secret-alist))) + (setcdr entry (plist-put (cdr entry) + (intern (concat ":" + (substring (symbol-name + (car plist)) + (match-end 0)))) + (car (cdr plist)))) + (setcar (cdr plist) t)) + (setq plist (nthcdr 2 plist))) + (setq pointer (cdr pointer))) + (plstore--make nil alist nil secret-alist))) + +(defun plstore--write-contents-functions () + (when plstore-encoded + (let ((store (plstore--decode (buffer-string))) + (file (buffer-file-name))) + (unwind-protect + (progn + (set-visited-file-name nil) + (with-temp-buffer + (plstore--insert-buffer store) + (write-region (buffer-string) nil file))) + (set-visited-file-name file) + (set-buffer-modified-p nil)) + t))) + +(defun plstore-mode-original () + "Show the original form of the this buffer." + (interactive) + (when plstore-encoded + (if (and (buffer-modified-p) + (y-or-n-p "Save buffer before reading the original form? ")) + (save-buffer)) + (erase-buffer) + (insert-file-contents-literally (buffer-file-name)) + (set-buffer-modified-p nil) + (setq plstore-encoded nil))) + +(defun plstore-mode-decoded () + "Show the decoded form of the this buffer." + (interactive) + (unless plstore-encoded + (if (and (buffer-modified-p) + (y-or-n-p "Save buffer before decoding? ")) + (save-buffer)) + (let ((store (plstore--make (current-buffer)))) + (plstore--init-from-buffer store) + (erase-buffer) + (insert + (substitute-command-keys "\ +;;; You are looking at the decoded form of the PLSTORE file.\n\ +;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n")) + (insert (plstore--encode store)) + (set-buffer-modified-p nil) + (setq plstore-encoded t)))) + +(defun plstore-mode-toggle-display () + "Toggle the display mode of PLSTORE between the original and decoded forms." + (interactive) + (if plstore-encoded + (plstore-mode-original) + (plstore-mode-decoded))) + +(eval-when-compile + (defmacro plstore-called-interactively-p (kind) + (condition-case nil + (progn + (eval '(called-interactively-p 'any)) + ;; Emacs >=23.2 + `(called-interactively-p ,kind)) + ;; Emacs <23.2 + (wrong-number-of-arguments '(called-interactively-p)) + ;; XEmacs + (void-function '(interactive-p))))) + +;;;###autoload +(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE" + "Major mode for editing PLSTORE files." + (make-local-variable 'plstore-encoded) + (add-hook 'write-contents-functions #'plstore--write-contents-functions) + (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display) + ;; to create a new file with plstore-mode, mark it as already decoded + (if (plstore-called-interactively-p 'any) + (setq plstore-encoded t) + (plstore-mode-decoded))) + (provide 'plstore) ;;; plstore.el ends here diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el index ee4345c2f4f..25330989e00 100644 --- a/lisp/gnus/pop3.el +++ b/lisp/gnus/pop3.el @@ -194,10 +194,16 @@ Use streaming commands." (unless (memq (process-status process) '(open run)) (error "pop3 process died")) (when total-size - (message "pop3 retrieved %dKB (%d%%)" - (truncate (/ (buffer-size) 1000)) - (truncate (* (/ (* (buffer-size) 1.0) - total-size) 100)))) + (let ((size 0)) + (goto-char (point-min)) + (while (re-search-forward "^\\+OK.*\n" nil t) + (setq size (+ size (- (point)) + (if (re-search-forward "^\\.\r?\n" nil 'move) + (match-beginning 0) + (point))))) + (message "pop3 retrieved %dKB (%d%%)" + (truncate (/ size 1000)) + (truncate (* (/ (* size 1.0) total-size) 100))))) (pop3-accept-process-output process)) start-point) diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el index c54fe3e3d71..b2130d56eb6 100644 --- a/lisp/gnus/registry.el +++ b/lisp/gnus/registry.el @@ -79,12 +79,6 @@ (eval-when-compile (require 'cl)) -(eval-when-compile - (when (null (ignore-errors (require 'ert))) - (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) - -(ignore-errors - (require 'ert)) (eval-and-compile (or (ignore-errors (progn (require 'eieio) @@ -373,111 +367,5 @@ Proposes any entries over the max-hard limit minus size * prune-factor." collect k))) (list limit candidates)))) -(ert-deftest registry-instantiation-test () - (should (registry-db "Testing"))) - -(ert-deftest registry-match-test () - (let ((entry '((hello "goodbye" "bye") (blank)))) - - (message "Testing :regex matching") - (should (registry--match :regex entry '((hello "nye" "bye")))) - (should (registry--match :regex entry '((hello "good")))) - (should-not (registry--match :regex entry '((hello "nye")))) - (should-not (registry--match :regex entry '((hello)))) - - (message "Testing :member matching") - (should (registry--match :member entry '((hello "bye")))) - (should (registry--match :member entry '((hello "goodbye")))) - (should-not (registry--match :member entry '((hello "good")))) - (should-not (registry--match :member entry '((hello "nye")))) - (should-not (registry--match :member entry '((hello))))) - (message "Done with matching testing.")) - -(defun registry-make-testable-db (n &optional name file) - (let* ((db (registry-db - (or name "Testing") - :file (or file "unused") - :max-hard n - :max-soft 0 ; keep nothing not precious - :precious '(extra more-extra) - :tracked '(sender subject groups)))) - (dotimes (i n) - (registry-insert db i `((sender "me") - (subject "about you") - (more-extra) ; empty data key should be pruned - ;; first 5 entries will NOT have this extra data - ,@(when (< 5 i) (list (list 'extra "more data"))) - (groups ,(number-to-string i))))) - db)) - -(ert-deftest registry-usage-test () - (let* ((n 100) - (db (registry-make-testable-db n))) - (message "size %d" n) - (should (= n (registry-size db))) - (message "max-hard test") - (should-error (registry-insert db "new" '())) - (message "Individual lookup") - (should (= 58 (caadr (registry-lookup db '(1 58 99))))) - (message "Grouped individual lookup") - (should (= 3 (length (registry-lookup db '(1 58 99))))) - (when (boundp 'lexical-binding) - (message "Individual lookup (breaks before lexbind)") - (should (= 58 - (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99))))) - (message "Grouped individual lookup (breaks before lexbind)") - (should (= 3 - (length (registry-lookup-breaks-before-lexbind db - '(1 58 99)))))) - (message "Search") - (should (= n (length (registry-search db :all t)))) - (should (= n (length (registry-search db :member '((sender "me")))))) - (message "Secondary index search") - (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) - (should (equal '(74) (registry-lookup-secondary-value db 'groups "74"))) - (message "Delete") - (should (registry-delete db '(1) t)) - (decf n) - (message "Search after delete") - (should (= n (length (registry-search db :all t)))) - (message "Secondary search after delete") - (should (= n (length (registry-lookup-secondary-value db 'sender "me")))) - ;; (message "Pruning") - ;; (let* ((tokeep (registry-search db :member '((extra "more data")))) - ;; (count (- n (length tokeep))) - ;; (pruned (registry-prune db)) - ;; (prune-count (length pruned))) - ;; (message "Expecting to prune %d entries and pruned %d" - ;; count prune-count) - ;; (should (and (= count 5) - ;; (= count prune-count)))) - (message "Done with usage testing."))) - -(ert-deftest registry-persistence-test () - (let* ((n 100) - (tempfile (make-temp-file "registry-persistence-")) - (name "persistence tester") - (db (registry-make-testable-db n name tempfile)) - size back) - (message "Saving to %s" tempfile) - (eieio-persistent-save db) - (setq size (nth 7 (file-attributes tempfile))) - (message "Saved to %s: size %d" tempfile size) - (should (< 0 size)) - (with-temp-buffer - (insert-file-contents-literally tempfile) - (should (looking-at (concat ";; Object " - name - "\n;; EIEIO PERSISTENT OBJECT")))) - (message "Reading object back") - (setq back (eieio-persistent-read tempfile)) - (should back) - (message "Read object back: %d keys, expected %d==%d" - (registry-size back) n (registry-size db)) - (should (= (registry-size back) n)) - (should (= (registry-size back) (registry-size db))) - (delete-file tempfile)) - (message "Done with persistence testing.")) - (provide 'registry) ;;; registry.el ends here diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el index 42118298734..bf6e57e8d79 100644 --- a/lisp/gnus/shr.el +++ b/lisp/gnus/shr.el @@ -119,6 +119,7 @@ cid: URL as the argument.") (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) (define-key map "i" 'shr-browse-image) + (define-key map "z" 'shr-zoom-image) (define-key map "I" 'shr-insert-image) (define-key map "u" 'shr-copy-url) (define-key map "v" 'shr-browse-url) @@ -128,17 +129,23 @@ cid: URL as the argument.") ;; Public functions and commands. -(defun shr-visit-file (file) - "Parse FILE as an HTML document, and render it in a new buffer." - (interactive "fHTML file name: ") +(defun shr-render-buffer (buffer) + "Display the HTML rendering of the current buffer." + (interactive (list (current-buffer))) (pop-to-buffer "*html*") (erase-buffer) (shr-insert-document - (with-temp-buffer - (insert-file-contents file) + (with-current-buffer buffer (libxml-parse-html-region (point-min) (point-max)))) (goto-char (point-min))) +(defun shr-visit-file (file) + "Parse FILE as an HTML document, and render it in a new buffer." + (interactive "fHTML file name: ") + (with-temp-buffer + (insert-file-contents file) + (shr-render-buffer (current-buffer)))) + ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -235,6 +242,40 @@ the URL of the image to the kill buffer instead." (list (current-buffer) (1- (point)) (point-marker)) t t)))) +(defun shr-zoom-image () + "Toggle the image size. +The size will be rotated between the default size, the original +size, and full-buffer size." + (interactive) + (let ((url (get-text-property (point) 'image-url)) + (size (get-text-property (point) 'image-size)) + (buffer-read-only nil)) + (if (not url) + (message "No image under point") + ;; Delete the old picture. + (while (get-text-property (point) 'image-url) + (forward-char -1)) + (forward-char 1) + (let ((start (point))) + (while (get-text-property (point) 'image-url) + (forward-char 1)) + (forward-char -1) + (put-text-property start (point) 'display nil) + (when (> (- (point) start) 2) + (delete-region start (1- (point))))) + (message "Inserting %s..." url) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) (1- (point)) (point-marker) + (list (cons 'size + (cond ((or (eq size 'default) + (null size)) + 'original) + ((eq size 'original) + 'full) + ((eq size 'full) + 'default))))) + t)))) + ;;; Utility functions. (defun shr-transform-dom (dom) @@ -298,6 +339,7 @@ the URL of the image to the kill buffer instead." (defun shr-insert (text) (when (and (eq shr-state 'image) + (not (bolp)) (not (string-match "\\`[ \t\n]+\\'" text))) (insert "\n") (setq shr-state nil)) @@ -305,11 +347,11 @@ the URL of the image to the kill buffer instead." ((eq shr-folding-mode 'none) (insert text)) (t - (when (and (string-match "\\`[ \t\n]" text) + (when (and (string-match "\\`[ \t\n ]" text) (not (bolp)) (not (eq (char-after (1- (point))) ? ))) (insert " ")) - (dolist (elem (split-string text)) + (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t)) (when (and (bolp) (> shr-indentation 0)) (shr-indent)) @@ -349,7 +391,7 @@ the URL of the image to the kill buffer instead." (shr-indent)) (end-of-line)) (insert " "))) - (unless (string-match "[ \t\n]\\'" text) + (unless (string-match "[ \t\n ]\\'" text) (delete-char -1))))) (defun shr-find-fill-point () @@ -408,32 +450,29 @@ the URL of the image to the kill buffer instead." (shr-char-kinsoku-eol-p (following-char))))) (goto-char bp))) ((shr-char-kinsoku-eol-p (preceding-char)) - (if (shr-char-kinsoku-eol-p (following-char)) - ;; There are consecutive kinsoku-eol characters. - (setq failed t) - (let ((count 4)) - (while - (progn - (backward-char 1) - (and (> (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char))))))) - (if (setq failed (= (current-column) shr-indentation)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1))))) - (t - (if (shr-char-kinsoku-bol-p (preceding-char)) - ;; There are consecutive kinsoku-bol characters. - (setq failed t) - (let ((count 4)) - (while (and (>= (setq count (1- count)) 0) + ;; Find backward the point where kinsoku-eol characters begin. + (let ((count 4)) + (while + (progn + (backward-char 1) + (and (> (setq count (1- count)) 0) + (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) + (or (shr-char-kinsoku-eol-p (preceding-char)) + (shr-char-kinsoku-bol-p (following-char))))))) + (if (setq failed (= (current-column) shr-indentation)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we go to the second best position. + (if (looking-at "\\(\\c<+\\)\\c<") + (goto-char (match-end 1)) + (forward-char 1)))) + ((shr-char-kinsoku-bol-p (following-char)) + ;; Find forward the point where kinsoku-bol characters end. + (let ((count 4)) + (while (progn + (forward-char 1) + (and (>= (setq count (1- count)) 0) (shr-char-kinsoku-bol-p (following-char)) - (shr-char-breakable-p (following-char))) - (forward-char 1)))))) + (shr-char-breakable-p (following-char)))))))) (when (eq (following-char) ? ) (forward-char 1)))) (not failed))) @@ -465,7 +504,7 @@ the URL of the image to the kill buffer instead." (if (save-excursion (beginning-of-line) (looking-at " *$")) - (insert "\n") + (delete-region (match-beginning 0) (match-end 0)) (insert "\n\n"))))) (defun shr-indent () @@ -523,7 +562,7 @@ the URL of the image to the kill buffer instead." (expand-file-name (file-name-nondirectory url) directory))))) -(defun shr-image-fetched (status buffer start end) +(defun shr-image-fetched (status buffer start end &optional flags) (let ((image-buffer (current-buffer))) (when (and (buffer-name buffer) (not (plist-get status :error))) @@ -534,30 +573,53 @@ the URL of the image to the kill buffer instead." (with-current-buffer buffer (save-excursion (let ((alt (buffer-substring start end)) + (properties (text-properties-at start)) (inhibit-read-only t)) (delete-region start end) (goto-char start) - (funcall shr-put-image-function data alt))))))) + (funcall shr-put-image-function data alt flags) + (while properties + (let ((type (pop properties)) + (value (pop properties))) + (unless (memq type '(display image-size)) + (put-text-property start (point) type value)))))))))) (kill-buffer image-buffer))) -(defun shr-put-image (data alt) +(defun shr-put-image (data alt &optional flags) "Put image DATA with a string ALT. Return image." (if (display-graphic-p) - (let ((image (ignore-errors - (shr-rescale-image data)))) + (let* ((size (cdr (assq 'size flags))) + (start (point)) + (image (cond + ((eq size 'original) + (create-image data nil t :ascent 100)) + ((eq size 'full) + (ignore-errors + (shr-rescale-image data t))) + (t + (ignore-errors + (shr-rescale-image data)))))) (when image ;; When inserting big-ish pictures, put them at the ;; beginning of the line. (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (insert-image image (or alt "*")) + (if (eq size 'original) + (let ((overlays (overlays-at (point)))) + (insert-sliced-image image (or alt "*") nil 20 1) + (dolist (overlay overlays) + (overlay-put overlay 'face 'default))) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) (when (image-animated-p image) (image-animate image nil 60))) image) (insert alt))) -(defun shr-rescale-image (data) +(defun shr-rescale-image (data &optional force) + "Rescale DATA, if too big, to fit the current buffer. +If FORCE, rescale the image anyway." (let ((image (create-image data nil t :ascent 100))) (if (or (not (fboundp 'imagemagick-types)) (not (get-buffer-window (current-buffer)))) @@ -572,7 +634,8 @@ the URL of the image to the kill buffer instead." (window-height (truncate (* shr-max-image-proportion (- (nth 3 edges) (nth 1 edges))))) scaled-image) - (when (> height window-height) + (when (or force + (> height window-height)) (setq image (or (create-image data 'imagemagick t :height window-height :ascent 100) @@ -984,7 +1047,12 @@ ones, in case fg and bg are nil." (shr-generic cont))) (defun shr-tag-br (cont) - (unless (bobp) + (when (and (not (bobp)) + ;; Only add a newline if we break the current line, or + ;; the previous line isn't a blank line. + (or (not (bolp)) + (and (> (- (point) 2) (point-min)) + (not (= (char-after (- (point) 2)) ?\n))))) (insert "\n") (shr-indent)) (shr-generic cont)) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 3cfbd7dba35..c3be15adc1a 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -2088,11 +2088,6 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; all this is done inside a condition-case to trap errors -(eval-when-compile - (autoload 'bbdb-buffer "bbdb") - (autoload 'bbdb-create-internal "bbdb") - (autoload 'bbdb-search-simple "bbdb")) - ;; Autoloaded in message, which we require. (declare-function gnus-extract-address-components "gnus-util" (from)) @@ -2104,9 +2099,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (file-error ;; `bbdb-records' should not be bound as an autoload function ;; before loading bbdb because of `bbdb-hashtable-size'. + (defalias 'bbdb-buffer 'ignore) + (defalias 'bbdb-create-internal 'ignore) (defalias 'bbdb-records 'ignore) (defalias 'spam-BBDB-register-routine 'ignore) (defalias 'spam-enter-ham-BBDB 'ignore) + (defalias 'spam-exists-in-BBDB-p 'ignore) + (defalias 'bbdb-gethash 'ignore) nil)) ;; when the BBDB changes, we want to clear out our cache @@ -2126,7 +2125,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 'ignore)) (net-address (nth 1 parsed-address)) (record (and net-address - (bbdb-search-simple nil net-address)))) + (spam-exists-in-BBDB-p net-address)))) (when net-address (gnus-message 6 "%s address %s %s BBDB" (if remove "Deleting" "Adding") @@ -2148,15 +2147,17 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-BBDB-unregister-routine (articles) (spam-BBDB-register-routine articles t)) + (defsubst spam-exists-in-BBDB-p (net) + (when (and (stringp net) (not (zerop (length net)))) + (bbdb-records) + (bbdb-gethash (downcase net)))) + (defun spam-check-BBDB () "Mail from people in the BBDB is classified as ham or non-spam" - (let ((who (message-fetch-field "from"))) - (when who - (setq who (nth 1 (gnus-extract-address-components who))) - (if - (if (fboundp 'bbdb-search) - (bbdb-search (bbdb-records) who) ;; v3 - (bbdb-search-simple nil who)) ;; v2 + (let ((net (message-fetch-field "from"))) + (when net + (setq net (nth 1 (gnus-extract-address-components net))) + (if (spam-exists-in-BBDB-p net) t (if spam-use-BBDB-exclusive spam-split-group |