X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-html.el;h=8571fdbe9112f9302922c012fd7b7f73ee38a7a7;hb=927cc9daf685365b19b5757522b6b4154b5d2d1f;hp=a693a2b842d86626fe597f39bb21c328de1c3b2b;hpb=7565b0b9f8381f2d2161f4048e71d05a6f9e9066;p=gnus diff --git a/lisp/gnus-html.el b/lisp/gnus-html.el index a693a2b84..8571fdbe9 100644 --- a/lisp/gnus-html.el +++ b/lisp/gnus-html.el @@ -37,6 +37,7 @@ (require 'url-cache) (require 'xml) (require 'browse-url) +(eval-and-compile (unless (featurep 'xemacs) (require 'help-fns))) (defcustom gnus-html-image-cache-ttl (days-to-time 7) "Time used to determine if we should use images from the cache." @@ -56,12 +57,6 @@ :group 'gnus-art :type 'integer) -(defcustom gnus-blocked-images "." - "Images that have URLs matching this regexp will be blocked." - :version "24.1" - :group 'gnus-art - :type 'regexp) - (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 @@ -88,9 +83,27 @@ 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))))) + (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." @@ -172,17 +185,16 @@ fit these criteria." ;; 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)))) + (let* ((handle (mm-get-content-id + (setq url (match-string 1 url)))) + (image (when handle + (gnus-create-image (mm-with-part handle (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-put-image (gnus-rescale-image image (gnus-html-maximum-image-size)) + (gnus-string-or string "*") 'cid) (gnus-add-image 'cid image)))) ;; Normal, external URL. (let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" @@ -193,8 +205,8 @@ fit these criteria." url (if (buffer-live-p gnus-summary-buffer) (with-current-buffer gnus-summary-buffer - gnus-blocked-images) - gnus-blocked-images)) + (gnus-blocked-images)) + (gnus-blocked-images))) (progn (widget-convert-button 'link start end @@ -203,7 +215,7 @@ fit these criteria." :keymap gnus-html-image-map :button-keymap gnus-html-image-map) (let ((overlay (gnus-make-overlay start end)) - (spec (list url 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 @@ -247,7 +259,7 @@ Use ALT-TEXT for the image string." (setq tag (match-string 1) parameters (match-string 2) start (match-beginning 0)) - (when (plusp (length parameters)) + (when (> (length parameters) 0) (set-text-properties 0 (1- (length parameters)) nil parameters)) (delete-region start (point)) (when (search-forward (concat "") nil t) @@ -263,7 +275,7 @@ Use ALT-TEXT for the image string." (setq url (match-string 1 parameters)) (gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url) (gnus-article-add-button start end - 'browse-url url + 'browse-url (mm-url-decode-entities-string url) url) (let ((overlay (gnus-make-overlay start end))) (gnus-overlay-put overlay 'evaporate t) @@ -345,10 +357,16 @@ Use ALT-TEXT for the image string." "Retrieve IMAGE, and place it into BUFFER on arrival." (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s" buffer image) - (ignore-errors - (url-retrieve (car image) - 'gnus-html-image-fetched - (list buffer image)))) + (let ((args (list (car image) + 'gnus-html-image-fetched + (list buffer image)))) + (when (> (length (if (featurep 'xemacs) + (cdr (split-string (function-arglist 'url-retrieve))) + (help-function-arglist 'url-retrieve))) + 4) + (setq args (nconc args (list t)))) + (ignore-errors + (apply #'url-retrieve args)))) (defun gnus-html-image-fetched (status buffer image) "Callback function called when image has been fetched." @@ -374,9 +392,25 @@ Return a string with image data." (search-forward "\r\n\r\n" nil t)) (buffer-substring (point) (point-max))))) +(defun gnus-html-maximum-image-size () + "Return the maximum size of an image according to `gnus-max-image-proportion'." + (let ((edges (gnus-window-inside-pixel-edges + (get-buffer-window (current-buffer))))) + ;; (width . height) + (cons + ;; Aimed width + (truncate + (* gnus-max-image-proportion + (- (nth 2 edges) (nth 0 edges)))) + ;; Aimed height + (truncate (* gnus-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))))) + (defun gnus-html-put-image (data url &optional alt-text) + "Put an image with DATA from URL and 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? @@ -390,7 +424,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. @@ -398,8 +433,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)) @@ -407,49 +443,29 @@ Return a string with image data." (= (car size) 30) (= (cdr size) 30)))) ;; Good image, add it! - (let ((image (gnus-html-rescale-image image data size))) + (let ((image (gnus-rescale-image image (gnus-html-maximum-image-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) + (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)))))))) -(defun gnus-html-rescale-image (image data size) - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) - image - (let* ((width (car size)) - (height (cdr size)) - (edges (window-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 - (- (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 gnus-html-image-url-blocked-p (url blocked-images) "Find out if URL is blocked by BLOCKED-IMAGES." (let ((ret (and blocked-images @@ -475,10 +491,11 @@ This only works if the article in question is HTML." (defun gnus-html-prefetch-images (summary) (when (buffer-live-p summary) (let ((blocked-images (with-current-buffer summary - gnus-blocked-images))) + (gnus-blocked-images)))) (save-match-data - (while (re-search-forward "]+src=[\"']\\(http[^\"']+\\)" nil t) + (let ((url (gnus-html-encode-url + (mm-url-decode-entities-string (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