Mercurial > emacs
diff lisp/gnus/gnus-html.el @ 110486:1ad1adb298a3
Merge Changes made in Gnus trunk.
gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to get the start of data.
gnus-html.el: Use gnus-html-encode-url to encode URL.
gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks outside the active range.
gnus.el: Try to keep the server/method cache unique.
gnus-html.el (gnus-html-rescale-image): Use window-inside-pixel-edges rather than window-pixel-edges.
gnus-html.el (gnus-html-put-image): Stop using markers.
gnus-html.el (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of data.
nnimap.el: Expunge IMAP groups by default on article deletion.
gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since this command might take a while.
nnimap.el (nnimap-request-list): Set the current nnimap group to nil, since EXAMINE changes it on the server.
nnmail.el, nnimap.el: Allow nnimap to just delete 'junk messages when splitting.
nnimap.el (nnimap-parse-flags): Make IMAP flags parsing much faster by using `read'.
nnimap.el (nnimap-make-process-buffer): Record the server name.
gnus-html.el (gnus-html-image-fetched): Only cache if gnus-html-image-automatic-caching is set.
gnus-html.el (gnus-html-image-fetched): Check for errors.
gnus-start.el (gnus-read-active-for-groups): Only run -request-scan once per method on `g'.
nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is immediate, then expire all articles.
gnus-group.el (gnus-group-get-icon): Compute icon to return.
gnus-group.el (gnus-group-icon-list): Fix bad docstring information.
nnimap.el (nnimap-update-info): Fix up various off-by-one errors when syncing flags in nnimap.
time-date.el (date-to-time): Speed up date-to-time.
gnus-start.el (gnus-get-unread-articles): Don't have `gnus-get-unread-articles-in-group' update info.
gnus-group.el: Remove gnus-group-highlight-line from the default hook list.
gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start.
gnus-group.el (gnus-group-insert-group-line): Pass the real group name so that it gets the right data.
gnus-int.el (gnus-open-server): Add tracing for performance debugging.
nnimap.el (nnimap-parse-flags): Parse the data in any order.
nnimap.el (nnimap-update-info): Fix up code slightly.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Thu, 23 Sep 2010 00:30:37 +0000 |
parents | f97b4d2abce9 |
children | d3b676998c45 |
line wrap: on
line diff
--- a/lisp/gnus/gnus-html.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus-html.el Thu Sep 23 00:30:37 2010 +0000 @@ -36,13 +36,20 @@ (require 'url) (require 'url-cache) (require 'xml) +(require 'browse-url) (defcustom gnus-html-image-cache-ttl (days-to-time 7) - "Time in seconds used to cache the image on disk." + "Time used to determine if we should use images from the cache." :version "24.1" :group 'gnus-art :type 'integer) +(defcustom gnus-html-image-automatic-caching t + "Whether automatically cache retrieve images." + :version "24.1" + :group 'gnus-art + :type 'boolean) + (defcustom gnus-html-frame-width 70 "What width to use when rendering HTML." :version "24.1" @@ -81,6 +88,10 @@ (define-key map [tab] 'widget-forward) map)) +(defun gnus-html-encode-url (url) + "Encode URL." + (browse-url-url-encode-chars url "[)$ ]")) + (defun gnus-html-cache-expired (url ttl) "Check if URL is cached for more than TTL." (cond (url-standalone-mode @@ -155,7 +166,7 @@ (delete-region (match-beginning 0) (match-end 0))) (setq end (point)) (when (string-match "src=\"\\([^\"]+\\)" parameters) - (setq url (match-string 1 parameters)) + (setq url (gnus-html-encode-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 @@ -177,6 +188,7 @@ (let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" parameters) (xml-substitute-special (match-string 2 parameters))))) + (gnus-put-text-property start end 'gnus-image-url url) (if (gnus-html-image-url-blocked-p url (if (buffer-live-p gnus-summary-buffer) @@ -191,13 +203,9 @@ :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) - alt-text))) + (spec (list url alt-text))) (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-url url) (gnus-put-text-property start end 'gnus-image spec))) @@ -224,13 +232,9 @@ ;; asynchronously. (gnus-html-schedule-image-fetching (current-buffer) - (list url - (set-marker (make-marker) start) - (set-marker (make-marker) end) - alt-text)) + (list url alt-text)) ;; It's already cached, so just insert it. - (gnus-html-put-image (gnus-html-get-image-data url) - start end url alt-text))) + (gnus-html-put-image (gnus-html-get-image-data url) url alt-text))) (defun gnus-html-wash-tags () (let (tag parameters string start end images url) @@ -347,22 +351,17 @@ (list buffer image)))) (defun gnus-html-image-fetched (status buffer image) - (url-store-in-cache (current-buffer)) - (when (and (search-forward "\n\n" nil t) - (buffer-live-p buffer) - ;; If the `image' has no marker, do not replace anything - (cadr image) - ;; If the position of the marker is 1, then that - ;; means that the text it was in has been deleted; - ;; i.e., that the user has selected a different - ;; article before the image arrived. - (not (= (marker-position (cadr image)) - (with-current-buffer buffer - (point-min))))) - (let ((data (buffer-substring (point) (point-max)))) - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image)))))) + "Callback function called when image has been fetched." + (unless (plist-get status :error) + (when gnus-html-image-automatic-caching + (url-store-in-cache (current-buffer))) + (when (and (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (buffer-live-p buffer)) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (gnus-html-put-image data (car image) (cadr image))))))) (kill-buffer (current-buffer))) (defun gnus-html-get-image-data (url) @@ -371,54 +370,61 @@ (with-temp-buffer (mm-disable-multibyte) (url-cache-extract (url-cache-create-filename url)) - (when (search-forward "\n\n" nil t) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) (buffer-substring (point) (point-max))))) -(defun gnus-html-put-image (data start end &optional url alt-text) +(defun gnus-html-put-image (data url &optional alt-text) (when (gnus-graphic-display-p) - (let* ((image (ignore-errors - (gnus-create-image data nil t))) - (size (and image - (if (featurep 'xemacs) - (cons (glyph-width image) (glyph-height image)) - (image-size image t))))) - (save-excursion - (goto-char start) - (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. - (not (and (if (featurep 'xemacs) - (glyphp image) - (listp image)) - (eq (if (featurep 'xemacs) - (let ((d (cdadar (specifier-spec-list - (glyph-image image))))) - (and (vectorp d) - (aref d 0))) - (plist-get (cdr image) :type)) - 'gif) - (= (car size) 30) - (= (cdr size) 30)))) - ;; Good image, add it! - (let ((image (gnus-html-rescale-image image data size))) - (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) - (when url - (gnus-put-text-property start (point) 'gnus-image-url url)) - (gnus-add-image 'external image) - t) - ;; Bad image, try to show something else - (delete-region start end) - (when (fboundp 'find-image) - (setq image (find-image '((:type xpm :file "lock-broken.xpm")))) - (gnus-put-image image alt-text 'internal) - (gnus-add-image 'internal image)) - nil)))))) + (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? + (when start + (let* ((image + (ignore-errors + (gnus-create-image data nil t))) + (size (and image + (if (featurep 'xemacs) + (cons (glyph-width image) (glyph-height image)) + (image-size image t))))) + (save-excursion + (goto-char start) + (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. + (not (and (if (featurep 'xemacs) + (glyphp image) + (listp image)) + (eq (if (featurep 'xemacs) + (let ((d (cdadar (specifier-spec-list + (glyph-image image))))) + (and (vectorp d) + (aref d 0))) + (plist-get (cdr image) :type)) + 'gif) + (= (car size) 30) + (= (cdr size) 30)))) + ;; Good image, add it! + (let ((image (gnus-html-rescale-image image data size))) + (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) + (when 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")))) + (gnus-put-image image alt-text 'internal) + (gnus-add-image 'internal image)) + nil)))))))) (defun gnus-html-rescale-image (image data size) (if (or (not (fboundp 'imagemagick-types)) @@ -426,7 +432,7 @@ image (let* ((width (car size)) (height (cdr size)) - (edges (window-pixel-edges (get-buffer-window (current-buffer)))) + (edges (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 @@ -472,7 +478,7 @@ gnus-blocked-images))) (save-match-data (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t) - (let ((url (match-string 1))) + (let ((url (gnus-html-encode-url (match-string 1)))) (unless (gnus-html-image-url-blocked-p url blocked-images) (when (gnus-html-cache-expired url gnus-html-image-cache-ttl) (gnus-html-schedule-image-fetching nil