X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-html.el;h=3ae3766ed624d1cc6624809b84cb97ecfc4d892e;hb=92bc187d1fcbe58bbd9c638b69a614c3bbad208e;hp=fee9eee0f9eb0351d677c31c28cd636a02cc2507;hpb=80c3e8ae02dc0bc5e6fc73d40c1925d82b7d3599;p=gnus diff --git a/lisp/gnus-html.el b/lisp/gnus-html.el index fee9eee0f..3ae3766ed 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." @@ -104,12 +105,7 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")." (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))) + encoded-text))))) (defun gnus-html-encode-url (url) "Encode URL." @@ -270,7 +266,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) @@ -368,10 +364,15 @@ 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) + (split-string (function-arglist 'url-retrieve)) + (help-function-arglist 'url-retrieve))) + 4) + (setq args (nconc args (list t)))) + (apply #'url-retrieve args))) (defun gnus-html-image-fetched (status buffer image) "Callback function called when image has been fetched." @@ -399,7 +400,8 @@ Return a string with image data." (defun gnus-html-put-image (data url &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? @@ -413,7 +415,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. @@ -421,8 +424,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)) @@ -430,49 +434,41 @@ 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 + (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))))))))) (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 (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 - (- (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