diff options
Diffstat (limited to 'lisp/gnus')
| -rw-r--r-- | lisp/gnus/ChangeLog | 405 | ||||
| -rw-r--r-- | lisp/gnus/auth-source.el | 194 | ||||
| -rw-r--r-- | lisp/gnus/eww.el | 367 | ||||
| -rw-r--r-- | lisp/gnus/gnus-art.el | 4 | ||||
| -rw-r--r-- | lisp/gnus/gnus-group.el | 12 | ||||
| -rw-r--r-- | lisp/gnus/gnus-start.el | 22 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 67 | ||||
| -rw-r--r-- | lisp/gnus/gnus.el | 5 | ||||
| -rw-r--r-- | lisp/gnus/mm-decode.el | 20 | ||||
| -rw-r--r-- | lisp/gnus/mml2015.el | 19 | ||||
| -rw-r--r-- | lisp/gnus/nnimap.el | 221 | ||||
| -rw-r--r-- | lisp/gnus/nnir.el | 4 | ||||
| -rw-r--r-- | lisp/gnus/shr-color.el | 363 | ||||
| -rw-r--r-- | lisp/gnus/shr.el | 1530 | ||||
| -rw-r--r-- | lisp/gnus/sieve-manage.el | 18 | ||||
| -rw-r--r-- | lisp/gnus/sieve.el | 12 |
16 files changed, 781 insertions, 2482 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 83831264f58..34eb28f0965 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,378 @@ +2013-07-05 David Kastrup <dak@gnu.org> + + * auth-source.el (auth-source-netrc-parse-one): Allow empty strings in + authinfo file again (important for blank passwords). This had been + broken with 2013-06-15 change. + +2013-07-03 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): + Revert 2013-01-14 change. + +2013-07-02 David Engster <deng@randomsample.de> + + * gnus-sum.el (gnus-update-marks): Do not remove empty 'unexist' + ranges, since `nnimap-retrieve-group-data-early' also uses it as a flag + to see whether the group was synced before. + +2013-07-02 Martin Stjernholm <mast@lysator.liu.se> + + * nnimap.el (nnimap-request-move-article): Decode the group name when + doing internal moves to avoid charset issues. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnimap.el (nnimap-request-list): + Revert change that made listing synchronous. + (nnimap-get-responses): Restore. + +2013-07-02 Dave Abrahams <dave@boostpro.com> + + * nnimap.el (nnimap-change-group): Document result value. + + * nnimap.el (nnimap-find-article-by-message-id): + Account for the fact that nnimap-change-group can return t. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnimap.el (nnimap-request-head): + Resture to-buffer parameter, used by `nnimap-request-move-article'. + + * nnimap.el (nnimap-request-head): Remove to-buffer argument. + + * gnus-int.el (gnus-request-head): Remove to-buffer argument, only + supported by nnimap actually. Reverts previous change. + + * gnus-int.el (gnus-request-head): Add an optional to-buffer parameter + to mimic `gnus-request-article' and enjoy backends the nn*-request-head + to-buffer argument that is already supported. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnimap.el (nnimap-get-responses): Remove, unused. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnimap.el (nnimap-request-articles-find-limit): Rename from + `nnimap-request-move-articles-find-limit' since we do not use it + only for move operations. + (nnimap-request-accept-article): + Use `nnimap-request-articles-find-limit' to limit search by message-id. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnir.el (nnir-run-imap): Fix, use `nnimap-change-group'. + + * nnimap.el (nnimap-log-buffer): + Check that `window-point-insertion-type' is boundp, since it's not + available in XEmacs. + +2013-07-02 Michael Welsh Duggan <md5i@md5i.com> + + * nnimap.el (nnimap-log-buffer): + Add this, setting `window-point-insertion-type' in the buffer to t. + (nnimap-log-command): Use nnimap-log-buffer. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnimap.el (nnimap-find-article-by-message-id): + Add an optional limit argument to be able to limit the search. + (nnimap-request-move-article): + Use `nnimap-request-move-articles-find-limit'. + (nnimap-request-move-articles-find-limit): + Add this to limit the search by Message-Id after a message move. + (nnimap): Add defgroup. + +2013-07-02 Julien Danjou <julien@danjou.info> + + * nnimap.el (nnimap-find-article-by-message-id): + Use `nnimap-possibly-change-group' rather than its own EXAMINE call. + (nnimap-possibly-change-group): Add read-only argument. + (nnimap-request-list): Use nnimap-possibly-change-group rather than + issuing EXAMINE manually. + (nnimap-find-article-by-message-id): + Use `nnimap-possibly-change-group' with read-only argument. + (nnimap-change-group): Rename from `nnimap-possibly-change-group'. + We cannot possibly change because we need to be sure that it's either + read-write or read-only. + +2013-07-02 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-summary-insert-old-articles): + Don't include unexistent messages. + +2013-07-02 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-clean-old-newsrc): + Remove totally bogus `unexists' entries. + (gnus-clean-old-newsrc): Fix last checkin. + + * nnimap.el (nnimap-update-info): + None of the articles below the active low-water mark exist. + +2013-07-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnimap.el (gnus-refer-thread-use-nnir): Silence the byte compiler. + +2013-07-02 Sergio Martinez <samf0xb58@gmail.com> (tiny change) + + * nnimap.el (nnimap-request-scan): + Allow `nnimap-inbox' to be a list of inboxes. + +2013-07-02 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-expire-articles-1): + Don't try to expire messages that don't exist. + + * gnus-sum.el (gnus-summary-expire-articles): Ditto. + +2013-07-02 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-clean-old-newsrc): Allow a FORCE parameter. + +2013-07-02 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-clean-old-newsrc): + Delete `unexist' from pre-Ma Gnus 0.3. + +2013-07-02 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-summary-local-variables): + Make `gnus-newsgroup-unexist' into a local variable. + +2013-07-02 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-adjust-marked-articles): + Add to `gnus-newsgroup-unexist'. + + * gnus.el (gnus-article-mark-lists): + Add `unexist' to the list of marks. + (gnus-article-special-mark-lists): + Put the `unexist' in the special marks list instead. + + * gnus-sum.el (gnus-articles-to-read): Don't include unexisting + articles in the list of articles to be selected. + + * nnimap.el (nnimap-retrieve-group-data-early): + Query for unexisting articles. + (nnimap-update-info): Keep track of unexisting articles. + (nnimap-update-qresync-info): Ditto. + +2013-07-02 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-clean-old-newsrc): New function. + (gnus-read-newsrc-file): Use it. + +2013-07-02 Daiki Ueno <ueno@gnu.org> + + * mml2015.el (mml2015-epg-key-image): Use 'gnus-create-image' instead + of 'create-image' for XEmacs compatibility; check errors when decoding + image. Reported by Uwe Brauer. + +2013-06-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-extend-url-button): Make it work again with + gnus-button-push revised at 2011-01-19. + +2013-06-19 Glenn Morris <rgm@gnu.org> + + * gnus-group.el (gnus-mark-article-as-read): Fix declaration. + +2013-06-18 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-netrc-parse-entries): Remove debugging. + +2013-06-18 Glenn Morris <rgm@gnu.org> + + * eww.el, shr.el, shr-color.el: Move to ../net. + +2013-06-18 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-tag-table): Insert the images after the table, so that + they're not covered by the table colourisation, which often looked + awkward. + (shr-tag-dl, shr-tag-dt, shr-tag-dd): Add support for <dl>, <dt> and + <dd>. + +2013-06-18 Katsumi Yamaoka <yamaoka@jpl.org> + + * eww.el (eww-detect-charset): Improve regexp; move backward. + +2013-06-18 Glenn Morris <rgm@gnu.org> + + * mm-decode.el (widget-convert-button): Autoload. + + * sieve-manage.el (mm-enable-multibyte): Autoload. + + * shr.el (libxml-parse-html-region): Declare. + (shr-render-buffer): Explicit error if no libxml2 support. + +2013-06-17 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-current-line): New function. + (auth-source-netrc-parse-entries): When a data token is "machine", + assume we're in the wrong place and abort parsing the current line. + +2013-06-17 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * eww.el (eww-tag-select): Don't render totally empty <select> forms. + (eww-convert-widgets): Don't bug out if the first widget starts at the + beginning of the buffer. + (eww-convert-widgets): Fix last patch. + (eww-tag-input): Support <input type=image>. + + * shr.el (shr-insert-table): Respect border-collapse: collapse. + (shr-tag-base): Protect against base specs that are degenerate. + (shr-ensure-paragraph): Don't delete empty lines that have text + properties, because these may be input fields. + + * eww.el (eww-convert-widgets): Put `help-echo' on input fields so that + we can navigate to them. + + * shr.el (shr-colorize-region): Put the colours over the entire region. + (shr-inhibit-decoration): New variable. + (shr-add-font): Use it to inhibit text property decorations while doing + preliminary table renderings. This speeds up typical Wikipedia page + renderings by 15%. + (shr-tag-span): Don't respect the <title>, because that overwrites the + help-echo from links inside the spans. + (shr-next-link): Use `help-echo' for navigation, so that we can + navigate to form elements, too. + + * eww.el (eww-button): New face. + (eww-convert-widgets): Use it to make submit buttons more button-like. + + * mm-decode.el (mm-convert-shr-links): Override the shr local map, so + that Gnus commands work. + + * shr.el (shr-render-td): Support horizontal alignment. + + * eww.el (eww-put-color): Removed. + (eww-colorize-region): Use `add-face-text-property'. + + * shr.el (shr-add-font): Append face data, so that we get the correct + precedence: The innermost value (which is applied first) wins. + (shr-make-overlay): Obsolete function. + + * mm-decode.el (mm-convert-shr-links): New function to convert + new-style shr URL links into widgets. + (mm-shr): Use it. + + * eww.el (eww-mode-map): Use `shr-next-link' (etc) instead of the + widget commands, since we're no longer using widgets for links. + + * shr.el (shr-next-link): New command. + (shr-previous-link): New command. + (shr-urlify): Don't use `widget-convert', because that's slow. + (shr-put-color-1): Use `add-face-text-property' instead of overlays, + because collecting the overlays and reapplying them when generating + tables is slow. + (shr-insert-table): Ditto. + +2013-06-17 Stefan Monnier <monnier@iro.umontreal.ca> + + * sieve.el (sieve-edit-script): Avoid beginning-of-buffer. + * shr.el (browse-url): Require `url'. + * eww.el (url): Require format-spec. + +2013-06-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * eww.el (eww-display-html): Default to using the entire window width. + (eww-browse-url): Don't add a User-Agent header (twice), because that + makes Bing refuse connection. + + * shr.el (shr-make-table): Cache the table rendering at the table + level, and not the <td> level. This is a bit faster. + + * eww.el (eww-render): Go to the correct ID when given URLs ending with + #id. + + * shr.el (shr-tag-li): Don't require a new paragraph, since other + browsers don't. + (shr-expand-url): Respect #anchor links. + (shr-parse-base): Chop off the anchor before using. + (shr-descend): Respect display: none. + (shr-descend): Allow marking elements that have certain IDs. + + * eww.el (eww-tag-textarea): Use `text' instead of `editable-field'. + + * shr.el (shr-expand-url): Don't bug out on zero-length links. + + * eww.el (eww-tag-textarea): Support <textarea>. + +2013-06-16 Rüdiger Sonderfeld <ruediger@c-plusplus.de> + + * shr.el (shr-dom-to-xml): Fixed function call. + + * eww.el (eww): New group. + (eww-header-line-format): New custom variable. + (eww-current-title): New variable. + (eww-display-html): Update header and handle title tag. + (eww-update-header-line-format): New function. + (eww-tag-title): New function. + + * shr.el (shr-dom-to-xml): New function. + (shr-tag-svg): Add support for the SVG tag. + (shr-bullet): New custom variable. + (shr-tag-li): Support custom bullet in unordered lists. + +2013-06-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-expand-url): Respect // URLs. + + * eww.el (eww-tag-body): Override the shr body rendering so that we can + put a background colour onto the entire buffer. + (eww-render): When being redirected, use the redirect URL as the new + base URL. + + * shr.el (shr-parse-base): Fix parsing error. + + * eww.el (eww-submit): Pass the base in to `shr-expand-url'. + + * shr.el (shr-parse-base): New function. + (shr-expand-url): Use it to expand relative URLs reliably. + +2013-06-15 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-search-collection): Fix docstring. + (auth-source-netrc-parse): Refactor and improve netrc parser to support + single-quoted strings and multiline entries. + (auth-source-netrc-parse-next-interesting) + (auth-source-netrc-parse-one, auth-source-netrc-parse-entries): New + functions to support parser. + +2013-06-14 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * eww.el (eww-submit): Get submit button logic right when hitting RET + on non-submit buttons. + + * shr.el: Remove shr-preliminary-table-render, since that can't really + be used for anything in practice. + +2013-06-13 Albert Krewinkel <tarleb@moltkeplatz.de> + + * sieve.el: Rebind q to (sieve-bury-buffer), bind Q to + (sieve-manage-quit). + +2013-06-14 David Edmondson <dme@dme.org> (tiny change) + + * mml2015.el (mml2015-maximum-key-image-dimension): New user option to + control the maximum size of photo ID image. + (mml2015-epg-key-image-to-string): Respect it. + +2013-06-13 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-tag-table-1): Mark the preliminary table renderings + instead of the final one so that we can more easily distinguish them. + + * eww.el (eww-submit): Compute the submission URL correctly. + +2013-06-13 Stefan Monnier <monnier@iro.umontreal.ca> + + * sieve-manage.el (sieve-manage-open-server): Don't quote lambda. + Use plist-get rather than CL's getf. + (sieve-manage-parse-capability): Avoid CL's remove-if. + 2013-06-13 Lars Magne Ingebrigtsen <larsi@gnus.org> * shr.el (shr-expand-url): Expansion should chop off the bits after the @@ -29,9 +404,9 @@ 2013-06-10 Albert Krewinkel <krewinkel@moltkeplatz.de> - * sieve-manage.el (sieve-manage-open): work with STARTTLS: shorten + * sieve-manage.el (sieve-manage-open): Work with STARTTLS: shorten stream managing functions by using open-protocol-stream to do most of - the work. Has the nice benefit of enabling STARTTLS. + the work. Has the nice benefit of enabling STARTTLS. Wait for capabilities after STARTTLS: following RFC5804, the server sends new capabilities after successfully establishing a TLS connection with the client. The client should update the cached list of @@ -82,10 +457,10 @@ 2013-06-10 Albert Krewinkel <krewinkel@moltkeplatz.de> * sieve.el: Put point at beginning of buffer when viewing a script. - (sieve-open-server): respect the PORT parameter. Show the correct port - number in sieve-buffer's header. Fixed code to also work with a string - as port specifier. Properly close the connection on pressing 'q'. Make - sieve-manage-quit close the connection and process buffer. Also, remove + (sieve-open-server): Respect the PORT parameter. Show the correct port + number in sieve-buffer's header. Fixed code to also work with a string + as port specifier. Properly close the connection on pressing 'q'. Make + sieve-manage-quit close the connection and process buffer. Also, remove duplicate keybinding for 'q'. 2013-06-10 Roy Hashimoto <roy.hashimoto@gmail.com> (tiny change) @@ -329,7 +704,7 @@ (nnir-request-update-info): Improve marks updating. (nnir-request-scan): Don't duplicate marks updating. (gnus-group-make-nnir-group, nnir-run-imap, nnir-request-create-group): - Use 'assq rather than 'assoc. Quote anonymous function. + Use 'assq rather than 'assoc. Quote anonymous function. (nnir-request-group, nnir-close-group, gnus-summary-create-nnir-group): Use 'gnus-group-prefixed-p. (gnus-summary-create-nnir-group): Make sure server for method is open. @@ -387,13 +762,13 @@ buffer use the posting-style and gcc of the original article group. (gnus-inews-insert-gcc): Don't set gcc-self for virtual groups. - * nnir.el: Fix byte-compile warning. nnoo-define-skeleton should come + * nnir.el: Fix byte-compile warning. nnoo-define-skeleton should come after other deffoos. 2013-03-26 Andrew Cohen <cohen@bu.edu> - * nnir.el: Major rewrite. Cleaner separation between searches and group - management. Marks are now shown in nnir summary buffers. Rudimentary + * nnir.el: Major rewrite. Cleaner separation between searches and group + management. Marks are now shown in nnir summary buffers. Rudimentary support for real (i.e. not ephemeral) nnir groups. (gnus-summary-make-nnir-group): New function for initiating searches from a summary buffer. @@ -599,9 +974,9 @@ 2012-12-25 Adam Sjøgren <asjo@koldfront.dk> - * mml2015.el (mml2015-epg-key-image): use --attribute-fd rather than - temporary file to get PGP key image. Pass no-show-photos when extracting - image to avoid having it pop up twice. + * mml2015.el (mml2015-epg-key-image): Use --attribute-fd rather than + temporary file to get PGP key image. Pass no-show-photos when + extracting image to avoid having it pop up twice. 2012-12-26 Lars Ingebrigtsen <larsi@gnus.org> @@ -1125,7 +1500,7 @@ 2012-08-10 Daiki Ueno <ueno@unixuser.org> - * auth-source.el: (auth-source-plstore-search) + * auth-source.el (auth-source-plstore-search) (auth-source-secrets-search): Ignore :require and :type in search spec. 2012-08-06 Julien Danjou <julien@danjou.info> @@ -9822,7 +10197,7 @@ 2010-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> - * gnus-html.el: require mm-url. + * gnus-html.el: Require mm-url. (gnus-html-wash-tags): Clarify the code a bit by renaming the variable with the url to `url'. (gnus-html-wash-tags): Support cid: URLs/images. diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index e94904bf175..54429b5cfda 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -801,7 +801,7 @@ Returns the deleted entries." (auth-source-search (plist-put spec :delete t))) (defun auth-source-search-collection (collection value) - "Returns t is VALUE is t or COLLECTION is t or contains VALUE." + "Returns t is VALUE is t or COLLECTION is t or COLLECTION contains VALUE." (when (and (atom collection) (not (eq t collection))) (setq collection (list collection))) @@ -942,7 +942,7 @@ while \(:host t) would find all host entries." (defun auth-source--aget (alist key) (cdr (assoc key alist))) -;; (auth-source-netrc-parse "~/.authinfo.gpg") +;; (auth-source-netrc-parse :file "~/.authinfo.gpg") (defun* auth-source-netrc-parse (&rest spec &key file max host user port delete require @@ -955,15 +955,41 @@ Note that the MAX parameter is used so we can exit the parse early." (when (file-exists-p file) (setq port (auth-source-ensure-strings port)) (with-temp-buffer - (let* ((tokens '("machine" "host" "default" "login" "user" - "password" "account" "macdef" "force" - "port" "protocol")) - (max (or max 5000)) ; sanity check: default to stop at 5K + (let* ((max (or max 5000)) ; sanity check: default to stop at 5K (modified 0) (cached (cdr-safe (assoc file auth-source-netrc-cache))) (cached-mtime (plist-get cached :mtime)) (cached-secrets (plist-get cached :secret)) - alist elem result pair) + (check (lambda(alist) + (and alist + (auth-source-search-collection + host + (or + (auth-source--aget alist "machine") + (auth-source--aget alist "host") + t)) + (auth-source-search-collection + user + (or + (auth-source--aget alist "login") + (auth-source--aget alist "account") + (auth-source--aget alist "user") + t)) + (auth-source-search-collection + port + (or + (auth-source--aget alist "port") + (auth-source--aget alist "protocol") + t)) + (or + ;; the required list of keys is nil, or + (null require) + ;; every element of require is in n(ormalized) + (let ((n (nth 0 (auth-source-netrc-normalize + (list alist) file)))) + (loop for req in require + always (plist-get n req))))))) + result) (if (and (functionp cached-secrets) (equal cached-mtime @@ -983,85 +1009,10 @@ Note that the MAX parameter is used so we can exit the parse early." :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)) - (> max 0)) - - (narrow-to-region (point) (point-at-eol)) - ;; For each line, get the tokens and values. - (while (not (eobp)) - (skip-chars-forward "\t ") - ;; Skip lines that begin with a "#". - (if (eq (char-after) ?#) - (goto-char (point-max)) - (unless (eobp) - (setq elem - (if (= (following-char) ?\") - (read (current-buffer)) - (buffer-substring - (point) (progn (skip-chars-forward "^\t ") - (point))))) - (cond - ((equal elem "macdef") - ;; We skip past the macro definition. - (widen) - (while (and (zerop (forward-line 1)) - (looking-at "$"))) - (narrow-to-region (point) (point))) - ((and (member elem tokens) (null pair)) - ;; Tokens that don't have a following value are ignored, - ;; except "default". - (when (and pair (or (cdr pair) - (equal (car pair) "default"))) - (push pair alist)) - (setq pair (list elem))) - (t - ;; Values that haven't got a preceding token are ignored. - (when pair - (setcdr pair elem) - (push pair alist) - (setq pair nil))))))) - - (when (and alist - (> max 0) - (auth-source-search-collection - host - (or - (auth-source--aget alist "machine") - (auth-source--aget alist "host") - t)) - (auth-source-search-collection - user - (or - (auth-source--aget alist "login") - (auth-source--aget alist "account") - (auth-source--aget alist "user") - t)) - (auth-source-search-collection - port - (or - (auth-source--aget alist "port") - (auth-source--aget alist "protocol") - t)) - (or - ;; the required list of keys is nil, or - (null require) - ;; every element of require is in the normalized list - (let ((normalized (nth 0 (auth-source-netrc-normalize - (list alist) file)))) - (loop for req in require - always (plist-get normalized req))))) - (decf max) - (push (nreverse alist) result) - ;; to delete a line, we just comment it out - (when delete - (goto-char (point-min)) - (insert "#") - (incf modified))) - (setq alist nil - pair nil) - (widen) - (forward-line 1)) + (let ((entries (auth-source-netrc-parse-entries check max)) + alist) + (while (setq alist (pop entries)) + (push (nreverse alist) result))) (when (< 0 modified) (when auth-source-gpg-encrypt-to @@ -1084,6 +1035,77 @@ Note that the MAX parameter is used so we can exit the parse early." (nreverse result)))))) +(defun auth-source-netrc-parse-next-interesting () + "Advance to the next interesting position in the current buffer." + ;; If we're looking at a comment or are at the end of the line, move forward + (while (or (looking-at "#") + (and (eolp) + (not (eobp)))) + (forward-line 1)) + (skip-chars-forward "\t ")) + +(defun auth-source-netrc-parse-one () + "Read one thing from the current buffer." + (auth-source-netrc-parse-next-interesting) + + (when (or (looking-at "'\\([^']*\\)'") + (looking-at "\"\\([^\"]*\\)\"") + (looking-at "\\([^ \t\n]+\\)")) + (forward-char (length (match-string 0))) + (auth-source-netrc-parse-next-interesting) + (match-string-no-properties 1))) + +;; with thanks to org-mode +(defsubst auth-source-current-line (&optional pos) + (save-excursion + (and pos (goto-char pos)) + ;; works also in narrowed buffer, because we start at 1, not point-min + (+ (if (bolp) 1 0) (count-lines 1 (point))))) + +(defun auth-source-netrc-parse-entries(check max) + "Parse up to MAX netrc entries, passed by CHECK, from the current buffer." + (let ((adder (lambda(check alist all) + (when (and + alist + (> max (length all)) + (funcall check alist)) + (push alist all)) + all)) + item item2 all alist default) + (while (setq item (auth-source-netrc-parse-one)) + (setq default (equal item "default")) + ;; We're starting a new machine. Save the old one. + (when (and alist + (or default + (equal item "machine"))) + ;; (auth-source-do-trivia + ;; "auth-source-netrc-parse-entries: got entry %S" alist) + (setq all (funcall adder check alist all) + alist nil)) + ;; In default entries, we don't have a next token. + ;; We store them as ("machine" . t) + (if default + (push (cons "machine" t) alist) + ;; Not a default entry. Grab the next item. + (when (setq item2 (auth-source-netrc-parse-one)) + ;; Did we get a "machine" value? + (if (equal item2 "machine") + (progn + (gnus-error 1 + "%s: Unexpected 'machine' token at line %d" + "auth-source-netrc-parse-entries" + (auth-source-current-line)) + (forward-line 1)) + (push (cons item item2) alist))))) + + ;; Clean up: if there's an entry left over, use it. + (when alist + (setq all (funcall adder check alist all)) + ;; (auth-source-do-trivia + ;; "auth-source-netrc-parse-entries: got2 entry %S" alist) + ) + (nreverse all))) + (defvar auth-source-passphrase-alist nil) (defun auth-source-token-passphrase-callback-function (context key-id file) diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el deleted file mode 100644 index d4dd178fb70..00000000000 --- a/lisp/gnus/eww.el +++ /dev/null @@ -1,367 +0,0 @@ -;;; eww.el --- Emacs Web Wowser - -;; Copyright (C) 2013 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: html - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'shr) -(require 'url) -(require 'mm-url) - -(defvar eww-current-url nil) -(defvar eww-history nil) - -;;;###autoload -(defun eww (url) - "Fetch URL and render the page." - (interactive "sUrl: ") - (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url) - (setq url (concat "http://" url))) - (url-retrieve url 'eww-render (list url))) - -(defun eww-detect-charset (html-p) - (let ((case-fold-search t) - (pt (point))) - (or (and html-p - (re-search-forward - "<meta[\t\n\r ]+[^>]*charset=\\([^\t\n\r \"/>]+\\)" nil t) - (goto-char pt) - (match-string 1)) - (and (looking-at - "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)") - (match-string 1))))) - -(defun eww-render (status url &optional point) - (let* ((headers (eww-parse-headers)) - (content-type - (mail-header-parse-content-type - (or (cdr (assoc "content-type" headers)) - "text/plain"))) - (charset (intern - (downcase - (or (cdr (assq 'charset (cdr content-type))) - (eww-detect-charset (equal (car content-type) - "text/html")) - "utf8")))) - (data-buffer (current-buffer))) - (unwind-protect - (progn - (cond - ((equal (car content-type) "text/html") - (eww-display-html charset url)) - ((string-match "^image/" (car content-type)) - (eww-display-image)) - (t - (eww-display-raw charset))) - (when point - (goto-char point))) - (kill-buffer data-buffer)))) - -(defun eww-parse-headers () - (let ((headers nil)) - (goto-char (point-min)) - (while (and (not (eobp)) - (not (eolp))) - (when (looking-at "\\([^:]+\\): *\\(.*\\)") - (push (cons (downcase (match-string 1)) - (match-string 2)) - headers)) - (forward-line 1)) - (unless (eobp) - (forward-line 1)) - headers)) - -(defun eww-display-html (charset url) - (unless (eq charset 'utf8) - (decode-coding-region (point) (point-max) charset)) - (let ((document - (list - 'base (list (cons 'href url)) - (libxml-parse-html-region (point) (point-max))))) - (eww-setup-buffer) - (setq eww-current-url url) - (let ((inhibit-read-only t) - (shr-external-rendering-functions - '((form . eww-tag-form) - (input . eww-tag-input) - (select . eww-tag-select)))) - (shr-insert-document document) - (eww-convert-widgets)) - (goto-char (point-min)))) - -(defun eww-display-raw (charset) - (let ((data (buffer-substring (point) (point-max)))) - (eww-setup-buffer) - (let ((inhibit-read-only t)) - (insert data)) - (goto-char (point-min)))) - -(defun eww-display-image () - (let ((data (buffer-substring (point) (point-max)))) - (eww-setup-buffer) - (let ((inhibit-read-only t)) - (shr-put-image data nil)) - (goto-char (point-min)))) - -(defun eww-setup-buffer () - (pop-to-buffer (get-buffer-create "*eww*")) - (remove-overlays) - (setq widget-field-list nil) - (let ((inhibit-read-only t)) - (erase-buffer)) - (eww-mode)) - -(defvar eww-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'eww-quit) - (define-key map "g" 'eww-reload) - (define-key map [tab] 'widget-forward) - (define-key map [backtab] 'widget-backward) - (define-key map [delete] 'scroll-down-command) - (define-key map "\177" 'scroll-down-command) - (define-key map " " 'scroll-up-command) - (define-key map "p" 'eww-previous-url) - ;;(define-key map "n" 'eww-next-url) - map)) - -(define-derived-mode eww-mode nil "eww" - "Mode for browsing the web. - -\\{eww-mode-map}" - (set (make-local-variable 'eww-current-url) 'author) - (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url)) - -(defun eww-browse-url (url &optional new-window) - (let ((url-request-extra-headers - (append '(("User-Agent" . "eww/1.0")) - url-request-extra-headers))) - (push (list eww-current-url (point)) - eww-history) - (eww url))) - -(defun eww-quit () - "Exit the Emacs Web Wowser." - (interactive) - (setq eww-history nil) - (kill-buffer (current-buffer))) - -(defun eww-previous-url () - "Go to the previously displayed page." - (interactive) - (when (zerop (length eww-history)) - (error "No previous page")) - (let ((prev (pop eww-history))) - (url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev))))) - -(defun eww-reload () - "Reload the current page." - (interactive) - (url-retrieve eww-current-url 'eww-render - (list eww-current-url (point)))) - -;; Form support. - -(defvar eww-form nil) - -(defun eww-tag-form (cont) - (let ((eww-form - (list (assq :method cont) - (assq :action cont))) - (start (point))) - (shr-ensure-paragraph) - (shr-generic cont) - (shr-ensure-paragraph) - (when (> (point) start) - (put-text-property start (1+ start) - 'eww-form eww-form)))) - -(defun eww-tag-input (cont) - (let* ((start (point)) - (type (downcase (or (cdr (assq :type cont)) - "text"))) - (widget - (cond - ((equal type "submit") - (list - 'push-button - :notify 'eww-submit - :name (cdr (assq :name cont)) - :eww-form eww-form - (or (cdr (assq :value cont)) "Submit"))) - ((or (equal type "radio") - (equal type "checkbox")) - (list 'checkbox - :notify 'eww-click-radio - :name (cdr (assq :name cont)) - :checkbox-value (cdr (assq :value cont)) - :checkbox-type type - :eww-form eww-form - (cdr (assq :checked cont)))) - ((equal type "hidden") - (list 'hidden - :name (cdr (assq :name cont)) - :value (cdr (assq :value cont)))) - (t - (list - 'editable-field - :size (string-to-number - (or (cdr (assq :size cont)) - "40")) - :value (or (cdr (assq :value cont)) "") - :secret (and (equal type "password") ?*) - :action 'eww-submit - :name (cdr (assq :name cont)) - :eww-form eww-form))))) - (if (eq (car widget) 'hidden) - (when shr-final-table-render - (nconc eww-form (list widget))) - (apply 'widget-create widget)) - (put-text-property start (point) 'eww-widget widget) - (insert " "))) - -(defun eww-tag-select (cont) - (shr-ensure-paragraph) - (let ((menu (list 'menu-choice - :name (cdr (assq :name cont)) - :eww-form eww-form)) - (options nil) - (start (point))) - (dolist (elem cont) - (when (eq (car elem) 'option) - (when (cdr (assq :selected (cdr elem))) - (nconc menu (list :value - (cdr (assq :value (cdr elem)))))) - (push (list 'item - :value (cdr (assq :value (cdr elem))) - :tag (cdr (assq 'text (cdr elem)))) - options))) - ;; If we have no selected values, default to the first value. - (unless (plist-get (cdr menu) :value) - (nconc menu (list :value (nth 2 (car options))))) - (nconc menu options) - (apply 'widget-create menu) - (put-text-property start (point) 'eww-widget menu) - (shr-ensure-paragraph))) - -(defun eww-click-radio (widget &rest ignore) - (let ((form (plist-get (cdr widget) :eww-form)) - (name (plist-get (cdr widget) :name))) - (when (equal (plist-get (cdr widget) :type) "radio") - (if (widget-value widget) - ;; Switch all the other radio buttons off. - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((field (plist-get (overlay-properties overlay) 'button))) - (when (and (eq (plist-get (cdr field) :eww-form) form) - (equal name (plist-get (cdr field) :name))) - (unless (eq field widget) - (widget-value-set field nil))))) - (widget-value-set widget t))) - (eww-fix-widget-keymap))) - -(defun eww-submit (widget &rest ignore) - (let ((form (plist-get (cdr widget) :eww-form)) - (first-button t) - values) - (dolist (overlay (sort (overlays-in (point-min) (point-max)) - (lambda (o1 o2) - (< (overlay-start o1) (overlay-start o2))))) - (let ((field (or (plist-get (overlay-properties overlay) 'field) - (plist-get (overlay-properties overlay) 'button) - (plist-get (overlay-properties overlay) 'eww-hidden)))) - (when (eq (plist-get (cdr field) :eww-form) form) - (let ((name (plist-get (cdr field) :name))) - (when name - (cond - ((eq (car field) 'checkbox) - (when (widget-value field) - (push (cons name (plist-get (cdr field) :checkbox-value)) - values))) - ((eq (car field) 'eww-hidden) - (push (cons name (plist-get (cdr field) :value)) - values)) - ((eq (car field) 'push-button) - ;; We want the values from buttons if we hit a button, - ;; or we're submitting something and this is the first - ;; button displayed. - (when (or (and (eq (car widget) 'push-button) - (eq widget field)) - (and (not (eq (car widget) 'push-button)) - (eq (car field) 'push-button) - first-button)) - (setq first-button nil) - (push (cons name (widget-value field)) - values))) - (t - (push (cons name (widget-value field)) - values)))))))) - (dolist (elem form) - (when (and (consp elem) - (eq (car elem) 'hidden)) - (push (cons (plist-get (cdr elem) :name) - (plist-get (cdr elem) :value)) - values))) - (let ((shr-base eww-current-url)) - (if (and (stringp (cdr (assq :method form))) - (equal (downcase (cdr (assq :method form))) "post")) - (let ((url-request-method "POST") - (url-request-extra-headers - '(("Content-Type" . "application/x-www-form-urlencoded"))) - (url-request-data (mm-url-encode-www-form-urlencoded values))) - (eww-browse-url (shr-expand-url (cdr (assq :action form))))) - (eww-browse-url - (shr-expand-url - (concat - (cdr (assq :action form)) - "?" - (mm-url-encode-www-form-urlencoded values)))))))) - -(defun eww-convert-widgets () - (let ((start (point-min)) - widget) - ;; Some widgets come from different buffers (rendered for tables), - ;; so we need to nix out the list of widgets and recreate them. - (setq widget-field-list nil - widget-field-new nil) - (while (setq start (next-single-property-change start 'eww-widget)) - (setq widget (get-text-property start 'eww-widget)) - (goto-char start) - (let ((end (next-single-property-change start 'eww-widget))) - (dolist (overlay (overlays-in start end)) - (when (or (plist-get (overlay-properties overlay) 'button) - (plist-get (overlay-properties overlay) 'field)) - (delete-overlay overlay))) - (delete-region start end)) - (apply 'widget-create widget)) - (widget-setup) - (eww-fix-widget-keymap))) - -(defun eww-fix-widget-keymap () - (dolist (overlay (overlays-in (point-min) (point-max))) - (when (plist-get (overlay-properties overlay) 'button) - (overlay-put overlay 'local-map widget-keymap)))) - -(provide 'eww) - -;;; eww.el ends here diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 65f4b76ad19..5840aacd7a3 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -7866,7 +7866,9 @@ url is put as the `gnus-button-url' overlay property on the button." (let (gnus-article-mouse-face widget-mouse-face) (while points (gnus-article-add-button (pop points) (pop points) - 'gnus-button-push beg))) + 'gnus-button-push + (list beg (assq 'gnus-button-url-regexp + gnus-button-alist))))) (let ((overlay (gnus-make-overlay start end))) (gnus-overlay-put overlay 'evaporate t) (gnus-overlay-put overlay 'gnus-button-url diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 30ce184ed66..8050f5d59d7 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3654,6 +3654,10 @@ Uses the process/prefix convention." (expirable (if (gnus-group-total-expirable-p group) (cons nil (gnus-list-of-read-articles group)) (assq 'expire (gnus-info-marks info)))) + (articles-to-expire + (gnus-list-range-difference + (gnus-uncompress-sequence (cdr expirable)) + (cdr (assq 'unexist (gnus-info-marks info))))) (expiry-wait (gnus-group-find-parameter group 'expiry-wait)) (nnmail-expiry-target (or (gnus-group-find-parameter group 'expiry-target) @@ -3668,11 +3672,9 @@ Uses the process/prefix convention." ;; parameter. (let ((nnmail-expiry-wait-function nil) (nnmail-expiry-wait expiry-wait)) - (gnus-request-expire-articles - (gnus-uncompress-sequence (cdr expirable)) group)) + (gnus-request-expire-articles articles-to-expire group)) ;; Just expire using the normal expiry values. - (gnus-request-expire-articles - (gnus-uncompress-sequence (cdr expirable)) group)))) + (gnus-request-expire-articles articles-to-expire group)))) (gnus-close-group group)) (gnus-message 6 "Expiring articles in %s...done" (gnus-group-decoded-name group)) @@ -4661,7 +4663,7 @@ you the groups that have both dormant articles and cached articles." (let ((gnus-group-list-option 'limit)) (gnus-group-list-plus args))) -(declare-function gnus-mark-article-as-read "gnu-sum" (article &optional mark)) +(declare-function gnus-mark-article-as-read "gnus-sum" (article &optional mark)) (declare-function gnus-group-make-articles-read "gnus-sum" (group articles)) (defun gnus-group-mark-article-read (group article) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 48bb99bfbce..084af884930 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -2301,7 +2301,27 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-message 5 "Reading %s...done" newsrc-file))) ;; Convert old to new. - (gnus-convert-old-newsrc)))) + (gnus-convert-old-newsrc) + (gnus-clean-old-newsrc)))) + +(defun gnus-clean-old-newsrc (&optional force) + (when gnus-newsrc-file-version + ;; Remove totally bogus `unexists' entries. The name is + ;; `unexist'. + (dolist (info (cdr gnus-newsrc-alist)) + (let ((exist (assoc 'unexists (gnus-info-marks info)))) + (when exist + (gnus-info-set-marks + info (delete exist (gnus-info-marks info)))))) + (when (or force + (< (gnus-continuum-version gnus-newsrc-file-version) + (gnus-continuum-version "Ma Gnus v0.03"))) + ;; Remove old `exist' marks from old nnimap groups. + (dolist (info (cdr gnus-newsrc-alist)) + (let ((exist (assoc 'unexist (gnus-info-marks info)))) + (when exist + (gnus-info-set-marks + info (delete exist (gnus-info-marks info))))))))) (defun gnus-convert-old-newsrc () "Convert old newsrc formats into the current format, if needed." diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index c8f593ea403..9bae9f981bd 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1524,6 +1524,9 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") (defvar gnus-newsgroup-seen nil "Range of seen articles in the current newsgroup.") +(defvar gnus-newsgroup-unexist nil + "Range of unexistent articles in the current newsgroup.") + (defvar gnus-newsgroup-articles nil "List of articles in the current newsgroup.") @@ -1571,6 +1574,7 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") gnus-newsgroup-killed gnus-newsgroup-unseen gnus-newsgroup-seen + gnus-newsgroup-unexist gnus-newsgroup-cached gnus-newsgroup-downloadable gnus-newsgroup-undownloaded @@ -3653,18 +3657,17 @@ buffer that was in action when the last article was fetched." (or (car (funcall gnus-extract-address-components from)) from)) -(defun gnus-summary-from-or-to-or-newsgroups (header from) +(defun gnus-summary-from-or-to-or-newsgroups (header gnus-tmp-from) (let ((mail-parse-charset gnus-newsgroup-charset) - (ignored-from-addresses (gnus-ignored-from-addresses)) - ;; Is it really necessary to do this next part for each summary line? - ;; Luckily, doesn't seem to slow things down much. - (mail-parse-ignored-charsets - (with-current-buffer gnus-summary-buffer - gnus-newsgroup-ignored-charsets)) - (address (cadr (gnus-extract-address-components from)))) + (ignored-from-addresses (gnus-ignored-from-addresses)) + ;; Is it really necessary to do this next part for each summary line? + ;; Luckily, doesn't seem to slow things down much. + (mail-parse-ignored-charsets + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (or (and ignored-from-addresses - (string-match ignored-from-addresses address) + (string-match ignored-from-addresses gnus-tmp-from) (let ((extra-headers (mail-header-extra header)) to newsgroups) @@ -3679,11 +3682,13 @@ buffer that was in action when the last article was fetched." (cdr (assq 'Newsgroups extra-headers)) (and (memq 'Newsgroups gnus-extra-headers) - (eq (car (gnus-find-method-for-group - gnus-newsgroup-name)) 'nntp) + (eq (car (gnus-find-method-for-group + gnus-newsgroup-name)) 'nntp) (gnus-group-real-name gnus-newsgroup-name)))) (concat gnus-summary-newsgroup-prefix newsgroups))))) - (gnus-string-mark-left-to-right (gnus-summary-extract-address-component from))))) + (gnus-string-mark-left-to-right + (inline + (gnus-summary-extract-address-component gnus-tmp-from)))))) (defun gnus-summary-insert-line (gnus-tmp-header gnus-tmp-level gnus-tmp-current @@ -5789,6 +5794,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." "Find out what articles the user wants to read." (let* ((only-read-p t) (articles + (gnus-list-range-difference ;; Select all articles if `read-all' is non-nil, or if there ;; are no unread articles. (if (or read-all @@ -5815,7 +5821,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq only-read-p nil) (gnus-sorted-nunion (gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked) - gnus-newsgroup-unreads))) + gnus-newsgroup-unreads)) + (cdr (assq 'unexist (gnus-info-marks (gnus-get-info group)))))) (scored-list (gnus-killed-articles gnus-newsgroup-killed articles)) (scored (length scored-list)) (number (length articles)) @@ -5985,7 +5992,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." (and (numberp (car articles)) (> min (car articles))))) (pop articles)) - (set var articles)))))))) + (set var articles)) + ((eq mark 'unexist) + (set var (cdr marks))))))))) (defun gnus-update-missing-marks (missing) "Go through the list of MISSING articles and remove them from the mark lists." @@ -6061,7 +6070,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-active gnus-newsgroup-name) del)) (push (list del 'del (list (cdr type))) delta-marks)))) - (when list + (when (or list + (eq (cdr type) 'unexist)) (push (cons (cdr type) list) newmarked))) (when delta-marks @@ -10305,16 +10315,19 @@ This will be the case if the article has both been mailed and posted." 'request-expire-articles gnus-newsgroup-name)) ;; This backend supports expiry. (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) - (expirable (if total - (progn - ;; We need to update the info for - ;; this group for `gnus-list-of-read-articles' - ;; to give us the right answer. - (gnus-run-hooks 'gnus-exit-group-hook) - (gnus-summary-update-info) - (gnus-list-of-read-articles gnus-newsgroup-name)) - (setq gnus-newsgroup-expirable - (sort gnus-newsgroup-expirable '<)))) + (expirable + (gnus-list-range-difference + (if total + (progn + ;; We need to update the info for + ;; this group for `gnus-list-of-read-articles' + ;; to give us the right answer. + (gnus-run-hooks 'gnus-exit-group-hook) + (gnus-summary-update-info) + (gnus-list-of-read-articles gnus-newsgroup-name)) + (setq gnus-newsgroup-expirable + (sort gnus-newsgroup-expirable '<))) + gnus-newsgroup-unexist)) (expiry-wait (if now 'immediate (gnus-group-find-parameter gnus-newsgroup-name 'expiry-wait))) @@ -12847,7 +12860,9 @@ If ALL is a number, fetch this number of articles." ;; Some nntp servers lie about their active range. When ;; this happens, the active range can be in the millions. ;; Use a compressed range to avoid creating a huge list. - (gnus-range-difference (list gnus-newsgroup-active) old)) + (gnus-range-difference + (gnus-range-difference (list gnus-newsgroup-active) old) + gnus-newsgroup-unexist)) (setq len (gnus-range-length older)) (cond ((null older) nil) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 2c2dbd90c56..9a927a1cfab 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2636,10 +2636,11 @@ a string, be sure to use a valid format, see RFC 2616." (scored . score) (saved . save) (cached . cache) (downloadable . download) (unsendable . unsend) (forwarded . forward) - (seen . seen))) + (seen . seen) (unexist . unexist))) (defconst gnus-article-special-mark-lists '((seen range) + (unexist range) (killed range) (bookmark tuple) (uid tuple) @@ -2654,7 +2655,7 @@ a string, be sure to use a valid format, see RFC 2616." ;; `score' is not a proper mark ;; `bookmark': don't propagated it, or fix the bug in update-mark. (defconst gnus-article-unpropagated-mark-lists - '(seen cache download unsend score bookmark) + '(seen cache download unsend score bookmark unexist) "Marks that shouldn't be propagated to back ends. Typical marks are those that make no sense in a standalone back end, such as a mark that says whether an article is stored in the cache diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index b025f7cc601..98be1c5def2 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1809,6 +1809,7 @@ If RECURSIVE, search recursively." (libxml-parse-html-region (point-min) (point-max)))) (unless (bobp) (insert "\n")) + (mm-convert-shr-links) (mm-handle-set-undisplayer handle `(lambda () @@ -1816,6 +1817,25 @@ If RECURSIVE, search recursively." (delete-region ,(point-min-marker) ,(point-max-marker)))))))) +(defvar shr-map) + +(autoload 'widget-convert-button "wid-edit") + +(defun mm-convert-shr-links () + (let ((start (point-min)) + end) + (while (and start + (< start (point-max))) + (when (setq start (text-property-not-all start (point-max) 'shr-url nil)) + (setq end (next-single-property-change start 'shr-url nil (point-max))) + (widget-convert-button + 'url-link start end + :help-echo (get-text-property start 'help-echo) + :keymap shr-map + (get-text-property start 'shr-url)) + (put-text-property start end 'local-map nil) + (setq start end))))) + (defun mm-handle-filename (handle) "Return filename of HANDLE if any." (or (mail-content-type-get (mm-handle-type handle) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 5d122dfbe40..2c2187a5f8d 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -146,6 +146,12 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." :group 'mime-security :type 'boolean) +(defcustom mml2015-maximum-key-image-dimension 64 + "The maximum dimension (width or height) of any key images." + :version "24.4" + :group 'mime-security + :type 'integer) + ;; Extract plaintext from cleartext signature. IMO, this kind of task ;; should be done by GnuPG rather than Elisp, but older PGP backends ;; (such as Mailcrypt, and PGG) discard the output from GnuPG. @@ -871,7 +877,11 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (shell-quote-argument epg-gpg-program) key-id)))) (when (> (length data) 0) (insert (substring data 16)) - (create-image (buffer-string) nil t))))) + (condition-case nil + (gnus-create-image (buffer-string) nil t) + (error)))))) + +(autoload 'gnus-rescale-image "gnus-util") (defun mml2015-epg-key-image-to-string (key-id) "Return a string with the image of a key, if any" @@ -879,7 +889,12 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (key-image (mml2015-epg-key-image key-id))) (when key-image (setq result " ") - (put-text-property 1 2 'display key-image result)) + (put-text-property + 1 2 'display + (gnus-rescale-image key-image + (cons mml2015-maximum-key-image-dimension + mml2015-maximum-key-image-dimension)) + result)) result)) (defun mml2015-epg-signature-to-string (signature) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 8fdd69b47da..4d9320b995f 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -82,7 +82,8 @@ back on `network'.") (defvoo nnimap-inbox nil "The mail box where incoming mail arrives and should be split out of. -For example, \"INBOX\".") +This can be a string or a list of strings +For example, \"INBOX\" or (\"INBOX\" \"SENT\").") (defvoo nnimap-split-methods nil "How mail is split. @@ -123,6 +124,16 @@ will fetch all parts that have types that match that string. A likely value would be \"text/\" to automatically fetch all textual parts.") +(defgroup nnimap nil + "IMAP for Gnus." + :group 'gnus) + +(defcustom nnimap-request-articles-find-limit nil + "Limit the number of articles to look for after moving an article." + :type 'integer + :version "24.3" + :group 'nnimap) + (defvar nnimap-process nil) (defvar nnimap-status-string "") @@ -173,7 +184,7 @@ textual parts.") (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (erase-buffer) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (erase-buffer) (nnimap-wait-for-response @@ -567,10 +578,10 @@ textual parts.") (when group (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer - (let ((result (nnimap-possibly-change-group group server)) + (let ((result (nnimap-change-group group server)) parts structure) (when (stringp article) - (setq article (nnimap-find-article-by-message-id group article))) + (setq article (nnimap-find-article-by-message-id group server article))) (when (and result article) (erase-buffer) @@ -599,10 +610,10 @@ textual parts.") (deffoo nnimap-request-head (article &optional group server to-buffer) (when group (setq group (nnimap-decode-gnus-group group))) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (when (stringp article) - (setq article (nnimap-find-article-by-message-id group article))) + (setq article (nnimap-find-article-by-message-id group server article))) (if (null article) nil (nnimap-get-whole-article @@ -751,7 +762,7 @@ textual parts.") (deffoo nnimap-request-group (group &optional server dont-check info) (setq group (nnimap-decode-gnus-group group)) - (let ((result (nnimap-possibly-change-group + (let ((result (nnimap-change-group ;; Don't SELECT the group if we're going to select it ;; later, anyway. (if (and (not dont-check) @@ -801,19 +812,19 @@ textual parts.") (deffoo nnimap-request-create-group (group &optional server args) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) (deffoo nnimap-request-delete-group (group &optional force server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) (deffoo nnimap-request-rename-group (group new-name &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (nnimap-unselect-group) (car (nnimap-command "RENAME %S %S" @@ -828,7 +839,7 @@ textual parts.") (deffoo nnimap-request-expunge-group (group &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "EXPUNGE"))))) @@ -856,6 +867,8 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) (setq group (nnimap-decode-gnus-group group)) + (when internal-move-group + (setq internal-move-group (nnimap-decode-gnus-group internal-move-group))) (with-temp-buffer (mm-disable-multibyte) (when (funcall (if internal-move-group @@ -876,11 +889,12 @@ textual parts.") (cons internal-move-group (or (nnimap-find-uid-response "COPYUID" (cadr result)) (nnimap-find-article-by-message-id - internal-move-group message-id))))) + internal-move-group server message-id + nnimap-request-articles-find-limit))))) ;; Move the article to a different method. (let ((result (eval accept-form))) (when result - (nnimap-possibly-change-group group server) + (nnimap-change-group group server) (nnimap-delete-article article) result))))))) @@ -889,7 +903,7 @@ textual parts.") (cond ((null articles) nil) - ((not (nnimap-possibly-change-group group server)) + ((not (nnimap-change-group group server)) articles) ((and force (eq nnmail-expiry-target 'delete)) @@ -926,7 +940,7 @@ textual parts.") (gnus-server-equal (gnus-group-method nnmail-expiry-target) (gnus-server-to-method (format "nnimap:%s" server)))) - (and (nnimap-possibly-change-group group server) + (and (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (nnheader-message 7 "Expiring articles from %s: %s" group articles) (nnimap-command @@ -956,7 +970,7 @@ textual parts.") (when target (push article deleted-articles)))))))) ;; Change back to the current group again. - (nnimap-possibly-change-group group server) + (nnimap-change-group group server) (setq deleted-articles (nreverse deleted-articles)) (nnimap-delete-article (gnus-compress-sequence deleted-articles)) deleted-articles)) @@ -978,23 +992,37 @@ textual parts.") (cdr (assoc "SEARCH" (cdr result)))))))))) -(defun nnimap-find-article-by-message-id (group message-id) +(defun nnimap-find-article-by-message-id (group server message-id + &optional limit) + "Search for message with MESSAGE-ID in GROUP from SERVER. +If LIMIT, first try to limit the search to the N last articles." (with-current-buffer (nnimap-buffer) (erase-buffer) - (unless (or (not group) (equal group (nnimap-group nnimap-object))) - (setf (nnimap-group nnimap-object) nil) - (setf (nnimap-examined nnimap-object) group) - (nnimap-send-command "EXAMINE %S" (utf7-encode group t))) - (let ((sequence - (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id)) - article result) - (setq result (nnimap-wait-for-response sequence)) - (when (and result - (car (setq result (nnimap-parse-response)))) - ;; Select the last instance of the message in the group. - (and (setq article - (car (last (cdr (assoc "SEARCH" (cdr result)))))) - (string-to-number article)))))) + (let* ((change-group-result (nnimap-change-group group server nil t)) + (number-of-article + (and (listp change-group-result) + (catch 'found + (dolist (result (cdr change-group-result)) + (when (equal "EXISTS" (cadr result)) + (throw 'found (car result))))))) + (sequence + (nnimap-send-command + "UID SEARCH%s HEADER Message-Id %S" + (if (and limit number-of-article) + ;; The -1 is because IMAP message + ;; numbers are one-based rather than + ;; zero-based. + (format " %s:*" (- (string-to-number number-of-article) + limit -1)) + "") + message-id))) + (when (nnimap-wait-for-response sequence) + (let ((article (car (last (cdr (assoc "SEARCH" + (nnimap-parse-response))))))) + (if article + (string-to-number article) + (when (and limit number-of-article) + (nnimap-find-article-by-message-id group server message-id)))))))) (defun nnimap-delete-article (articles) (with-current-buffer (nnimap-buffer) @@ -1015,11 +1043,14 @@ textual parts.") (deffoo nnimap-request-scan (&optional group server) (when group (setq group (nnimap-decode-gnus-group group))) - (when (and (nnimap-possibly-change-group nil server) + (when (and (nnimap-change-group nil server) nnimap-inbox nnimap-split-methods) (nnheader-message 7 "nnimap %s splitting mail..." server) - (nnimap-split-incoming-mail) + (if (listp nnimap-inbox) + (dolist (nnimap-inbox nnimap-inbox) + (nnimap-split-incoming-mail)) + (nnimap-split-incoming-mail)) (nnheader-message 7 "nnimap %s splitting mail...done" server))) (defun nnimap-marks-to-flags (marks) @@ -1031,7 +1062,7 @@ textual parts.") (deffoo nnimap-request-update-group-status (group status &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (let ((command (assoc status '((subscribe "SUBSCRIBE") @@ -1042,7 +1073,7 @@ textual parts.") (deffoo nnimap-request-set-mark (group actions &optional server) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) (erase-buffer) @@ -1067,7 +1098,7 @@ textual parts.") (deffoo nnimap-request-accept-article (group &optional server last) (setq group (nnimap-decode-gnus-group group)) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (nnmail-check-syntax) (let ((message-id (message-field-value "message-id")) sequence message) @@ -1099,7 +1130,8 @@ textual parts.") (cons group (or (nnimap-find-uid-response "APPENDUID" (car result)) (nnimap-find-article-by-message-id - group message-id)))))))))) + group server message-id + nnimap-request-articles-find-limit)))))))))) (defun nnimap-process-quirk (greeting-match type data) (when (and (nnimap-greeting nnimap-object) @@ -1145,7 +1177,7 @@ textual parts.") (deffoo nnimap-request-replace-article (article group buffer) (setq group (nnimap-decode-gnus-group group)) (let (group-art) - (when (and (nnimap-possibly-change-group group nil) + (when (and (nnimap-change-group group) ;; Put the article into the group. (with-current-buffer buffer (setq group-art @@ -1180,8 +1212,17 @@ textual parts.") groups)))) (nreverse groups))) +(defun nnimap-get-responses (sequences) + (let (responses) + (dolist (sequence sequences) + (goto-char (point-min)) + (when (re-search-forward (format "^%d " sequence) nil t) + (push (list sequence (nnimap-parse-response)) + responses))) + responses)) + (deffoo nnimap-request-list (&optional server) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer nntp-server-buffer (erase-buffer) (let ((groups @@ -1228,7 +1269,7 @@ textual parts.") t))))) (deffoo nnimap-request-newgroups (date &optional server) - (when (nnimap-possibly-change-group nil server) + (when (nnimap-change-group nil server) (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (group (with-current-buffer (nnimap-buffer) @@ -1239,14 +1280,15 @@ textual parts.") t))) (deffoo nnimap-retrieve-group-data-early (server infos) - (when (and (nnimap-possibly-change-group nil server) + (when (and (nnimap-change-group nil server) infos) (with-current-buffer (nnimap-buffer) (erase-buffer) (setf (nnimap-group nnimap-object) nil) (setf (nnimap-initial-resync nnimap-object) 0) (let ((qresyncp (nnimap-capability "QRESYNC")) - params groups sequences active uidvalidity modseq group) + params groups sequences active uidvalidity modseq group + unexist) ;; Go through the infos and gather the data needed to know ;; what and how to request the data. (dolist (info infos) @@ -1254,13 +1296,15 @@ textual parts.") group (nnimap-decode-gnus-group (gnus-group-real-name (gnus-info-group info))) active (cdr (assq 'active params)) + unexist (assq 'unexist (gnus-info-marks info)) uidvalidity (cdr (assq 'uidvalidity params)) modseq (cdr (assq 'modseq params))) (setf (nnimap-examined nnimap-object) group) (if (and qresyncp uidvalidity active - modseq) + modseq + unexist) (push (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" (utf7-encode group t) @@ -1279,11 +1323,10 @@ textual parts.") ;; is read-only or not. "SELECT")) start) - (if (and active uidvalidity) + (if (and active uidvalidity unexist) ;; Fetch the last 100 flags. (setq start (max 1 (- (cdr active) 100))) - (setf (nnimap-initial-resync nnimap-object) - (1+ (nnimap-initial-resync nnimap-object))) + (incf (nnimap-initial-resync nnimap-object)) (setq start 1)) (push (list (nnimap-send-command "%s %S" command (utf7-encode group t)) @@ -1303,7 +1346,7 @@ textual parts.") (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) (when (and sequences - (nnimap-possibly-change-group nil server t) + (nnimap-change-group nil server t) ;; Check that the process is still alive. (get-buffer-process (nnimap-buffer)) (memq (process-status (get-buffer-process (nnimap-buffer))) @@ -1462,6 +1505,25 @@ textual parts.") (setq new-marks (gnus-range-nconcat old-marks new-marks))) (when new-marks (push (cons (car type) new-marks) marks))))) + ;; Keep track of non-existing articles. + (let* ((old-unexists (assq 'unexist marks)) + (active (gnus-active group)) + (unexists + (if completep + (gnus-range-difference + active + (gnus-compress-sequence existing)) + (gnus-add-to-range + (cdr old-unexists) + (gnus-list-range-difference + existing (gnus-active group)))))) + (when (> (car active) 1) + (setq unexists (gnus-range-add + (cons 1 (1- (car active))) + unexists))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) ;; Tell Gnus whether there are any \Recent messages in any of ;; the groups. @@ -1505,6 +1567,14 @@ textual parts.") (gnus-sorted-complement existing new-marks)))) (when ticks (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)) + ;; Add vanished to the list of unexisting articles. + (when vanished + (let* ((old-unexists (assq 'unexist marks)) + (unexists (gnus-range-add (cdr old-unexists) vanished))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) (defun nnimap-imap-ranges-to-gnus-ranges (irange) @@ -1642,7 +1712,7 @@ textual parts.") (setq nnimap-status-string "Read-only server") nil) -(defvar gnus-refer-thread-use-nnir) ; gnus-sum +(defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el (declare-function gnus-fetch-headers "gnus-sum" (articles &optional limit force-new dependencies)) @@ -1653,7 +1723,7 @@ textual parts.") (setq group (nnimap-decode-gnus-group group))) (if gnus-refer-thread-use-nnir (nnir-search-thread header) - (when (nnimap-possibly-change-group group server) + (when (nnimap-change-group group server) (let* ((cmd (nnimap-make-thread-query header)) (result (with-current-buffer (nnimap-buffer) (nnimap-command "UID SEARCH %s" cmd)))) @@ -1664,7 +1734,14 @@ textual parts.") (cdr (assoc "SEARCH" (cdr result)))))) nil t)))))) -(defun nnimap-possibly-change-group (group server &optional no-reconnect) +(defun nnimap-change-group (group &optional server no-reconnect read-only) + "Change group to GROUP if non-nil. +If SERVER is set, check that server is connected, otherwise retry +to reconnect, unless NO-RECONNECT is set to t. Return nil if +unsuccessful in connecting. +If GROUP is nil, return t. +If READ-ONLY is set, send EXAMINE rather than SELECT to the server. +Return the server's response to the SELECT or EXAMINE command." (let ((open-result t)) (when (and server (not (nnimap-server-opened server))) @@ -1676,13 +1753,15 @@ textual parts.") t) (t (with-current-buffer (nnimap-buffer) - (if (equal group (nnimap-group nnimap-object)) - t - (let ((result (nnimap-command "SELECT %S" (utf7-encode group t)))) - (when (car result) - (setf (nnimap-group nnimap-object) group - (nnimap-select-result nnimap-object) result) - result)))))))) + (let ((result (nnimap-command "%s %S" + (if read-only + "EXAMINE" + "SELECT") + (utf7-encode group t)))) + (when (car result) + (setf (nnimap-group nnimap-object) group + (nnimap-select-result nnimap-object) result) + result))))))) (defun nnimap-find-connection (buffer) "Find the connection delivering to BUFFER." @@ -1718,15 +1797,24 @@ textual parts.") (defvar nnimap-record-commands nil "If non-nil, log commands to the \"*imap log*\" buffer.") +(defun nnimap-log-buffer () + (let ((name "*imap log*")) + (or (get-buffer name) + (with-current-buffer (get-buffer-create name) + (when (boundp 'window-point-insertion-type) + (make-local-variable 'window-point-insertion-type) + (setq window-point-insertion-type t)) + (current-buffer))))) + (defun nnimap-log-command (command) (when nnimap-record-commands - (with-current-buffer (get-buffer-create "*imap log*") + (with-current-buffer (nnimap-log-buffer) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") - " [" nnimap-address "] " - (if nnimap-inhibit-logging - "(inhibited)\n" - command)))) + " [" nnimap-address "] " + (if nnimap-inhibit-logging + "(inhibited)\n" + command)))) command) (defun nnimap-command (&rest args) @@ -1865,15 +1953,6 @@ textual parts.") (forward-line 1))) (buffer-substring (point) end)))) -(defun nnimap-get-responses (sequences) - (let (responses) - (dolist (sequence sequences) - (goto-char (point-min)) - (when (re-search-forward (format "^%d " sequence) nil t) - (push (list sequence (nnimap-parse-response)) - responses))) - responses)) - (defvar nnimap-incoming-split-list nil) (defun nnimap-fetch-inbox (articles) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 120149ae0fb..22dee30e8fa 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -288,7 +288,7 @@ is `(valuefunc member)'." (eval-when-compile (autoload 'nnimap-buffer "nnimap") (autoload 'nnimap-command "nnimap") - (autoload 'nnimap-possibly-change-group "nnimap") + (autoload 'nnimap-change-group "nnimap") (autoload 'nnimap-make-thread-query "nnimap") (autoload 'gnus-registry-action "gnus-registry") (autoload 'gnus-registry-get-id-key "gnus-registry") @@ -973,7 +973,7 @@ details on the language and supported extensions." #'(lambda (group) (let (artlist) (condition-case () - (when (nnimap-possibly-change-group + (when (nnimap-change-group (gnus-group-short-name group) server) (with-current-buffer (nnimap-buffer) (message "Searching %s..." group) diff --git a/lisp/gnus/shr-color.el b/lisp/gnus/shr-color.el deleted file mode 100644 index 21f1fc4f004..00000000000 --- a/lisp/gnus/shr-color.el +++ /dev/null @@ -1,363 +0,0 @@ -;;; shr-color.el --- Simple HTML Renderer color management - -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. - -;; Author: Julien Danjou <julien@danjou.info> -;; Keywords: html - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package handles colors display for shr. - -;;; Code: - -(require 'color) -(eval-when-compile (require 'cl)) - -(defgroup shr-color nil - "Simple HTML Renderer colors" - :group 'shr) - -(defcustom shr-color-visible-luminance-min 40 - "Minimum luminance distance between two colors to be considered visible. -Must be between 0 and 100." - :group 'shr-color - :type 'number) - -(defcustom shr-color-visible-distance-min 5 - "Minimum color distance between two colors to be considered visible. -This value is used to compare result for `ciede2000'. It's an -absolute value without any unit." - :group 'shr-color - :type 'integer) - -(defconst shr-color-html-colors-alist - '(("AliceBlue" . "#F0F8FF") - ("AntiqueWhite" . "#FAEBD7") - ("Aqua" . "#00FFFF") - ("Aquamarine" . "#7FFFD4") - ("Azure" . "#F0FFFF") - ("Beige" . "#F5F5DC") - ("Bisque" . "#FFE4C4") - ("Black" . "#000000") - ("BlanchedAlmond" . "#FFEBCD") - ("Blue" . "#0000FF") - ("BlueViolet" . "#8A2BE2") - ("Brown" . "#A52A2A") - ("BurlyWood" . "#DEB887") - ("CadetBlue" . "#5F9EA0") - ("Chartreuse" . "#7FFF00") - ("Chocolate" . "#D2691E") - ("Coral" . "#FF7F50") - ("CornflowerBlue" . "#6495ED") - ("Cornsilk" . "#FFF8DC") - ("Crimson" . "#DC143C") - ("Cyan" . "#00FFFF") - ("DarkBlue" . "#00008B") - ("DarkCyan" . "#008B8B") - ("DarkGoldenRod" . "#B8860B") - ("DarkGray" . "#A9A9A9") - ("DarkGrey" . "#A9A9A9") - ("DarkGreen" . "#006400") - ("DarkKhaki" . "#BDB76B") - ("DarkMagenta" . "#8B008B") - ("DarkOliveGreen" . "#556B2F") - ("Darkorange" . "#FF8C00") - ("DarkOrchid" . "#9932CC") - ("DarkRed" . "#8B0000") - ("DarkSalmon" . "#E9967A") - ("DarkSeaGreen" . "#8FBC8F") - ("DarkSlateBlue" . "#483D8B") - ("DarkSlateGray" . "#2F4F4F") - ("DarkSlateGrey" . "#2F4F4F") - ("DarkTurquoise" . "#00CED1") - ("DarkViolet" . "#9400D3") - ("DeepPink" . "#FF1493") - ("DeepSkyBlue" . "#00BFFF") - ("DimGray" . "#696969") - ("DimGrey" . "#696969") - ("DodgerBlue" . "#1E90FF") - ("FireBrick" . "#B22222") - ("FloralWhite" . "#FFFAF0") - ("ForestGreen" . "#228B22") - ("Fuchsia" . "#FF00FF") - ("Gainsboro" . "#DCDCDC") - ("GhostWhite" . "#F8F8FF") - ("Gold" . "#FFD700") - ("GoldenRod" . "#DAA520") - ("Gray" . "#808080") - ("Grey" . "#808080") - ("Green" . "#008000") - ("GreenYellow" . "#ADFF2F") - ("HoneyDew" . "#F0FFF0") - ("HotPink" . "#FF69B4") - ("IndianRed" . "#CD5C5C") - ("Indigo" . "#4B0082") - ("Ivory" . "#FFFFF0") - ("Khaki" . "#F0E68C") - ("Lavender" . "#E6E6FA") - ("LavenderBlush" . "#FFF0F5") - ("LawnGreen" . "#7CFC00") - ("LemonChiffon" . "#FFFACD") - ("LightBlue" . "#ADD8E6") - ("LightCoral" . "#F08080") - ("LightCyan" . "#E0FFFF") - ("LightGoldenRodYellow" . "#FAFAD2") - ("LightGray" . "#D3D3D3") - ("LightGrey" . "#D3D3D3") - ("LightGreen" . "#90EE90") - ("LightPink" . "#FFB6C1") - ("LightSalmon" . "#FFA07A") - ("LightSeaGreen" . "#20B2AA") - ("LightSkyBlue" . "#87CEFA") - ("LightSlateGray" . "#778899") - ("LightSlateGrey" . "#778899") - ("LightSteelBlue" . "#B0C4DE") - ("LightYellow" . "#FFFFE0") - ("Lime" . "#00FF00") - ("LimeGreen" . "#32CD32") - ("Linen" . "#FAF0E6") - ("Magenta" . "#FF00FF") - ("Maroon" . "#800000") - ("MediumAquaMarine" . "#66CDAA") - ("MediumBlue" . "#0000CD") - ("MediumOrchid" . "#BA55D3") - ("MediumPurple" . "#9370D8") - ("MediumSeaGreen" . "#3CB371") - ("MediumSlateBlue" . "#7B68EE") - ("MediumSpringGreen" . "#00FA9A") - ("MediumTurquoise" . "#48D1CC") - ("MediumVioletRed" . "#C71585") - ("MidnightBlue" . "#191970") - ("MintCream" . "#F5FFFA") - ("MistyRose" . "#FFE4E1") - ("Moccasin" . "#FFE4B5") - ("NavajoWhite" . "#FFDEAD") - ("Navy" . "#000080") - ("OldLace" . "#FDF5E6") - ("Olive" . "#808000") - ("OliveDrab" . "#6B8E23") - ("Orange" . "#FFA500") - ("OrangeRed" . "#FF4500") - ("Orchid" . "#DA70D6") - ("PaleGoldenRod" . "#EEE8AA") - ("PaleGreen" . "#98FB98") - ("PaleTurquoise" . "#AFEEEE") - ("PaleVioletRed" . "#D87093") - ("PapayaWhip" . "#FFEFD5") - ("PeachPuff" . "#FFDAB9") - ("Peru" . "#CD853F") - ("Pink" . "#FFC0CB") - ("Plum" . "#DDA0DD") - ("PowderBlue" . "#B0E0E6") - ("Purple" . "#800080") - ("Red" . "#FF0000") - ("RosyBrown" . "#BC8F8F") - ("RoyalBlue" . "#4169E1") - ("SaddleBrown" . "#8B4513") - ("Salmon" . "#FA8072") - ("SandyBrown" . "#F4A460") - ("SeaGreen" . "#2E8B57") - ("SeaShell" . "#FFF5EE") - ("Sienna" . "#A0522D") - ("Silver" . "#C0C0C0") - ("SkyBlue" . "#87CEEB") - ("SlateBlue" . "#6A5ACD") - ("SlateGray" . "#708090") - ("SlateGrey" . "#708090") - ("Snow" . "#FFFAFA") - ("SpringGreen" . "#00FF7F") - ("SteelBlue" . "#4682B4") - ("Tan" . "#D2B48C") - ("Teal" . "#008080") - ("Thistle" . "#D8BFD8") - ("Tomato" . "#FF6347") - ("Turquoise" . "#40E0D0") - ("Violet" . "#EE82EE") - ("Wheat" . "#F5DEB3") - ("White" . "#FFFFFF") - ("WhiteSmoke" . "#F5F5F5") - ("Yellow" . "#FFFF00") - ("YellowGreen" . "#9ACD32")) - "Alist of HTML colors. -Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).") - -(defun shr-color-relative-to-absolute (number) - "Convert a relative NUMBER to absolute. -If NUMBER is absolute, return NUMBER. -This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." - (let ((string-length (- (length number) 1))) - ;; Is this a number with %? - (if (eq (elt number string-length) ?%) - (/ (* (string-to-number (substring number 0 string-length)) 255) 100) - (string-to-number number)))) - -(defun shr-color-hue-to-rgb (x y h) - "Convert X Y H to RGB value." - (when (< h 0) (incf h)) - (when (> h 1) (decf h)) - (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6))) - ((< h 0.5) y) - ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) - (t x))) - -(defun shr-color-hsl-to-rgb-fractions (h s l) - "Convert H S L to fractional RGB values." - (let (m1 m2) - (if (<= l 0.5) - (setq m2 (* l (+ s 1))) - (setq m2 (- (+ l s) (* l s)))) - (setq m1 (- (* l 2) m2)) - (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0))) - (shr-color-hue-to-rgb m1 m2 h) - (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0)))))) - -(defun shr-color->hexadecimal (color) - "Convert any color format to hexadecimal representation. -Like rgb() or hsl()." - (when color - (cond - ;; Hexadecimal color: #abc or #aabbcc - ((string-match - "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" - color) - (match-string 1 color)) - ;; rgb() or rgba() colors - ((or (string-match - "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" - color) - (string-match - "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" - color)) - (format "#%02X%02X%02X" - (shr-color-relative-to-absolute (match-string-no-properties 1 color)) - (shr-color-relative-to-absolute (match-string-no-properties 2 color)) - (shr-color-relative-to-absolute (match-string-no-properties 3 color)))) - ;; hsl() or hsla() colors - ((or (string-match - "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)" - color) - (string-match - "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" - color)) - (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) - (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) - (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) - (destructuring-bind (r g b) - (shr-color-hsl-to-rgb-fractions h s l) - (color-rgb-to-hex r g b)))) - ;; Color names - ((cdr (assoc-string color shr-color-html-colors-alist t))) - ;; Unrecognized color :( - (t - nil)))) - -(defun shr-color-set-minimum-interval (val1 val2 min max interval - &optional fixed) - "Set minimum interval between VAL1 and VAL2 to INTERVAL. -The values are bound by MIN and MAX. -If FIXED is t, then VAL1 will not be touched." - (let ((diff (abs (- val1 val2)))) - (unless (>= diff interval) - (if fixed - (let* ((missing (- interval diff)) - ;; If val2 > val1, try to increase val2 - ;; That's the "good direction" - (val2-good-direction - (if (> val2 val1) - (min max (+ val2 missing)) - (max min (- val2 missing)))) - (diff-val2-good-direction-val1 (abs (- val2-good-direction val1)))) - (if (>= diff-val2-good-direction-val1 interval) - (setq val2 val2-good-direction) - ;; Good-direction is not so good, compute bad-direction - (let* ((val2-bad-direction - (if (> val2 val1) - (max min (- val1 interval)) - (min max (+ val1 interval)))) - (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1)))) - (if (>= diff-val2-bad-direction-val1 interval) - (setq val2 val2-bad-direction) - ;; Still not good, pick the best and prefer good direction - (setq val2 - (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1) - val2-good-direction - val2-bad-direction)))))) - ;; No fixed, move val1 and val2 - (let ((missing (/ (- interval diff) 2.0))) - (if (< val1 val2) - (setq val1 (max min (- val1 missing)) - val2 (min max (+ val2 missing))) - (setq val2 (max min (- val2 missing)) - val1 (min max (+ val1 missing)))) - (setq diff (abs (- val1 val2))) ; Recompute diff - (unless (>= diff interval) - ;; Not ok, we hit a boundary - (let ((missing (- interval diff))) - (cond ((= val1 min) - (setq val2 (+ val2 missing))) - ((= val2 min) - (setq val1 (+ val1 missing))) - ((= val1 max) - (setq val2 (- val2 missing))) - ((= val2 max) - (setq val1 (- val1 missing))))))))) - (list val1 val2))) - -(defun shr-color-visible (bg fg &optional fixed-background) - "Check that BG and FG colors are visible if they are drawn on each other. -Return (bg fg) if they are. If they are too similar, two new -colors are returned instead. -If FIXED-BACKGROUND is set, and if the color are not visible, a -new background color will not be computed. Only the foreground -color will be adapted to be visible on BG." - ;; Convert fg and bg to CIE Lab - (let ((fg-norm (color-name-to-rgb fg)) - (bg-norm (color-name-to-rgb bg))) - (if (or (null fg-norm) - (null bg-norm)) - (list bg fg) - (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm)) - (bg-lab (apply 'color-srgb-to-lab bg-norm)) - ;; Compute color distance using CIE DE 2000 - (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) - ;; Compute luminance distance (subtract L component) - (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) - (if (and (>= fg-bg-distance shr-color-visible-distance-min) - (>= luminance-distance shr-color-visible-luminance-min)) - (list bg fg) - ;; Not visible, try to change luminance to make them visible - (let ((Ls (shr-color-set-minimum-interval - (car bg-lab) (car fg-lab) 0 100 - shr-color-visible-luminance-min fixed-background))) - (unless fixed-background - (setcar bg-lab (car Ls))) - (setcar fg-lab (cadr Ls)) - (list - (if fixed-background - bg - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'color-lab-to-srgb bg-lab)))) - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'color-lab-to-srgb fg-lab)))))))))) - -(provide 'shr-color) - -;;; shr-color.el ends here diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el deleted file mode 100644 index 8cb16634e2b..00000000000 --- a/lisp/gnus/shr.el +++ /dev/null @@ -1,1530 +0,0 @@ -;;; shr.el --- Simple HTML Renderer - -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: html - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package takes a HTML parse tree (as provided by -;; libxml-parse-html-region) and renders it in the current buffer. It -;; does not do CSS, JavaScript or anything advanced: It's geared -;; towards rendering typical short snippets of HTML, like what you'd -;; find in HTML email and the like. - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'browse-url) - -(defgroup shr nil - "Simple HTML Renderer" - :version "24.1" - :group 'mail) - -(defcustom shr-max-image-proportion 0.9 - "How big pictures displayed are in relation to the window they're in. -A value of 0.7 means that they are allowed to take up 70% of the -width and height of the window. If they are larger than this, -and Emacs supports it, then the images will be rescaled down to -fit these criteria." - :version "24.1" - :group 'shr - :type 'float) - -(defcustom shr-blocked-images nil - "Images that have URLs matching this regexp will be blocked." - :version "24.1" - :group 'shr - :type '(choice (const nil) regexp)) - -(defcustom shr-table-horizontal-line ?\s - "Character used to draw horizontal table lines." - :group 'shr - :type 'character) - -(defcustom shr-table-vertical-line ?\s - "Character used to draw vertical table lines." - :group 'shr - :type 'character) - -(defcustom shr-table-corner ?\s - "Character used to draw table corners." - :group 'shr - :type 'character) - -(defcustom shr-hr-line ?- - "Character used to draw hr lines." - :group 'shr - :type 'character) - -(defcustom shr-width fill-column - "Frame width to use for rendering. -May either be an integer specifying a fixed width in characters, -or nil, meaning that the full width of the window should be -used." - :type '(choice (integer :tag "Fixed width in characters") - (const :tag "Use the width of the window" nil)) - :group 'shr) - -(defvar shr-content-function nil - "If bound, this should be a function that will return the content. -This is used for cid: URLs, and the function is called with the -cid: URL as the argument.") - -(defvar shr-put-image-function 'shr-put-image - "Function called to put image and alt string.") - -(defface shr-strike-through '((t (:strike-through t))) - "Font for <s> elements." - :group 'shr) - -(defface shr-link - '((t (:inherit link))) - "Font for link elements." - :group 'shr) - -;;; Internal variables. - -(defvar shr-folding-mode nil) -(defvar shr-state nil) -(defvar shr-start nil) -(defvar shr-indentation 0) -(defvar shr-inhibit-images nil) -(defvar shr-list-mode nil) -(defvar shr-content-cache nil) -(defvar shr-kinsoku-shorten nil) -(defvar shr-table-depth 0) -(defvar shr-stylesheet nil) -(defvar shr-base nil) -(defvar shr-ignore-cache nil) -(defvar shr-external-rendering-functions nil) -(defvar shr-final-table-render nil) - -(defvar shr-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'shr-show-alt-text) - (define-key map "i" 'shr-browse-image) - (define-key map "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) - (define-key map "o" 'shr-save-contents) - (define-key map "\r" 'shr-browse-url) - map)) - -;; Public functions and commands. - -(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-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. -DOM should be a parse tree as generated by -`libxml-parse-html-region' or similar." - (setq shr-content-cache nil) - (let ((start (point)) - (shr-state nil) - (shr-start nil) - (shr-base nil) - (shr-width (or shr-width (window-width)))) - (shr-descend (shr-transform-dom dom)) - (shr-remove-trailing-whitespace start (point)))) - -(defun shr-remove-trailing-whitespace (start end) - (let ((width (window-width))) - (save-restriction - (narrow-to-region start end) - (goto-char start) - (while (not (eobp)) - (end-of-line) - (when (> (shr-previous-newline-padding-width (current-column)) width) - (dolist (overlay (overlays-at (point))) - (when (overlay-get overlay 'before-string) - (overlay-put overlay 'before-string nil)))) - (forward-line 1))))) - -(defun shr-copy-url () - "Copy the URL under point to the kill ring. -If called twice, then try to fetch the URL and see whether it -redirects somewhere else." - (interactive) - (let ((url (get-text-property (point) 'shr-url))) - (cond - ((not url) - (message "No URL under point")) - ;; Resolve redirected URLs. - ((equal url (car kill-ring)) - (url-retrieve - url - (lambda (a) - (when (and (consp a) - (eq (car a) :redirect)) - (with-temp-buffer - (insert (cadr a)) - (goto-char (point-min)) - ;; Remove common tracking junk from the URL. - (when (re-search-forward ".utm_.*" nil t) - (replace-match "" t t)) - (message "Copied %s" (buffer-string)) - (copy-region-as-kill (point-min) (point-max))))) - nil t)) - ;; Copy the URL to the kill ring. - (t - (with-temp-buffer - (insert url) - (copy-region-as-kill (point-min) (point-max)) - (message "Copied %s" url)))))) - -(defun shr-show-alt-text () - "Show the ALT text of the image under point." - (interactive) - (let ((text (get-text-property (point) 'shr-alt))) - (if (not text) - (message "No image under point") - (message "%s" text)))) - -(defun shr-browse-image (&optional copy-url) - "Browse the image under point. -If COPY-URL (the prefix if called interactively) is non-nil, copy -the URL of the image to the kill buffer instead." - (interactive "P") - (let ((url (get-text-property (point) 'image-url))) - (cond - ((not url) - (message "No image under point")) - (copy-url - (with-temp-buffer - (insert url) - (copy-region-as-kill (point-min) (point-max)) - (message "Copied %s" url))) - (t - (message "Browsing %s..." url) - (browse-url url))))) - -(defun shr-insert-image () - "Insert the image under point into the buffer." - (interactive) - (let ((url (get-text-property (point) 'image-url))) - (if (not url) - (message "No image under point") - (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched - (list (current-buffer) (1- (point)) (point-marker)) - t 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) - (let ((result (list (pop dom)))) - (dolist (arg (pop dom)) - (push (cons (intern (concat ":" (symbol-name (car arg))) obarray) - (cdr arg)) - result)) - (dolist (sub dom) - (if (stringp sub) - (push (cons 'text sub) result) - (push (shr-transform-dom sub) result))) - (nreverse result))) - -(defun shr-descend (dom) - (let ((function - (or - ;; Allow other packages to override (or provide) rendering - ;; of elements. - (cdr (assq (car dom) shr-external-rendering-functions)) - (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))) - (style (cdr (assq :style (cdr dom)))) - (shr-stylesheet shr-stylesheet) - (start (point))) - (when style - (if (string-match "color" style) - (setq shr-stylesheet (nconc (shr-parse-style style) - shr-stylesheet)) - (setq style nil))) - (if (fboundp function) - (funcall function (cdr dom)) - (shr-generic (cdr dom))) - ;; If style is set, then this node has set the color. - (when style - (shr-colorize-region start (point) - (cdr (assq 'color shr-stylesheet)) - (cdr (assq 'background-color shr-stylesheet)))))) - -(defun shr-generic (cont) - (dolist (sub cont) - (cond - ((eq (car sub) 'text) - (shr-insert (cdr sub))) - ((listp (cdr sub)) - (shr-descend sub))))) - -(defmacro shr-char-breakable-p (char) - "Return non-nil if a line can be broken before and after CHAR." - `(aref fill-find-break-point-function-table ,char)) -(defmacro shr-char-nospace-p (char) - "Return non-nil if no space is required before and after CHAR." - `(aref fill-nospace-between-words-table ,char)) - -;; KINSOKU is a Japanese word meaning a rule that should not be violated. -;; In Emacs, it is a term used for characters, e.g. punctuation marks, -;; parentheses, and so on, that should not be placed in the beginning -;; of a line or the end of a line. -(defmacro shr-char-kinsoku-bol-p (char) - "Return non-nil if a line ought not to begin with CHAR." - `(aref (char-category-set ,char) ?>)) -(defmacro shr-char-kinsoku-eol-p (char) - "Return non-nil if a line ought not to end with CHAR." - `(aref (char-category-set ,char) ?<)) -(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) - (load "kinsoku" nil t)) - -(defun shr-insert (text) - (when (and (eq shr-state 'image) - (not (bolp)) - (not (string-match "\\`[ \t\n]+\\'" text))) - (insert "\n") - (setq shr-state nil)) - (cond - ((eq shr-folding-mode 'none) - (insert text)) - (t - (when (and (string-match "\\`[ \t\n ]" text) - (not (bolp)) - (not (eq (char-after (1- (point))) ? ))) - (insert " ")) - (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t)) - (when (and (bolp) - (> shr-indentation 0)) - (shr-indent)) - ;; No space is needed behind a wide character categorized as - ;; kinsoku-bol, between characters both categorized as nospace, - ;; or at the beginning of a line. - (let (prev) - (when (and (> (current-column) shr-indentation) - (eq (preceding-char) ? ) - (or (= (line-beginning-position) (1- (point))) - (and (shr-char-breakable-p - (setq prev (char-after (- (point) 2)))) - (shr-char-kinsoku-bol-p prev)) - (and (shr-char-nospace-p prev) - (shr-char-nospace-p (aref elem 0))))) - (delete-char -1))) - ;; The shr-start is a special variable that is used to pass - ;; upwards the first point in the buffer where the text really - ;; starts. - (unless shr-start - (setq shr-start (point))) - (insert elem) - (setq shr-state nil) - (let (found) - (while (and (> (current-column) shr-width) - (progn - (setq found (shr-find-fill-point)) - (not (eolp)))) - (when (eq (preceding-char) ? ) - (delete-char -1)) - (insert "\n") - (unless found - ;; No space is needed at the beginning of a line. - (when (eq (following-char) ? ) - (delete-char 1))) - (when (> shr-indentation 0) - (shr-indent)) - (end-of-line)) - (insert " "))) - (unless (string-match "[ \t\r\n ]\\'" text) - (delete-char -1))))) - -(defun shr-find-fill-point () - (when (> (move-to-column shr-width) shr-width) - (backward-char 1)) - (let ((bp (point)) - failed) - (while (not (or (setq failed (= (current-column) shr-indentation)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (shr-char-breakable-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (if (eq (preceding-char) ?') - (not (memq (char-after (- (point) 2)) - (list nil ?\n ? ))) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char))))) - (shr-char-kinsoku-eol-p (following-char)))) - (backward-char 1)) - (if (and (not (or failed (eolp))) - (eq (preceding-char) ?')) - (while (not (or (setq failed (eolp)) - (eq (following-char) ? ) - (shr-char-breakable-p (following-char)) - (shr-char-kinsoku-eol-p (following-char)))) - (forward-char 1))) - (if failed - ;; There's no breakable point, so we give it up. - (let (found) - (goto-char bp) - (unless shr-kinsoku-shorten - (while (and (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move)) - (eq (preceding-char) ?'))) - (if (and found (not (match-beginning 1))) - (goto-char (match-beginning 0))))) - (or - (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line. - (cond - (shr-kinsoku-shorten - (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (shr-char-kinsoku-eol-p (preceding-char))) - (backward-char 1)) - (when (setq failed (= (current-column) shr-indentation)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we look for the second best position. - (while (and (progn - (forward-char 1) - (<= (current-column) shr-width)) - (progn - (setq bp (point)) - (shr-char-kinsoku-eol-p (following-char))))) - (goto-char bp))) - ((shr-char-kinsoku-eol-p (preceding-char)) - ;; 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)))))))) - (when (eq (following-char) ? ) - (forward-char 1)))) - (not failed))) - -(defun shr-expand-url (url) - (if (or (not url) - (string-match "\\`[a-z]*:" url) - (not shr-base)) - ;; Absolute URL. - url - (let ((base shr-base)) - ;; Chop off query string. - (when (string-match "\\`\\([^?]+\\)[?]" base) - (setq base (match-string 1 base))) - ;; Chop off the bit after the last slash. - (when (string-match "\\`\\(.*\\)[/][^/]+" base) - (setq base (match-string 1 base))) - (cond - ((and (string-match "\\`//" url) - (string-match "\\`[a-z]*:" base)) - (concat (match-string 0 base) url)) - ((and (not (string-match "/\\'" base)) - (not (string-match "\\`/" url))) - (concat base "/" url)) - ((and (string-match "\\`/" url) - (string-match "\\(\\`[^:]*://[^/]+\\)/" base)) - (concat (match-string 1 base) url)) - (t - (concat base url)))))) - -(defun shr-ensure-newline () - (unless (zerop (current-column)) - (insert "\n"))) - -(defun shr-ensure-paragraph () - (unless (bobp) - (if (<= (current-column) shr-indentation) - (unless (save-excursion - (forward-line -1) - (looking-at " *$")) - (insert "\n")) - (if (save-excursion - (beginning-of-line) - (looking-at " *$")) - (delete-region (match-beginning 0) (match-end 0)) - (insert "\n\n"))))) - -(defun shr-indent () - (when (> shr-indentation 0) - (insert (make-string shr-indentation ? )))) - -(defun shr-fontize-cont (cont &rest types) - (let (shr-start) - (shr-generic cont) - (dolist (type types) - (shr-add-font (or shr-start (point)) (point) type)))) - -(defun shr-make-overlay (beg end &optional buffer front-advance rear-advance) - (let ((overlay (make-overlay beg end buffer front-advance rear-advance))) - (overlay-put overlay 'evaporate t) - overlay)) - -;; Add an overlay in the region, but avoid putting the font properties -;; on blank text at the start of the line, and the newline at the end, -;; to avoid ugliness. -(defun shr-add-font (start end type) - (save-excursion - (goto-char start) - (while (< (point) end) - (when (bolp) - (skip-chars-forward " ")) - (let ((overlay (shr-make-overlay (point) (min (line-end-position) end)))) - (overlay-put overlay 'face type)) - (if (< (line-end-position) end) - (forward-line 1) - (goto-char end))))) - -(defun shr-browse-url () - "Browse the URL under point." - (interactive) - (let ((url (get-text-property (point) 'shr-url))) - (cond - ((not url) - (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) - (t - (browse-url url))))) - -(defun shr-save-contents (directory) - "Save the contents from URL in a file." - (interactive "DSave contents of URL to directory: ") - (let ((url (get-text-property (point) 'shr-url))) - (if (not url) - (message "No link under point") - (url-retrieve (shr-encode-url url) - 'shr-store-contents (list url directory) - nil t)))) - -(defun shr-store-contents (status url directory) - (unless (plist-get status :error) - (when (or (search-forward "\n\n" nil t) - (search-forward "\r\n\r\n" nil t)) - (write-region (point) (point-max) - (expand-file-name (file-name-nondirectory url) - directory))))) - -(defun shr-image-fetched (status buffer start end &optional flags) - (let ((image-buffer (current-buffer))) - (when (and (buffer-name buffer) - (not (plist-get status :error))) - (url-store-in-cache image-buffer) - (when (or (search-forward "\n\n" nil t) - (search-forward "\r\n\r\n" nil t)) - (let ((data (buffer-substring (point) (point-max)))) - (with-current-buffer buffer - (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 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-image-from-data (data) - "Return an image from the data: URI content DATA." - (when (string-match - "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)" - data) - (let ((param (match-string 4 data)) - (payload (url-unhex-string (match-string 5 data)))) - (when (string-match "^.*\\(;[ \t]*base64\\)$" param) - (setq payload (base64-decode-string payload))) - payload))) - -(defun shr-put-image (data alt &optional flags) - "Put image DATA with a string ALT. Return image." - (if (display-graphic-p) - (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")) - (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 (cond ((fboundp 'image-multi-frame-p) - ;; Only animate multi-frame things that specify a - ;; delay; eg animated gifs as opposed to - ;; multi-page tiffs. FIXME? - (cdr (image-multi-frame-p image))) - ((fboundp 'image-animated-p) - (image-animated-p image))) - (image-animate image nil 60))) - image) - (insert alt))) - -(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)))) - image - (let* ((size (image-size image t)) - (width (car size)) - (height (cdr size)) - (edges (window-inside-pixel-edges - (get-buffer-window (current-buffer)))) - (window-width (truncate (* shr-max-image-proportion - (- (nth 2 edges) (nth 0 edges))))) - (window-height (truncate (* shr-max-image-proportion - (- (nth 3 edges) (nth 1 edges))))) - scaled-image) - (when (or force - (> height window-height)) - (setq image (or (create-image data 'imagemagick t - :height window-height - :ascent 100) - image)) - (setq size (image-size image t))) - (when (> (car size) window-width) - (setq image (or - (create-image data 'imagemagick t - :width window-width - :ascent 100) - image))) - image)))) - -;; url-cache-extract autoloads url-cache. -(declare-function url-cache-create-filename "url-cache" (url)) -(autoload 'mm-disable-multibyte "mm-util") -(autoload 'browse-url-mail "browse-url") - -(defun shr-get-image-data (url) - "Get image data for URL. -Return a string with image data." - (with-temp-buffer - (mm-disable-multibyte) - (when (ignore-errors - (url-cache-extract (url-cache-create-filename (shr-encode-url url))) - t) - (when (or (search-forward "\n\n" nil t) - (search-forward "\r\n\r\n" nil t)) - (buffer-substring (point) (point-max)))))) - -(defun shr-image-displayer (content-function) - "Return a function to display an image. -CONTENT-FUNCTION is a function to retrieve an image for a cid url that -is an argument. The function to be returned takes three arguments URL, -START, and END. Note that START and END should be markers." - `(lambda (url start end) - (when url - (if (string-match "\\`cid:" url) - ,(when content-function - `(let ((image (funcall ,content-function - (substring url (match-end 0))))) - (when image - (goto-char start) - (funcall shr-put-image-function - image (buffer-substring start end)) - (delete-region (point) end)))) - (url-retrieve url 'shr-image-fetched - (list (current-buffer) start end) - t t))))) - -(defun shr-heading (cont &rest types) - (shr-ensure-paragraph) - (apply #'shr-fontize-cont cont types) - (shr-ensure-paragraph)) - -(autoload 'widget-convert-button "wid-edit") - -(defun shr-urlify (start url &optional title) - (widget-convert-button - 'url-link start (point) - :help-echo (if title (format "%s (%s)" url title) url) - :keymap shr-map - url) - (shr-add-font start (point) 'shr-link) - (put-text-property start (point) 'shr-url url)) - -(defun shr-encode-url (url) - "Encode URL." - (browse-url-url-encode-chars url "[)$ ]")) - -(autoload 'shr-color-visible "shr-color") -(autoload 'shr-color->hexadecimal "shr-color") - -(defun shr-color-check (fg bg) - "Check that FG is visible on BG. -Returns (fg bg) with corrected values. -Returns nil if the colors that would be used are the default -ones, in case fg and bg are nil." - (when (or fg bg) - (let ((fixed (cond ((null fg) 'fg) - ((null bg) 'bg)))) - ;; Convert colors to hexadecimal, or set them to default. - (let ((fg (or (shr-color->hexadecimal fg) - (frame-parameter nil 'foreground-color))) - (bg (or (shr-color->hexadecimal bg) - (frame-parameter nil 'background-color)))) - (cond ((eq fixed 'bg) - ;; Only return the new fg - (list nil (cadr (shr-color-visible bg fg t)))) - ((eq fixed 'fg) - ;; Invert args and results and return only the new bg - (list (cadr (shr-color-visible fg bg t)) nil)) - (t - (shr-color-visible bg fg))))))) - -(defun shr-colorize-region (start end fg &optional bg) - (when (or fg bg) - (let ((new-colors (shr-color-check fg bg))) - (when new-colors - (when fg - (shr-put-color start end :foreground (cadr new-colors))) - (when bg - (shr-put-color start end :background (car new-colors)))) - new-colors))) - -;; Put a color in the region, but avoid putting colors on blank -;; text at the start of the line, and the newline at the end, to avoid -;; ugliness. Also, don't overwrite any existing color information, -;; since this can be called recursively, and we want the "inner" color -;; to win. -(defun shr-put-color (start end type color) - (save-excursion - (goto-char start) - (while (< (point) end) - (when (and (bolp) - (not (eq type :background))) - (skip-chars-forward " ")) - (when (> (line-end-position) (point)) - (shr-put-color-1 (point) (min (line-end-position) end) type color)) - (if (< (line-end-position) end) - (forward-line 1) - (goto-char end))) - (when (and (eq type :background) - (= shr-table-depth 0)) - (shr-expand-newlines start end color)))) - -(defun shr-expand-newlines (start end color) - (save-restriction - ;; Skip past all white space at the start and ends. - (goto-char start) - (skip-chars-forward " \t\n") - (beginning-of-line) - (setq start (point)) - (goto-char end) - (skip-chars-backward " \t\n") - (forward-line 1) - (setq end (point)) - (narrow-to-region start end) - (let ((width (shr-buffer-width)) - column) - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (when (and (< (setq column (current-column)) width) - (< (setq column (shr-previous-newline-padding-width column)) - width)) - (let ((overlay (shr-make-overlay (point) (1+ (point))))) - (overlay-put overlay 'before-string - (concat - (mapconcat - (lambda (overlay) - (let ((string (plist-get - (overlay-properties overlay) - 'before-string))) - (if (not string) - "" - (overlay-put overlay 'before-string "") - string))) - (overlays-at (point)) - "") - (propertize (make-string (- width column) ? ) - 'face (list :background color)))))) - (forward-line 1))))) - -(defun shr-previous-newline-padding-width (width) - (let ((overlays (overlays-at (point))) - (previous-width 0)) - (if (null overlays) - width - (dolist (overlay overlays) - (setq previous-width - (+ previous-width - (length (plist-get (overlay-properties overlay) - 'before-string))))) - (+ width previous-width)))) - -(defun shr-put-color-1 (start end type color) - (let* ((old-props (get-text-property start 'face)) - (do-put (and (listp old-props) - (not (memq type old-props)))) - change) - (while (< start end) - (setq change (next-single-property-change start 'face nil end)) - (when do-put - (put-text-property start change 'face - (nconc (list type color) old-props))) - (setq old-props (get-text-property change 'face)) - (setq do-put (and (listp old-props) - (not (memq type old-props)))) - (setq start change)) - (when (and do-put - (> end start)) - (put-text-property start end 'face - (nconc (list type color old-props)))))) - -;;; Tag-specific rendering rules. - -(defun shr-tag-body (cont) - (let* ((start (point)) - (fgcolor (cdr (or (assq :fgcolor cont) - (assq :text cont)))) - (bgcolor (cdr (assq :bgcolor cont))) - (shr-stylesheet (list (cons 'color fgcolor) - (cons 'background-color bgcolor)))) - (shr-generic cont) - (shr-colorize-region start (point) fgcolor bgcolor))) - -(defun shr-tag-style (cont) - ) - -(defun shr-tag-script (cont) - ) - -(defun shr-tag-comment (cont) - ) - -(defun shr-tag-svg (cont) - ) - -(defun shr-tag-sup (cont) - (let ((start (point))) - (shr-generic cont) - (put-text-property start (point) 'display '(raise 0.5)))) - -(defun shr-tag-sub (cont) - (let ((start (point))) - (shr-generic cont) - (put-text-property start (point) 'display '(raise -0.5)))) - -(defun shr-tag-label (cont) - (shr-generic cont) - (shr-ensure-paragraph)) - -(defun shr-tag-p (cont) - (shr-ensure-paragraph) - (shr-indent) - (shr-generic cont) - (shr-ensure-paragraph)) - -(defun shr-tag-div (cont) - (shr-ensure-newline) - (shr-indent) - (shr-generic cont) - (shr-ensure-newline)) - -(defun shr-tag-s (cont) - (shr-fontize-cont cont 'shr-strike-through)) - -(defun shr-tag-del (cont) - (shr-fontize-cont cont 'shr-strike-through)) - -(defun shr-tag-b (cont) - (shr-fontize-cont cont 'bold)) - -(defun shr-tag-i (cont) - (shr-fontize-cont cont 'italic)) - -(defun shr-tag-em (cont) - (shr-fontize-cont cont 'italic)) - -(defun shr-tag-strong (cont) - (shr-fontize-cont cont 'bold)) - -(defun shr-tag-u (cont) - (shr-fontize-cont cont 'underline)) - -(defun shr-parse-style (style) - (when style - (save-match-data - (when (string-match "\n" style) - (setq style (replace-match " " t t style)))) - (let ((plist nil)) - (dolist (elem (split-string style ";")) - (when elem - (setq elem (split-string elem ":")) - (when (and (car elem) - (cadr elem)) - (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem))) - (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem)))) - (when (string-match " *!important\\'" value) - (setq value (substring value 0 (match-beginning 0)))) - (push (cons (intern name obarray) - value) - plist))))) - plist))) - -(defun shr-tag-base (cont) - (setq shr-base (cdr (assq :href cont))) - (shr-generic cont)) - -(defun shr-tag-a (cont) - (let ((url (cdr (assq :href cont))) - (title (cdr (assq :title cont))) - (start (point)) - shr-start) - (shr-generic cont) - (when url - (shr-urlify (or shr-start start) (shr-expand-url url) title)))) - -(defun shr-tag-object (cont) - (let ((start (point)) - url) - (dolist (elem cont) - (when (eq (car elem) 'embed) - (setq url (or url (cdr (assq :src (cdr elem)))))) - (when (and (eq (car elem) 'param) - (equal (cdr (assq :name (cdr elem))) "movie")) - (setq url (or url (cdr (assq :value (cdr elem))))))) - (when url - (shr-insert " [multimedia] ") - (shr-urlify start (shr-expand-url url))) - (shr-generic cont))) - -(defun shr-tag-video (cont) - (let ((image (cdr (assq :poster cont))) - (url (cdr (assq :src cont))) - (start (point))) - (shr-tag-img nil image) - (shr-urlify start (shr-expand-url url)))) - -(defun shr-tag-img (cont &optional url) - (when (or url - (and cont - (cdr (assq :src cont)))) - (when (and (> (current-column) 0) - (not (eq shr-state 'image))) - (insert "\n")) - (let ((alt (cdr (assq :alt cont))) - (url (shr-expand-url (or url (cdr (assq :src cont)))))) - (let ((start (point-marker))) - (when (zerop (length alt)) - (setq alt "*")) - (cond - ((or (member (cdr (assq :height cont)) '("0" "1")) - (member (cdr (assq :width cont)) '("0" "1"))) - ;; Ignore zero-sized or single-pixel images. - ) - ((and (not shr-inhibit-images) - (string-match "\\`data:" url)) - (let ((image (shr-image-from-data (substring url (match-end 0))))) - (if image - (funcall shr-put-image-function image alt) - (insert alt)))) - ((and (not shr-inhibit-images) - (string-match "\\`cid:" url)) - (let ((url (substring url (match-end 0))) - image) - (if (or (not shr-content-function) - (not (setq image (funcall shr-content-function url)))) - (insert alt) - (funcall shr-put-image-function image alt)))) - ((or shr-inhibit-images - (and shr-blocked-images - (string-match shr-blocked-images url))) - (setq shr-start (point)) - (let ((shr-state 'space)) - (if (> (string-width alt) 8) - (shr-insert (truncate-string-to-width alt 8)) - (shr-insert alt)))) - ((and (not shr-ignore-cache) - (url-is-cached (shr-encode-url url))) - (funcall shr-put-image-function (shr-get-image-data url) alt)) - (t - (insert alt " ") - (when (and shr-ignore-cache - (url-is-cached (shr-encode-url url))) - (let ((file (url-cache-create-filename (shr-encode-url url)))) - (when (file-exists-p file) - (delete-file file)))) - (url-queue-retrieve - (shr-encode-url url) 'shr-image-fetched - (list (current-buffer) start (set-marker (make-marker) (1- (point)))) - t t))) - (when (zerop shr-table-depth) ;; We are not in a table. - (put-text-property start (point) 'keymap shr-map) - (put-text-property start (point) 'shr-alt alt) - (put-text-property start (point) 'image-url url) - (put-text-property start (point) 'image-displayer - (shr-image-displayer shr-content-function)) - (put-text-property start (point) 'help-echo alt)) - (setq shr-state 'image))))) - -(defun shr-tag-pre (cont) - (let ((shr-folding-mode 'none)) - (shr-ensure-newline) - (shr-indent) - (shr-generic cont) - (shr-ensure-newline))) - -(defun shr-tag-blockquote (cont) - (shr-ensure-paragraph) - (shr-indent) - (let ((shr-indentation (+ shr-indentation 4))) - (shr-generic cont)) - (shr-ensure-paragraph)) - -(defun shr-tag-ul (cont) - (shr-ensure-paragraph) - (let ((shr-list-mode 'ul)) - (shr-generic cont)) - (shr-ensure-paragraph)) - -(defun shr-tag-ol (cont) - (shr-ensure-paragraph) - (let ((shr-list-mode 1)) - (shr-generic cont)) - (shr-ensure-paragraph)) - -(defun shr-tag-li (cont) - (shr-ensure-paragraph) - (shr-indent) - (let* ((bullet - (if (numberp shr-list-mode) - (prog1 - (format "%d " shr-list-mode) - (setq shr-list-mode (1+ shr-list-mode))) - "* ")) - (shr-indentation (+ shr-indentation (length bullet)))) - (insert bullet) - (shr-generic cont))) - -(defun shr-tag-br (cont) - (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)) - -(defun shr-tag-span (cont) - (let ((title (cdr (assq :title cont)))) - (shr-generic cont) - (when title - (when shr-start - (let ((overlay (shr-make-overlay shr-start (point)))) - (overlay-put overlay 'help-echo title)))))) - -(defun shr-tag-h1 (cont) - (shr-heading cont 'bold 'underline)) - -(defun shr-tag-h2 (cont) - (shr-heading cont 'bold)) - -(defun shr-tag-h3 (cont) - (shr-heading cont 'italic)) - -(defun shr-tag-h4 (cont) - (shr-heading cont)) - -(defun shr-tag-h5 (cont) - (shr-heading cont)) - -(defun shr-tag-h6 (cont) - (shr-heading cont)) - -(defun shr-tag-hr (cont) - (shr-ensure-newline) - (insert (make-string shr-width shr-hr-line) "\n")) - -(defun shr-tag-title (cont) - (shr-heading cont 'bold 'underline)) - -(defun shr-tag-font (cont) - (let* ((start (point)) - (color (cdr (assq :color cont))) - (shr-stylesheet (nconc (list (cons 'color color)) - shr-stylesheet))) - (shr-generic cont) - (when color - (shr-colorize-region start (point) color - (cdr (assq 'background-color shr-stylesheet)))))) - -;;; Table rendering algorithm. - -;; Table rendering is the only complicated thing here. We do this by -;; first counting how many TDs there are in each TR, and registering -;; how wide they think they should be ("width=45%", etc). Then we -;; render each TD separately (this is done in temporary buffers, so -;; that we can use all the rendering machinery as if we were in the -;; main buffer). Now we know how much space each TD really takes, so -;; we then render everything again with the new widths, and finally -;; insert all these boxes into the main buffer. -(defun shr-tag-table-1 (cont) - (setq cont (or (cdr (assq 'tbody cont)) - cont)) - (let* ((shr-inhibit-images t) - (shr-table-depth (1+ shr-table-depth)) - (shr-kinsoku-shorten t) - ;; Find all suggested widths. - (columns (shr-column-specs cont)) - ;; Compute how many characters wide each TD should be. - (suggested-widths (shr-pro-rate-columns columns)) - ;; Do a "test rendering" to see how big each TD is (this can - ;; be smaller (if there's little text) or bigger (if there's - ;; unbreakable text). - (sketch (shr-make-table cont suggested-widths)) - ;; Compute the "natural" width by setting each column to 500 - ;; characters and see how wide they really render. - (natural (shr-make-table cont (make-vector (length columns) 500))) - (sketch-widths (shr-table-widths sketch natural suggested-widths))) - ;; This probably won't work very well. - (when (> (+ (loop for width across sketch-widths - summing (1+ width)) - shr-indentation 1) - (frame-width)) - (setq truncate-lines t)) - ;; Then render the table again with these new "hard" widths. - (let ((shr-final-table-render t)) - (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))) - ;; Finally, insert all the images after the table. The Emacs buffer - ;; model isn't strong enough to allow us to put the images actually - ;; into the tables. - (when (zerop shr-table-depth) - (dolist (elem (shr-find-elements cont 'img)) - (shr-tag-img (cdr elem))))) - -(defun shr-tag-table (cont) - (shr-ensure-paragraph) - (let* ((caption (cdr (assq 'caption cont))) - (header (cdr (assq 'thead cont))) - (body (or (cdr (assq 'tbody cont)) cont)) - (footer (cdr (assq 'tfoot cont))) - (bgcolor (cdr (assq :bgcolor cont))) - (start (point)) - (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) - shr-stylesheet)) - (nheader (if header (shr-max-columns header))) - (nbody (if body (shr-max-columns body))) - (nfooter (if footer (shr-max-columns footer)))) - (if (and (not caption) - (not header) - (not (cdr (assq 'tbody cont))) - (not (cdr (assq 'tr cont))) - (not footer)) - ;; The table is totally invalid and just contains random junk. - ;; Try to output it anyway. - (shr-generic cont) - ;; It's a real table, so render it. - (shr-tag-table-1 - (nconc - (if caption `((tr (td ,@caption)))) - (if header - (if footer - ;; hader + body + footer - (if (= nheader nbody) - (if (= nbody nfooter) - `((tr (td (table (tbody ,@header ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@header ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))) - (nconc `((tr (td (table (tbody ,@header))))) - (if (= nbody nfooter) - `((tr (td (table (tbody ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))))) - ;; header + body - (if (= nheader nbody) - `((tr (td (table (tbody ,@header ,@body))))) - (if (= nheader 1) - `(,@header (tr (td (table (tbody ,@body))))) - `((tr (td (table (tbody ,@header)))) - (tr (td (table (tbody ,@body)))))))) - (if footer - ;; body + footer - (if (= nbody nfooter) - `((tr (td (table (tbody ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))) - (if caption - `((tr (td (table (tbody ,@body))))) - body)))))) - (when bgcolor - (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) - bgcolor)))) - -(defun shr-find-elements (cont type) - (let (result) - (dolist (elem cont) - (cond ((eq (car elem) type) - (push elem result)) - ((consp (cdr elem)) - (setq result (nconc (shr-find-elements (cdr elem) type) result))))) - (nreverse result))) - -(defun shr-insert-table (table widths) - (shr-insert-table-ruler widths) - (dolist (row table) - (let ((start (point)) - (height (let ((max 0)) - (dolist (column row) - (setq max (max max (cadr column)))) - max))) - (dotimes (i height) - (shr-indent) - (insert shr-table-vertical-line "\n")) - (dolist (column row) - (goto-char start) - (let ((lines (nth 2 column)) - (overlay-lines (nth 3 column)) - overlay overlay-line) - (dolist (line lines) - (setq overlay-line (pop overlay-lines)) - (end-of-line) - (insert line shr-table-vertical-line) - (dolist (overlay overlay-line) - (let ((o (shr-make-overlay (- (point) (nth 0 overlay) 1) - (- (point) (nth 1 overlay) 1))) - (properties (nth 2 overlay))) - (while properties - (overlay-put o (pop properties) (pop properties))))) - (forward-line 1)) - ;; Add blank lines at padding at the bottom of the TD, - ;; possibly. - (dotimes (i (- height (length lines))) - (end-of-line) - (let ((start (point))) - (insert (make-string (string-width (car lines)) ? ) - shr-table-vertical-line) - (when (nth 4 column) - (shr-put-color start (1- (point)) :background (nth 4 column)))) - (forward-line 1))))) - (shr-insert-table-ruler widths))) - -(defun shr-insert-table-ruler (widths) - (when (and (bolp) - (> shr-indentation 0)) - (shr-indent)) - (insert shr-table-corner) - (dotimes (i (length widths)) - (insert (make-string (aref widths i) shr-table-horizontal-line) - shr-table-corner)) - (insert "\n")) - -(defun shr-table-widths (table natural-table suggested-widths) - (let* ((length (length suggested-widths)) - (widths (make-vector length 0)) - (natural-widths (make-vector length 0))) - (dolist (row table) - (let ((i 0)) - (dolist (column row) - (aset widths i (max (aref widths i) column)) - (setq i (1+ i))))) - (dolist (row natural-table) - (let ((i 0)) - (dolist (column row) - (aset natural-widths i (max (aref natural-widths i) column)) - (setq i (1+ i))))) - (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)))) - (expanded-columns 0)) - ;; We have extra, unused space, so divide this space amongst the - ;; columns. - (when (> extra 0) - ;; If the natural width is wider than the rendered width, we - ;; want to allow the column to expand. - (dotimes (i length) - (when (> (aref natural-widths i) (aref widths i)) - (setq expanded-columns (1+ expanded-columns)))) - (dotimes (i length) - (when (> (aref natural-widths i) (aref widths i)) - (aset widths i (min - (aref natural-widths i) - (+ (/ extra expanded-columns) - (aref widths i)))))))) - widths)) - -(defun shr-make-table (cont widths &optional fill) - (let ((trs nil)) - (dolist (row cont) - (when (eq (car row) 'tr) - (let ((tds nil) - (columns (cdr row)) - (i 0) - column) - (while (< i (length widths)) - (setq column (pop columns)) - (when (or (memq (car column) '(td th)) - (null column)) - (push (shr-render-td (cdr column) (aref widths i) fill) - tds) - (setq i (1+ i)))) - (push (nreverse tds) trs)))) - (nreverse trs))) - -(defun shr-render-td (cont width fill) - (with-temp-buffer - (let ((bgcolor (cdr (assq :bgcolor cont))) - (fgcolor (cdr (assq :fgcolor cont))) - (style (cdr (assq :style cont))) - (shr-stylesheet shr-stylesheet) - overlays actual-colors) - (when style - (setq style (and (string-match "color" style) - (shr-parse-style style)))) - (when bgcolor - (setq style (nconc (list (cons 'background-color bgcolor)) style))) - (when fgcolor - (setq style (nconc (list (cons 'color fgcolor)) style))) - (when style - (setq shr-stylesheet (append style shr-stylesheet))) - (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) - (if cache - (progn - (insert (car cache)) - (let ((end (length (car cache)))) - (dolist (overlay (cadr cache)) - (let ((new-overlay - (shr-make-overlay (1+ (- end (nth 0 overlay))) - (1+ (- end (nth 1 overlay))))) - (properties (nth 2 overlay))) - (while properties - (overlay-put new-overlay - (pop properties) (pop properties))))))) - (let ((shr-width width) - (shr-indentation 0)) - (shr-descend (cons 'td cont))) - ;; Delete padding at the bottom of the TDs. - (delete-region - (point) - (progn - (skip-chars-backward " \t\n") - (end-of-line) - (point))) - (push (list (cons width cont) (buffer-string) - (shr-overlays-in-region (point-min) (point-max))) - shr-content-cache))) - (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (when fill - (goto-char (point-min)) - ;; If the buffer is totally empty, then put a single blank - ;; line here. - (if (zerop (buffer-size)) - (insert (make-string width ? )) - ;; Otherwise, fill the buffer. - (while (not (eobp)) - (end-of-line) - (when (> (- width (current-column)) 0) - (insert (make-string (- width (current-column)) ? ))) - (forward-line 1))) - (when style - (setq actual-colors - (shr-colorize-region - (point-min) (point-max) - (cdr (assq 'color shr-stylesheet)) - (cdr (assq 'background-color shr-stylesheet)))))) - (if fill - (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - (shr-collect-overlays) - (car actual-colors)) - max))))) - -(defun shr-buffer-width () - (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - max)) - -(defun shr-collect-overlays () - (save-excursion - (goto-char (point-min)) - (let ((overlays nil)) - (while (not (eobp)) - (push (shr-overlays-in-region (point) (line-end-position)) - overlays) - (forward-line 1)) - (nreverse overlays)))) - -(defun shr-overlays-in-region (start end) - (let (result) - (dolist (overlay (overlays-in start end)) - (push (list (if (> start (overlay-start overlay)) - (- end start) - (- end (overlay-start overlay))) - (if (< end (overlay-end overlay)) - 0 - (- end (overlay-end overlay))) - (overlay-properties overlay)) - result)) - (nreverse result))) - -(defun shr-pro-rate-columns (columns) - (let ((total-percentage 0) - (widths (make-vector (length columns) 0))) - (dotimes (i (length columns)) - (setq total-percentage (+ total-percentage (aref columns i)))) - (setq total-percentage (/ 1.0 total-percentage)) - (dotimes (i (length columns)) - (aset widths i (max (truncate (* (aref columns i) - total-percentage - (- shr-width (1+ (length columns))))) - 10))) - widths)) - -;; Return a summary of the number and shape of the TDs in the table. -(defun shr-column-specs (cont) - (let ((columns (make-vector (shr-max-columns cont) 1))) - (dolist (row cont) - (when (eq (car row) 'tr) - (let ((i 0)) - (dolist (column (cdr row)) - (when (memq (car column) '(td th)) - (let ((width (cdr (assq :width (cdr column))))) - (when (and width - (string-match "\\([0-9]+\\)%" width) - (not (zerop (setq width (string-to-number - (match-string 1 width)))))) - (aset columns i (/ width 100.0)))) - (setq i (1+ i))))))) - columns)) - -(defun shr-count (cont elem) - (let ((i 0)) - (dolist (sub cont) - (when (eq (car sub) elem) - (setq i (1+ i)))) - i)) - -(defun shr-max-columns (cont) - (let ((max 0)) - (dolist (row cont) - (when (eq (car row) 'tr) - (setq max (max max (+ (shr-count (cdr row) 'td) - (shr-count (cdr row) 'th)))))) - max)) - -(provide 'shr) - -;; Local Variables: -;; coding: utf-8 -;; End: - -;;; shr.el ends here diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index 23ab24152d9..4221276e2ec 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -168,6 +168,8 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (defvar sieve-manage-capability nil) ;; Internal utility functions +(autoload 'mm-enable-multibyte "mm-util") + (defun sieve-manage-make-process-buffer () (with-current-buffer (generate-new-buffer (format " *sieve %s:%s*" @@ -206,15 +208,15 @@ Return the buffer associated with the connection." :success "^OK.*\n" :return-list t :starttls-function - '(lambda (capabilities) - (when (string-match "\\bSTARTTLS\\b" capabilities) - "STARTTLS\r\n"))) + (lambda (capabilities) + (when (string-match "\\bSTARTTLS\\b" capabilities) + "STARTTLS\r\n"))) (setq sieve-manage-process proc) (setq sieve-manage-capability - (sieve-manage-parse-capability (getf props :capabilities))) + (sieve-manage-parse-capability (plist-get props :capabilities))) ;; Ignore new capabilities issues after successful STARTTLS (when (and (memq stream '(nil network starttls)) - (eq (getf props :type) 'tls)) + (eq (plist-get props :type) 'tls)) (sieve-manage-drop-next-answer)) (current-buffer)))) @@ -502,9 +504,9 @@ If NAME is nil, return the full server list of capabilities." (defun sieve-manage-parse-capability (str) "Parse managesieve capability string `STR'. Set variable `sieve-manage-capability' to " - (let ((capas (remove-if #'null - (mapcar #'split-string-and-unquote - (split-string str "\n"))))) + (let ((capas (delq nil + (mapcar #'split-string-and-unquote + (split-string str "\n"))))) (when (string= "OK" (caar (last capas))) (setq sieve-manage-state 'nonauth)) capas)) diff --git a/lisp/gnus/sieve.el b/lisp/gnus/sieve.el index 2c11c039d56..42e6330273a 100644 --- a/lisp/gnus/sieve.el +++ b/lisp/gnus/sieve.el @@ -125,7 +125,8 @@ require \"fileinto\"; (define-key map "f" 'sieve-edit-script) (define-key map "o" 'sieve-edit-script-other-window) (define-key map "r" 'sieve-remove) - (define-key map "q" 'sieve-manage-quit) + (define-key map "q" 'sieve-bury-buffer) + (define-key map "Q" 'sieve-manage-quit) (define-key map [(down-mouse-2)] 'sieve-edit-script) (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu) map) @@ -149,12 +150,17 @@ require \"fileinto\"; ;; Commands used in sieve-manage mode: (defun sieve-manage-quit () - "Quit." + "Quit Manage Sieve and close the connection." (interactive) (sieve-manage-close sieve-manage-buffer) (kill-buffer sieve-manage-buffer) (kill-buffer (current-buffer))) +(defun sieve-bury-buffer () + "Bury the Manage Sieve buffer without closing the connection." + (interactive) + (bury-buffer)) + (defun sieve-activate (&optional pos) (interactive "d") (let ((name (sieve-script-at-point)) err) @@ -207,7 +213,7 @@ require \"fileinto\"; (insert sieve-template)) (sieve-mode) (setq sieve-buffer-script-name name) - (beginning-of-buffer) + (goto-char (point-min)) (message (substitute-command-keys "Press \\[sieve-upload] to upload script to server.")))) |