mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-24 10:38:38 +00:00
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.
This commit is contained in:
parent
2a847524ab
commit
870409d4fb
@ -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>
|
||||
|
||||
|
@ -15111,7 +15111,7 @@ message. The function should return a list of group names that it
|
||||
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;
|
||||
|
@ -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.
|
||||
|
@ -76,7 +76,7 @@ Set image category to CATEGORY."
|
||||
(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
|
||||
|
@ -402,7 +402,8 @@ Return a string with image data."
|
||||
|
||||
(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 @@ Return a string with image data."
|
||||
(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 @@ Return a string with image data."
|
||||
(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 @@ Return a string with image data."
|
||||
(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 @@ Return a string with image data."
|
||||
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
|
||||
|
@ -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 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
|
||||
|
||||
(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)
|
||||
|
@ -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 @@ If RECURSIVE, search recursively."
|
||||
(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
|
||||
|
211
lisp/gnus/shr.el
211
lisp/gnus/shr.el
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user