Mercurial > emacs
changeset 110278:8c1028027f1b
gnus-html (gnus-html-wash-tags): Search for images first, so that <a><img> works better; (gnus-html-displayed-image-map): Bind RET and TAB on images for better UX.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Thu, 09 Sep 2010 00:08:06 +0000 |
| parents | a46aad43ce5a |
| children | 9be76f41f36f a80e97ca2324 |
| files | lisp/gnus/ChangeLog lisp/gnus/gnus-html.el |
| diffstat | 2 files changed, 103 insertions(+), 75 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Wed Sep 08 23:59:52 2010 +0000 +++ b/lisp/gnus/ChangeLog Thu Sep 09 00:08:06 2010 +0000 @@ -4,6 +4,8 @@ (gnus-html-browse-image): Ditto. (gnus-html-wash-tags): Add the data to allow showing the ALT text and to browse the image directly. + (gnus-html-wash-tags): Search for images first, so that <a><img> works + better. * gnus-async.el (gnus-async-article-callback): Call `gnus-html-prefetch-images' unconditionally.
--- a/lisp/gnus/gnus-html.el Wed Sep 08 23:59:52 2010 +0000 +++ b/lisp/gnus/gnus-html.el Thu Sep 09 00:08:06 2010 +0000 @@ -76,6 +76,9 @@ (let ((map (make-sparse-keymap))) (define-key map "a" 'gnus-html-show-alt-text) (define-key map "i" 'gnus-html-browse-image) + (define-key map "\r" 'gnus-html-browse-url) + (define-key map "u" 'gnus-article-copy-string) + (define-key map [tab] 'widget-forward) map)) ;;;###autoload @@ -117,15 +120,99 @@ (defvar gnus-article-mouse-face) +(defun gnus-html-pre-wash () + (goto-char (point-min)) + (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (while (re-search-forward "<a name[^\n>]+>" nil t) + (replace-match "" t t))) + (defun gnus-html-wash-tags () (let (tag parameters string start end images url) - (goto-char (point-min)) - (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t) - (replace-match "" t t)) + (gnus-html-pre-wash) (goto-char (point-min)) - (while (re-search-forward "<a name[^\n>]+>" nil t) - (replace-match "" t t)) + + ;; Search for all the images first. + (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t) + (setq parameters (match-string 1) + start (match-beginning 0)) + (delete-region start (point)) + (when (search-forward "</img_alt>" (line-end-position) t) + (delete-region (match-beginning 0) (match-end 0))) + (setq end (point)) + (when (string-match "src=\"\\([^\"]+\\)" parameters) + (setq url (match-string 1 parameters)) + (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) + (if (string-match "^cid:\\(.*\\)" url) + ;; URLs with cid: have their content stashed in other + ;; parts of the MIME structure, so just insert them + ;; immediately. + (let ((handle (mm-get-content-id + (setq url (match-string 1 url)))) + image) + (when handle + (mm-with-part handle + (setq image (gnus-create-image (buffer-string) + nil t)))) + (when image + (let ((string (buffer-substring start end))) + (delete-region start end) + (gnus-put-image image (gnus-string-or string "*") 'cid) + (gnus-add-image 'cid image)))) + ;; Normal, external URL. + (if (gnus-html-image-url-blocked-p + url + (if (buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-blocked-images) + gnus-blocked-images)) + (progn + (widget-convert-button + 'link start end + :action 'gnus-html-insert-image + :help-echo url + :keymap gnus-html-image-map + :button-keymap gnus-html-image-map) + (let ((overlay (gnus-make-overlay start end)) + (spec (list url + (set-marker (make-marker) start) + (set-marker (make-marker) end)))) + (gnus-overlay-put overlay 'local-map gnus-html-image-map) + (gnus-overlay-put overlay 'gnus-image spec) + (gnus-put-text-property + start end + 'gnus-image spec))) + (let ((file (gnus-html-image-id url)) + width height alt-text) + (when (string-match "height=\"?\\([0-9]+\\)" parameters) + (setq height (string-to-number (match-string 1 parameters)))) + (when (string-match "width=\"?\\([0-9]+\\)" parameters) + (setq width (string-to-number (match-string 1 parameters)))) + (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" + parameters) + (setq alt-text (match-string 2 parameters))) + ;; Don't fetch images that are really small. They're + ;; probably tracking pictures. + (when (and (or (null height) + (> height 4)) + (or (null width) + (> width 4))) + (if (file-exists-p file) + ;; It's already cached, so just insert it. + (let ((string (buffer-substring start end))) + ;; Delete the IMG text. + (delete-region start end) + (gnus-html-put-image file (point) string url alt-text)) + ;; We don't have it, so schedule it for fetching + ;; asynchronously. + (push (list url + (set-marker (make-marker) start) + (point-marker)) + images)))))))) + (goto-char (point-min)) + ;; Then do the other tags. (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t) (setq tag (match-string 1) parameters (match-string 2) @@ -138,76 +225,7 @@ (setq end (point)) (cond ;; Fetch and insert a picture. - ((equal tag "img_alt") - (when (string-match "src=\"\\([^\"]+\\)" parameters) - (setq url (match-string 1 parameters)) - (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) - (if (string-match "^cid:\\(.*\\)" url) - ;; URLs with cid: have their content stashed in other - ;; parts of the MIME structure, so just insert them - ;; immediately. - (let ((handle (mm-get-content-id - (setq url (match-string 1 url)))) - image) - (when handle - (mm-with-part handle - (setq image (gnus-create-image (buffer-string) - nil t)))) - (when image - (let ((string (buffer-substring start end))) - (delete-region start end) - (gnus-put-image image (gnus-string-or string "*") 'cid) - (gnus-add-image 'cid image)))) - ;; Normal, external URL. - (if (gnus-html-image-url-blocked-p - url - (if (buffer-live-p gnus-summary-buffer) - (with-current-buffer gnus-summary-buffer - gnus-blocked-images) - gnus-blocked-images)) - (progn - (widget-convert-button - 'link start end - :action 'gnus-html-insert-image - :help-echo url - :keymap gnus-html-image-map - :button-keymap gnus-html-image-map) - (let ((overlay (gnus-make-overlay start end)) - (spec (list url - (set-marker (make-marker) start) - (set-marker (make-marker) end)))) - (gnus-overlay-put overlay 'local-map gnus-html-image-map) - (gnus-overlay-put overlay 'gnus-image spec) - (gnus-put-text-property - start end - 'gnus-image spec))) - (let ((file (gnus-html-image-id url)) - width height alt-text) - (when (string-match "height=\"?\\([0-9]+\\)" parameters) - (setq height (string-to-number (match-string 1 parameters)))) - (when (string-match "width=\"?\\([0-9]+\\)" parameters) - (setq width (string-to-number (match-string 1 parameters)))) - (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" - parameters) - (setq alt-text (match-string 2 parameters))) - ;; Don't fetch images that are really small. They're - ;; probably tracking pictures. - (when (and (or (null height) - (> height 4)) - (or (null width) - (> width 4))) - (if (file-exists-p file) - ;; It's already cached, so just insert it. - (let ((string (buffer-substring start end))) - ;; Delete the IMG text. - (delete-region start end) - (gnus-html-put-image file (point) string url alt-text)) - ;; We don't have it, so schedule it for fetching - ;; asynchronously. - (push (list url - (set-marker (make-marker) start) - (point-marker)) - images)))))))) + ((equal tag "img_alt")) ;; Add a link. ((or (equal tag "a") (equal tag "A")) @@ -256,6 +274,14 @@ (interactive) (browse-url (get-text-property (point) 'gnus-image))) +(defun gnus-html-browse-url () + "Browse the image under point." + (interactive) + (let ((url (get-text-property (point) 'gnus-string))) + (if (not url) + (message "No URL at point") + (browse-url url)))) + (defun gnus-html-schedule-image-fetching (buffer images) (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s" buffer images)