# HG changeset patch # User Katsumi Yamaoka # Date 1283991008 0 # Node ID 9be76f41f36f1c0edfa3b9101ed85378b3cea91f # Parent c7809974cd64d51c7317f6ddaecd5d291fe7ce65# Parent 8c1028027f1b3d691019d68124e8f934f22dd525 Merge changes made in Gnus trunk: gnus-html.el (gnus-html-schedule-image-fetching): Decode entities before feeding URLs to curl. gnus-async.el (gnus-async-article-callback): Call `gnus-html-prefetch-images' unconditionally. gnus-html.el: Allow showing the ALT text of images and to browse the images themselves. gnus-html (gnus-html-wash-tags): Search for images first, so that works better; (gnus-html-displayed-image-map): Bind RET and TAB on images for better UX. diff -r c7809974cd64 -r 9be76f41f36f lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Wed Sep 08 18:21:23 2010 +0200 +++ b/lisp/gnus/ChangeLog Thu Sep 09 00:10:08 2010 +0000 @@ -1,3 +1,18 @@ +2010-09-08 Lars Magne Ingebrigtsen + + * gnus-html.el (gnus-html-show-alt-text): New command. + (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 works + better. + + * gnus-async.el (gnus-async-article-callback): Call + `gnus-html-prefetch-images' unconditionally. + + * gnus-html.el (gnus-html-schedule-image-fetching): Decode entities + before feeding URLs to curl. + 2010-09-07 Katsumi Yamaoka * gnus-html.el (gnus-html-wash-tags, gnus-html-put-image): Mark cid and diff -r c7809974cd64 -r 9be76f41f36f lisp/gnus/gnus-async.el --- a/lisp/gnus/gnus-async.el Wed Sep 08 18:21:23 2010 +0200 +++ b/lisp/gnus/gnus-async.el Thu Sep 09 00:10:08 2010 +0000 @@ -237,13 +237,13 @@ (setq gnus-async-current-prefetch-article nil) (when arg (gnus-async-set-buffer) - (when gnus-async-post-fetch-function - (save-excursion - (save-restriction - (narrow-to-region mark (point-max)) - ;; Prefetch images for the groups that want that. - (when (fboundp 'gnus-html-prefetch-images) - (gnus-html-prefetch-images summary)) + (save-excursion + (save-restriction + (narrow-to-region mark (point-max)) + ;; Prefetch images for the groups that want that. + (when (fboundp 'gnus-html-prefetch-images) + (gnus-html-prefetch-images summary)) + (when gnus-async-post-fetch-function (funcall gnus-async-post-fetch-function summary)))) (gnus-async-with-semaphore (setq diff -r c7809974cd64 -r 9be76f41f36f lisp/gnus/gnus-html.el --- a/lisp/gnus/gnus-html.el Wed Sep 08 18:21:23 2010 +0200 +++ b/lisp/gnus/gnus-html.el Thu Sep 09 00:10:08 2010 +0000 @@ -72,6 +72,15 @@ (define-key map "i" 'gnus-html-insert-image) map)) +(defvar gnus-html-displayed-image-map + (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 (defun gnus-article-html (&optional handle) (let ((article-buffer (current-buffer))) @@ -111,15 +120,99 @@ (defvar gnus-article-mouse-face) +(defun gnus-html-pre-wash () + (goto-char (point-min)) + (while (re-search-forward " * * *\n" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (while (re-search-forward "]+>" 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 " * * *\n" nil t) - (replace-match "" t t)) + (gnus-html-pre-wash) (goto-char (point-min)) - (while (re-search-forward "]+>" nil t) - (replace-match "" t t)) + + ;; Search for all the images first. + (while (re-search-forward "]*\\)>" nil t) + (setq parameters (match-string 1) + start (match-beginning 0)) + (delete-region start (point)) + (when (search-forward "" (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) @@ -132,73 +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) - (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)))) - ;; 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 ALT text. - (delete-region start end) - (gnus-html-put-image file (point) string)) - ;; 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")) @@ -237,6 +264,24 @@ (gnus-html-schedule-image-fetching (current-buffer) (list (get-text-property (point) 'gnus-image)))) +(defun gnus-html-show-alt-text () + "Show the ALT text of the image under point." + (interactive) + (message "%s" (get-text-property (point) 'gnus-alt-text))) + +(defun gnus-html-browse-image () + "Browse the image under point." + (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) @@ -247,7 +292,7 @@ "--location" "--max-time" "60" "-o" (gnus-html-image-id url) - url))) + (mm-url-decode-entities-string url)))) (process-kill-without-query process) (set-process-sentinel process 'gnus-html-curl-sentinel) (gnus-set-process-plist process (list 'images images @@ -276,7 +321,7 @@ (when images (gnus-html-schedule-image-fetching buffer images))))) -(defun gnus-html-put-image (file point string) +(defun gnus-html-put-image (file point string &optional url alt-text) (when (gnus-graphic-display-p) (let* ((image (ignore-errors (gnus-create-image file))) @@ -301,11 +346,17 @@ 'gif) (= (car size) 30) (= (cdr size) 30)))) - (progn + (let ((start (point))) (setq image (gnus-html-rescale-image image file size)) (gnus-put-image image (gnus-string-or string "*") 'external) + (let ((overlay (gnus-make-overlay start (point)))) + (gnus-overlay-put overlay '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))) (gnus-add-image 'external image) t) (insert string) @@ -360,7 +411,7 @@ (delete-file (nth 2 file))))))) (defun gnus-html-image-url-blocked-p (url blocked-images) -"Find out if URL is blocked by BLOCKED-IMAGES." + "Find out if URL is blocked by BLOCKED-IMAGES." (let ((ret (and blocked-images (string-match blocked-images url)))) (if ret @@ -395,7 +446,7 @@ (let ((url (match-string 1))) (unless (gnus-html-image-url-blocked-p url blocked-images) (unless (file-exists-p (gnus-html-image-id url)) - (push url urls) + (push (mm-url-decode-entities-string url) urls) (push (gnus-html-image-id url) urls) (push "-o" urls))))) (let ((process