X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-html.el;h=fee9eee0f9eb0351d677c31c28cd636a02cc2507;hb=2b3087478de94ab00415aac1c01c9b5b13289864;hp=d91db08c38e19a6e628def7a199edbf4b5a085c1;hpb=707f51a37c63cc5df71b0c829d4648b0742ee62c;p=gnus diff --git a/lisp/gnus-html.el b/lisp/gnus-html.el index d91db08c3..fee9eee0f 100644 --- a/lisp/gnus-html.el +++ b/lisp/gnus-html.el @@ -39,11 +39,17 @@ (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" @@ -56,7 +62,7 @@ :group 'gnus-art :type 'regexp) -(defcustom gnus-max-image-proportion 0.7 +(defcustom gnus-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, @@ -82,9 +88,32 @@ fit these criteria." (define-key map [tab] 'widget-forward) map)) +(eval-and-compile + (defalias 'gnus-html-encode-url-chars + (if (fboundp 'browse-url-url-encode-chars) + 'browse-url-url-encode-chars + (lambda (text chars) + "URL-encode the chars in TEXT that match CHARS. +CHARS is a regexp-like character alternative (e.g., \"[)$]\")." + (let ((encoded-text (copy-sequence text)) + (s 0)) + (while (setq s (string-match chars encoded-text s)) + (setq encoded-text + (replace-match (format "%%%x" + (string-to-char + (match-string 0 encoded-text))) + t t encoded-text) + s (1+ s))) + encoded-text)))) + ;; XEmacs does not have window-inside-pixel-edges + (defalias 'gnus-window-inside-pixel-edges + (if (fboundp 'window-inside-pixel-edges) + 'window-inside-pixel-edges + 'window-pixel-edges))) + (defun gnus-html-encode-url (url) "Encode URL." - (browse-url-url-encode-chars url "[)$ ]")) + (gnus-html-encode-url-chars url "[)$ ]")) (defun gnus-html-cache-expired (url ttl) "Check if URL is cached for more than TTL." @@ -182,6 +211,7 @@ fit these criteria." (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) @@ -196,13 +226,9 @@ fit these criteria." :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 start end 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))) @@ -229,13 +255,9 @@ Use ALT-TEXT for the image string." ;; 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) @@ -352,22 +374,17 @@ Use ALT-TEXT for the image string." (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) @@ -380,51 +397,57 @@ Return a string with image data." (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)) @@ -432,7 +455,7 @@ Return a string with image data." image (let* ((width (car size)) (height (cdr size)) - (edges (window-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 @@ -477,7 +500,7 @@ This only works if the article in question is HTML." (let ((blocked-images (with-current-buffer summary gnus-blocked-images))) (save-match-data - (while (re-search-forward "]+src=[\"']\\([^\"']+\\)" nil t) (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)