Mercurial > emacs
changeset 110708:4c31586ca1ca
Merge changes made in Gnus trunk.
shr.el: Start implementation.
shr.el: Continue implementation.
gnus-gravatar.el (gnus-gravatar-insert): Adjust character where we should go backward.
shr.el: Minimally useful state achieved.
mm-decode.el (mm-text-html-renderer): Switch to using shr.el for HTML rendering.
shr.el: (shr-insert): Add a newline after every picture before text.
gnus.texi (Splitting Mail): Really fix the @ref syntax.
shr.el (shr-add-font): Use overlays for combining faces.
shr.el (shr-add-font): Use overlays for combining faces.
shr.el (shr-insert): Pass upwards the text start point.
gnus-util.el: Reintroduce multiple completion functions.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Sun, 03 Oct 2010 00:33:27 +0000 |
| parents | 17914d74ccf4 |
| children | f07cd17d0a5a |
| files | doc/misc/ChangeLog doc/misc/gnus.texi lisp/gnus/ChangeLog lisp/gnus/gnus-gravatar.el lisp/gnus/gnus-html.el lisp/gnus/gnus-util.el lisp/gnus/mm-decode.el lisp/gnus/shr.el |
| diffstat | 8 files changed, 317 insertions(+), 26 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/misc/ChangeLog Sat Oct 02 20:03:44 2010 -0400 +++ b/doc/misc/ChangeLog Sun Oct 03 00:33:27 2010 +0000 @@ -1,6 +1,7 @@ 2010-10-02 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus.texi (Splitting Mail): Fix @xref syntax. + (Splitting Mail): Really fix the @ref syntax. 2010-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
--- a/doc/misc/gnus.texi Sat Oct 02 20:03:44 2010 -0400 +++ b/doc/misc/gnus.texi Sun Oct 03 00:33:27 2010 +0000 @@ -15111,7 +15111,7 @@ thinks should carry this mail message. This variable can also be a fancy split method. For the syntax, -@pxref{Fancy Mail Splitting}. +see @ref{Fancy Mail Splitting}. Note that the mail back ends are free to maul the poor, innocent, incoming headers all they want to. They all add @code{Lines} headers;
--- a/lisp/gnus/ChangeLog Sat Oct 02 20:03:44 2010 -0400 +++ b/lisp/gnus/ChangeLog Sun Oct 03 00:33:27 2010 +0000 @@ -1,3 +1,28 @@ +2010-10-02 Julien Danjou <julien@danjou.info> + + * gnus-util.el (gnus-iswitchb-completing-read): New function. + (gnus-ido-completing-read): New function. + (gnus-emacs-completing-read): New function. + (gnus-completing-read): Use gnus-completing-read-function. + Add gnus-completing-read-function. + +2010-10-02 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-insert-document): Autoload. + (shr-img): Be silent. + (shr-insert): Add a newline after every picture before text. + (shr-add-font): Use overlays for combining faces. + (shr-insert): Pass upwards the text start point. + + * mm-decode.el (mm-text-html-renderer): Default to shr.el rendering, if + possible. + (mm-shr): New function. + +2010-10-02 Julien Danjou <julien@danjou.info> + + * gnus-gravatar.el (gnus-gravatar-insert): Adjust character where we + should go backward. + 2010-10-02 Juanma Barranquero <lekktu@gmail.com> * shr.el (shr): Fix typo in provide call.
--- a/lisp/gnus/gnus-gravatar.el Sat Oct 02 20:03:44 2010 -0400 +++ b/lisp/gnus/gnus-gravatar.el Sun Oct 03 00:33:27 2010 +0000 @@ -76,7 +76,7 @@ (search-backward mail-address nil t))) (goto-char (1- (point))) ;; If we're on the " quoting the name, go backward - (when (looking-at "\"") + (when (looking-at "[\"<]") (goto-char (1- (point)))) ;; Do not do anything if there's already a gravatar. This can ;; happens if the buffer has been regenerated in the mean time, for
--- a/lisp/gnus/gnus-html.el Sat Oct 02 20:03:44 2010 -0400 +++ b/lisp/gnus/gnus-html.el Sun Oct 03 00:33:27 2010 +0000 @@ -402,7 +402,8 @@ (defun gnus-html-put-image (data url &optional alt-text) (when (gnus-graphic-display-p) - (let* ((start (text-property-any (point-min) (point-max) 'gnus-image-url url)) + (let* ((start (text-property-any (point-min) (point-max) + 'gnus-image-url url)) (end (when start (next-single-property-change start 'gnus-image-url)))) ;; Image found? @@ -416,7 +417,8 @@ (image-size image t))))) (save-excursion (goto-char start) - (let ((alt-text (or alt-text (buffer-substring-no-properties start end)))) + (let ((alt-text (or alt-text + (buffer-substring-no-properties start end)))) (if (and image ;; Kludge to avoid displaying 30x30 gif images, which ;; seems to be a signal of a broken image. @@ -424,8 +426,9 @@ (glyphp image) (listp image)) (eq (if (featurep 'xemacs) - (let ((d (cdadar (specifier-spec-list - (glyph-image image))))) + (let ((d (cdadar + (specifier-spec-list + (glyph-image image))))) (and (vectorp d) (aref d 0))) (plist-get (cdr image) :type)) @@ -437,17 +440,21 @@ (delete-region start end) (gnus-put-image image alt-text 'external) (gnus-put-text-property start (point) 'help-echo alt-text) - (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map - gnus-html-displayed-image-map) - (gnus-put-text-property start (point) 'gnus-alt-text alt-text) + (gnus-overlay-put + (gnus-make-overlay start (point)) 'local-map + gnus-html-displayed-image-map) + (gnus-put-text-property start (point) + 'gnus-alt-text alt-text) (when url - (gnus-put-text-property start (point) 'gnus-image-url url)) + (gnus-put-text-property start (point) + 'gnus-image-url url)) (gnus-add-image 'external image) t) ;; Bad image, try to show something else (when (fboundp 'find-image) (delete-region start end) - (setq image (find-image '((:type xpm :file "lock-broken.xpm")))) + (setq image (find-image + '((:type xpm :file "lock-broken.xpm")))) (gnus-put-image image alt-text 'internal) (gnus-add-image 'internal image)) nil)))))))) @@ -458,7 +465,8 @@ image (let* ((width (car size)) (height (cdr size)) - (edges (gnus-window-inside-pixel-edges (get-buffer-window (current-buffer)))) + (edges (gnus-window-inside-pixel-edges + (get-buffer-window (current-buffer)))) (window-width (truncate (* gnus-max-image-proportion (- (nth 2 edges) (nth 0 edges))))) (window-height (truncate (* gnus-max-image-proportion
--- a/lisp/gnus/gnus-util.el Sat Oct 02 20:03:44 2010 -0400 +++ b/lisp/gnus/gnus-util.el Sun Oct 03 00:33:27 2010 +0000 @@ -44,11 +44,19 @@ (defmacro with-no-warnings (&rest body) `(progn ,@body)))) -(defcustom gnus-use-ido nil - "Whether to use `ido' for `completing-read'." +(defcustom gnus-completing-read-function 'gnus-emacs-completing-read + "Function use to do completing read." :version "24.1" :group 'gnus-meta - :type 'boolean) + :type '(radio (function-item + :doc "Use Emacs standard `completing-read' function." + gnus-emacs-completing-read) + (function-item + :doc "Use `ido-completing-read' function." + gnus-ido-completing-read) + (function-item + :doc "Use iswitchb based completing-read function." + gnus-iswitchb-completing-read))) (defcustom gnus-completion-styles (if (and (boundp 'completion-styles-alist) @@ -1585,17 +1593,46 @@ (defun gnus-completing-read (prompt collection &optional require-match initial-input history def) - "Call `completing-read' or `ido-completing-read'. -Depends on `gnus-use-ido'." + "Call `gnus-completing-read-function'." + (funcall gnus-completing-read-function + (concat prompt (when def + (concat " (default " def ")")) + ": ") + collection require-match initial-input history def)) + +(defun gnus-emacs-completing-read (prompt collection &optional require-match + initial-input history def) + "Call standard `completing-read-function'." (let ((completion-styles gnus-completion-styles)) - (funcall - (if gnus-use-ido - 'ido-completing-read - 'completing-read) - (concat prompt (when def - (concat " (default " def ")")) - ": ") - collection nil require-match initial-input history def))) + (completing-read prompt collection nil require-match initial-input history def))) + +(defun gnus-ido-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `ido-completing-read-function'." + (require 'ido) + (ido-completing-read prompt collection nil require-match initial-input history def)) + +(defun gnus-iswitchb-completing-read (prompt collection &optional require-match + initial-input history def) + "`iswitchb' based completing-read function." + (require 'iswitchb) + (let ((iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist + (let ((choices (append + (when initial-input (list initial-input)) + (symbol-value history) collection)) + filtered-choices) + (dolist (x choices) + (setq filtered-choices (adjoin x filtered-choices))) + (nreverse filtered-choices)))))) + (unwind-protect + (progn + (when (not iswitchb-mode) + (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) + (iswitchb-read-buffer prompt def require-match)) + (when (not iswitchb-mode) + (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) (defun gnus-graphic-display-p () (if (featurep 'xemacs)
--- a/lisp/gnus/mm-decode.el Sat Oct 02 20:03:44 2010 -0400 +++ b/lisp/gnus/mm-decode.el Sun Oct 03 00:33:27 2010 +0000 @@ -105,7 +105,8 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((executable-find "w3m") 'gnus-article-html) + (cond ((fboundp 'libxml-parse-html-region) 'mm-shr) + ((executable-find "w3m") 'gnus-article-html) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) ((locate-library "w3") 'w3) @@ -1674,6 +1675,14 @@ (and (eq (mm-body-7-or-8) '7bit) (not (mm-long-lines-p 76)))))) +(defun mm-shr (handle) + (let ((article-buffer (current-buffer))) + (unless handle + (setq handle (mm-dissect-buffer t))) + (shr-insert-document + (mm-with-part handle + (libxml-parse-html-region (point-min) (point-max)))))) + (provide 'mm-decode) ;;; mm-decode.el ends here
--- a/lisp/gnus/shr.el Sat Oct 02 20:03:44 2010 -0400 +++ b/lisp/gnus/shr.el Sun Oct 03 00:33:27 2010 +0000 @@ -30,6 +30,217 @@ ;;; Code: +(defgroup shr nil + "Simple HTML Renderer" + :group 'mail) + +(defcustom shr-max-image-proportion 0.9 + "How big pictures displayed are in relation to the window they're in. +A value of 0.7 means that they are allowed to take up 70% of the +width and height of the window. If they are larger than this, +and Emacs supports it, then the images will be rescaled down to +fit these criteria." + :version "24.1" + :group 'shr + :type 'float) + +(defcustom shr-blocked-images nil + "Images that have URLs matching this regexp will be blocked." + :version "24.1" + :group 'shr + :type 'regexp) + +(defvar shr-folding-mode nil) +(defvar shr-state nil) +(defvar shr-start nil) + +(defvar shr-width 70) + +(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))) + +;;;###autoload +(defun shr-insert-document (dom) + (let ((shr-state nil) + (shr-start nil)) + (shr-descend (shr-transform-dom dom)))) + +(defun shr-descend (dom) + (let ((function (intern (concat "shr-" (symbol-name (car dom))) obarray))) + (if (fboundp function) + (funcall function (cdr dom)) + (shr-generic (cdr dom))))) + +(defun shr-generic (cont) + (dolist (sub cont) + (cond + ((eq (car sub) :text) + (shr-insert (cdr sub))) + ((consp (cdr sub)) + (shr-descend sub))))) + +(defun shr-p (cont) + (shr-ensure-newline) + (insert "\n") + (shr-generic cont) + (insert "\n")) + +(defun shr-b (cont) + (shr-fontize-cont cont 'bold)) + +(defun shr-i (cont) + (shr-fontize-cont cont 'italic)) + +(defun shr-u (cont) + (shr-fontize-cont cont 'underline)) + +(defun shr-s (cont) + (shr-fontize-cont cont 'strikethru)) + +(defun shr-fontize-cont (cont type) + (let (shr-start) + (shr-generic cont) + (shr-add-font shr-start (point) type))) + +(defun shr-add-font (start end type) + (let ((overlay (make-overlay start end))) + (overlay-put overlay 'face type))) + +(defun shr-a (cont) + (let ((url (cdr (assq :href cont))) + shr-start) + (shr-generic cont) + (widget-convert-button + 'link shr-start (point) + :action 'shr-browse-url + :url url + :keymap widget-keymap + :help-echo url))) + +(defun shr-browse-url (widget &rest stuff) + (browse-url (widget-get widget :url))) + +(defun shr-img (cont) + (let ((start (point-marker))) + (let ((alt (cdr (assq :alt cont))) + (url (cdr (assq :src cont)))) + (when (zerop (length alt)) + (setq alt "[img]")) + (cond + ((and shr-blocked-images + (string-match shr-blocked-images url)) + (insert alt)) + ((url-is-cached (browse-url-url-encode-chars url "[&)$ ]")) + (shr-put-image (shr-get-image-data url) (point) alt)) + (t + (insert alt) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) start (point-marker)) + t))) + (insert " ") + (setq shr-state 'image)))) + +(defun shr-image-fetched (status buffer start end) + (when (and (buffer-name buffer) + (not (plist-get status :error))) + (url-store-in-cache (current-buffer)) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (let ((alt (buffer-substring start end)) + (inhibit-read-only t)) + (delete-region start end) + (shr-put-image data start alt)))))) + (kill-buffer (current-buffer))) + +(defun shr-put-image (data point alt) + (if (not (display-graphic-p)) + (insert alt) + (let ((image (shr-rescale-image data))) + (put-image image point alt)))) + +(defun shr-rescale-image (data) + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + (create-image data nil t) + (let* ((image (create-image data nil t)) + (size (image-size image)) + (width (car size)) + (height (cdr size)) + (edges (window-inside-pixel-edges + (get-buffer-window (current-buffer)))) + (window-width (truncate (* shr-max-image-proportion + (- (nth 2 edges) (nth 0 edges))))) + (window-height (truncate (* shr-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))) + scaled-image) + (when (> height window-height) + (setq image (or (create-image data 'imagemagick t + :height window-height) + image)) + (setq size (image-size image t))) + (when (> (car size) window-width) + (setq image (or + (create-image data 'imagemagick t + :width window-width) + image))) + image))) + +(defun shr-pre (cont) + (let ((shr-folding-mode nil)) + (shr-ensure-newline) + (shr-generic cont) + (shr-ensure-newline))) + +(defun shr-blockquote (cont) + (shr-pre cont)) + +(defun shr-ensure-newline () + (unless (zerop (current-column)) + (insert "\n"))) + +(defun shr-insert (text) + (when (eq shr-state 'image) + (insert "\n") + (setq shr-state nil)) + (cond + ((eq shr-folding-mode 'none) + (insert t)) + (t + (let (column) + (dolist (elem (split-string text)) + (setq column (current-column)) + (when (plusp column) + (if (> (+ column (length elem) 1) shr-width) + (insert "\n") + (insert " "))) + ;; 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)))))) + +(defun shr-get-image-data (url) + "Get image data for URL. +Return a string with image data." + (with-temp-buffer + (mm-disable-multibyte) + (url-cache-extract (url-cache-create-filename url)) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (buffer-substring (point) (point-max))))) + (provide 'shr) ;;; shr.el ends here