(eval-when-compile (require 'cl))
(eval-when-compile (require 'mm-decode))
+
+(require 'gnus-art)
(require 'mm-url)
+(require 'url)
+(require 'url-cache)
+(require 'xml)
+(require 'browse-url)
-(defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/")
- "Where Gnus will cache images it downloads from the web."
+(defcustom gnus-html-image-cache-ttl (days-to-time 7)
+ "Time used to determine if we should use images from the cache."
:version "24.1"
:group 'gnus-art
- :type 'directory)
+ :type 'integer)
-(defcustom gnus-html-cache-size 500000000
- "The size of the Gnus image cache."
+(defcustom gnus-html-image-automatic-caching t
+ "Whether automatically cache retrieve images."
:version "24.1"
:group 'gnus-art
- :type 'integer)
+ :type 'boolean)
(defcustom gnus-html-frame-width 70
"What width to use when rendering HTML."
: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,
(let ((map (make-sparse-keymap)))
(define-key map "u" 'gnus-article-copy-string)
(define-key map "i" 'gnus-html-insert-image)
+ (define-key map "v" 'gnus-html-browse-url)
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))
+
+(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."
+ (gnus-html-encode-url-chars url "[)$ ]"))
+
+(defun gnus-html-cache-expired (url ttl)
+ "Check if URL is cached for more than TTL."
+ (cond (url-standalone-mode
+ (not (file-exists-p (url-cache-create-filename url))))
+ (t (let ((cache-time (url-is-cached url)))
+ (if cache-time
+ (time-less-p
+ (time-add
+ cache-time
+ ttl)
+ (current-time))
+ t)))))
+
;;;###autoload
-(defun gnus-article-html (handle)
+(defun gnus-article-html (&optional handle)
(let ((article-buffer (current-buffer)))
+ (unless handle
+ (setq handle (mm-dissect-buffer t)))
(save-restriction
(narrow-to-region (point) (point))
(save-excursion
"-I" "UTF-8"
"-O" "UTF-8"
"-o" "ext_halfdump=1"
+ "-o" "display_ins_del=2"
"-o" "pre_conv=1"
"-t" (format "%s" tab-width)
"-cols" (format "%s" gnus-html-frame-width)
(defvar gnus-article-mouse-face)
-(defun gnus-html-wash-tags ()
+(defun gnus-html-pre-wash ()
+ (goto-char (point-min))
+ (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (while (re-search-forward "<a name[^\n>]+>" nil t)
+ (replace-match "" t t)))
+
+(defun gnus-html-wash-images ()
+ "Run through current buffer and replace img tags by images."
(let (tag parameters string start end images url)
- (mm-url-decode-entities)
(goto-char (point-min))
- (while (re-search-forward " *<pre_int> *</pre_int>\n" nil t)
- (replace-match "" t t))
+ ;; Search for all the images first.
+ (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
+ (setq parameters (match-string 1)
+ start (match-beginning 0))
+ (delete-region start (point))
+ (when (search-forward "</img_alt>" (line-end-position) t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (setq end (point))
+ (when (string-match "src=\"\\([^\"]+\\)" 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
+ ;; 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.
+ (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)
+ (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 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 spec)))
+ ;; Non-blocked url
+ (let ((width
+ (when (string-match "width=\"?\\([0-9]+\\)" parameters)
+ (string-to-number (match-string 1 parameters))))
+ (height
+ (when (string-match "height=\"?\\([0-9]+\\)" parameters)
+ (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)))
+ (gnus-html-display-image url start end alt-text))))))))))
+
+(defun gnus-html-display-image (url start end alt-text)
+ "Display image at URL on text from START to END.
+Use ALT-TEXT for the image string."
+ (if (gnus-html-cache-expired url gnus-html-image-cache-ttl)
+ ;; We don't have it, so schedule it for fetching
+ ;; asynchronously.
+ (gnus-html-schedule-image-fetching
+ (current-buffer)
+ (list url alt-text))
+ ;; It's already cached, so just insert it.
+ (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)
+ (gnus-html-pre-wash)
+ (gnus-html-wash-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)
(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 "*")))))
- ;; 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
-
projects / gnus / blobdiff